| 1 |
# Magnus & Neudecker (1999) style matrix operations |
|
| 2 |
# YR - 11 may 2011: initial version |
|
| 3 |
# YR - 19 okt 2014: rename functions using lav_matrix_ prefix |
|
| 4 | ||
| 5 |
# vec operator |
|
| 6 |
# |
|
| 7 |
# the vec operator (for 'vectorization') transforms a matrix into |
|
| 8 |
# a vector by stacking the *columns* of the matrix one underneath the other |
|
| 9 |
# |
|
| 10 |
# M&N book: page 30 |
|
| 11 |
# |
|
| 12 |
# note: we do not coerce to 'double/numeric' storage-mode (like as.numeric) |
|
| 13 |
lav_matrix_vec <- function(A) {
|
|
| 14 | 5921x |
as.vector(A) |
| 15 |
} |
|
| 16 | ||
| 17 | ||
| 18 |
# vecr operator |
|
| 19 |
# |
|
| 20 |
# the vecr operator ransforms a matrix into |
|
| 21 |
# a vector by stacking the *rows* of the matrix one underneath the other |
|
| 22 |
lav_matrix_vecr <- function(A) {
|
|
| 23 |
# faster way?? |
|
| 24 |
# nRow <- NROW(A); nCol <- NCOL(A) |
|
| 25 |
# idx <- (seq_len(nCol) - 1L) * nRow + rep(seq_len(nRow), each = nCol) |
|
| 26 |
# if (lav_use_lavaanC() && is.numeric(A)) {
|
|
| 27 |
# return(lavaanC::m_vecr(A)) |
|
| 28 |
# } |
|
| 29 | ! |
lav_matrix_vec(t(A)) |
| 30 |
} |
|
| 31 | ||
| 32 | ||
| 33 |
# vech |
|
| 34 |
# |
|
| 35 |
# the vech operator (for 'half vectorization') transforms a *symmetric* matrix |
|
| 36 |
# into a vector by stacking the *columns* of the matrix one underneath the |
|
| 37 |
# other, but eliminating all supradiagonal elements |
|
| 38 |
# |
|
| 39 |
# see Henderson & Searle, 1979 |
|
| 40 |
# |
|
| 41 |
# M&N book: page 48-49 |
|
| 42 |
# |
|
| 43 |
lav_matrix_vech <- function(S, diagonal = TRUE) {
|
|
| 44 |
# if (lav_use_lavaanC() && is.numeric(S)) {
|
|
| 45 |
# return(lavaanC::m_vech(S, diagonal)) |
|
| 46 |
# } |
|
| 47 | 20711x |
ROW <- row(S) |
| 48 | 20711x |
COL <- col(S) |
| 49 | 7099x |
if (diagonal) S[ROW >= COL] else S[ROW > COL] |
| 50 |
} |
|
| 51 | ||
| 52 | ||
| 53 |
# the vechr operator transforms a *symmetric* matrix |
|
| 54 |
# into a vector by stacking the *rows* of the matrix one after the |
|
| 55 |
# other, but eliminating all supradiagonal elements |
|
| 56 |
lav_matrix_vechr <- function(S, diagonal = TRUE) {
|
|
| 57 |
# if (lav_use_lavaanC() && is.numeric(S)) {
|
|
| 58 |
# return(lavaanC::m_vechr(S, diagonal)) |
|
| 59 |
# } |
|
| 60 | ! |
S[lav_matrix_vechr_idx(n = NCOL(S), diagonal = diagonal)] |
| 61 |
} |
|
| 62 | ||
| 63 | ||
| 64 |
# the vechu operator transforms a *symmetric* matrix |
|
| 65 |
# into a vector by stacking the *columns* of the matrix one after the |
|
| 66 |
# other, but eliminating all infradiagonal elements |
|
| 67 |
lav_matrix_vechu <- function(S, diagonal = TRUE) {
|
|
| 68 |
# if (lav_use_lavaanC() && is.numeric(S)) {
|
|
| 69 |
# return(lavaanC::m_vechu(S, diagonal)) |
|
| 70 |
# } |
|
| 71 | 1235x |
S[lav_matrix_vechu_idx(n = NCOL(S), diagonal = diagonal)] |
| 72 |
} |
|
| 73 | ||
| 74 |
# the vechru operator transforms a *symmetric* matrix |
|
| 75 |
# into a vector by stacking the *rows* of the matrix one after the |
|
| 76 |
# other, but eliminating all infradiagonal elements |
|
| 77 |
# |
|
| 78 |
# same as vech (but using upper-diagonal elements) |
|
| 79 |
lav_matrix_vechru <- function(S, diagonal = TRUE) {
|
|
| 80 |
# if (lav_use_lavaanC() && is.numeric(S)) {
|
|
| 81 |
# return(lavaanC::m_vechru(S, diagonal)) |
|
| 82 |
# } |
|
| 83 | 78x |
S[lav_matrix_vechru_idx(n = NCOL(S), diagonal = diagonal)] |
| 84 |
} |
|
| 85 | ||
| 86 |
# return the *vector* indices of the lower triangular elements of a |
|
| 87 |
# symmetric matrix of size 'n' |
|
| 88 |
lav_matrix_vech_idx <- function(n = 1L, diagonal = TRUE) {
|
|
| 89 | 77215x |
n <- as.integer(n) |
| 90 |
# if (lav_use_lavaanC() && n > 1L) {
|
|
| 91 |
# return(lavaanC::m_vech_idx(n, diagonal)) |
|
| 92 |
# } |
|
| 93 | 77215x |
if (n < 100L) {
|
| 94 | 77215x |
ROW <- matrix(seq_len(n), n, n) |
| 95 | 77215x |
COL <- matrix(seq_len(n), n, n, byrow = TRUE) |
| 96 | 24534x |
if (diagonal) which(ROW >= COL) else which(ROW > COL) |
| 97 |
} else {
|
|
| 98 |
# ldw version |
|
| 99 | ! |
if (diagonal) {
|
| 100 | ! |
unlist(lapply( |
| 101 | ! |
seq_len(n), |
| 102 | ! |
function(j) (j - 1L) * n + seq.int(j, n) |
| 103 |
)) |
|
| 104 |
} else {
|
|
| 105 | ! |
unlist(lapply( |
| 106 | ! |
seq_len(n - 1L), |
| 107 | ! |
function(j) (j - 1L) * n + seq.int(j + 1L, n) |
| 108 |
)) |
|
| 109 |
} |
|
| 110 |
} |
|
| 111 |
} |
|
| 112 | ||
| 113 |
# return the *row* indices of the lower triangular elements of a |
|
| 114 |
# symmetric matrix of size 'n' |
|
| 115 |
lav_matrix_vech_row_idx <- function(n = 1L, diagonal = TRUE) {
|
|
| 116 | 26x |
n <- as.integer(n) |
| 117 |
# if (lav_use_lavaanC() && n > 1L) {
|
|
| 118 |
# return(lavaanC::m_vech_row_idx(n, diagonal)) |
|
| 119 |
# } |
|
| 120 | 26x |
if (diagonal) {
|
| 121 | 26x |
unlist(lapply(seq_len(n), seq.int, n)) |
| 122 |
} else {
|
|
| 123 | ! |
1 + unlist(lapply(seq_len(n - 1), seq.int, n - 1)) |
| 124 |
} |
|
| 125 |
} |
|
| 126 | ||
| 127 |
# return the *col* indices of the lower triangular elements of a |
|
| 128 |
# symmetric matrix of size 'n' |
|
| 129 |
lav_matrix_vech_col_idx <- function(n = 1L, diagonal = TRUE) {
|
|
| 130 | 26x |
n <- as.integer(n) |
| 131 |
# if (lav_use_lavaanC() && n > 1L) {
|
|
| 132 |
# return(lavaanC::m_vech_col_idx(n, diagonal)) |
|
| 133 |
# } |
|
| 134 | 26x |
if (!diagonal) {
|
| 135 | ! |
n <- n - 1L |
| 136 |
} |
|
| 137 | 26x |
rep.int(seq_len(n), times = rev(seq_len(n))) |
| 138 |
} |
|
| 139 | ||
| 140 | ||
| 141 | ||
| 142 | ||
| 143 |
# return the *vector* indices of the lower triangular elements of a |
|
| 144 |
# symmetric matrix of size 'n' -- ROW-WISE |
|
| 145 |
lav_matrix_vechr_idx <- function(n = 1L, diagonal = TRUE) {
|
|
| 146 | 3x |
n <- as.integer(n) |
| 147 |
# if (lav_use_lavaanC() && n > 1L) {
|
|
| 148 |
# return(lavaanC::m_vechr_idx(n, diagonal)) |
|
| 149 |
# } |
|
| 150 | 3x |
if (n < 100L) {
|
| 151 | 3x |
ROW <- matrix(seq_len(n), n, n) |
| 152 | 3x |
COL <- matrix(seq_len(n), n, n, byrow = TRUE) |
| 153 | 3x |
tmp <- matrix(seq_len(n * n), n, n, byrow = TRUE) |
| 154 | ! |
if (diagonal) tmp[ROW <= COL] else tmp[ROW < COL] |
| 155 |
} else {
|
|
| 156 | ! |
if (diagonal) {
|
| 157 | ! |
unlist(lapply( |
| 158 | ! |
seq_len(n), |
| 159 | ! |
function(j) seq.int(1, j) * n - (n - j) |
| 160 |
)) |
|
| 161 |
} else {
|
|
| 162 | ! |
unlist(lapply( |
| 163 | ! |
seq_len(n - 1L), |
| 164 | ! |
function(j) seq.int(1, j) * n - (n - j) + 1 |
| 165 |
)) |
|
| 166 |
} |
|
| 167 |
} |
|
| 168 |
} |
|
| 169 | ||
| 170 |
# return the *vector* indices of the upper triangular elements of a |
|
| 171 |
# symmetric matrix of size 'n' -- COLUMN-WISE |
|
| 172 |
lav_matrix_vechu_idx <- function(n = 1L, diagonal = TRUE) {
|
|
| 173 | 1238x |
n <- as.integer(n) |
| 174 |
# if (lav_use_lavaanC() && n > 1L) {
|
|
| 175 |
# return(lavaanC::m_vechu_idx(n, diagonal)) |
|
| 176 |
# } |
|
| 177 | 1238x |
if (n < 100L) {
|
| 178 | 1238x |
ROW <- matrix(seq_len(n), n, n) |
| 179 | 1238x |
COL <- matrix(seq_len(n), n, n, byrow = TRUE) |
| 180 | 3x |
if (diagonal) which(ROW <= COL) else which(ROW < COL) |
| 181 |
} else {
|
|
| 182 | ! |
if (diagonal) {
|
| 183 | ! |
unlist(lapply(seq_len(n), function(j) seq.int(j) + (j - 1) * n)) |
| 184 |
} else {
|
|
| 185 | ! |
unlist(lapply(seq_len(n - 1L), function(j) seq.int(j) + j * n)) |
| 186 |
} |
|
| 187 |
} |
|
| 188 |
} |
|
| 189 | ||
| 190 |
# return the *vector* indices of the upper triangular elements of a |
|
| 191 |
# symmetric matrix of size 'n' -- ROW-WISE |
|
| 192 |
lav_matrix_vechru_idx <- function(n = 1L, diagonal = TRUE) {
|
|
| 193 | 8571x |
n <- as.integer(n) |
| 194 |
# if (lav_use_lavaanC() && n > 1L) {
|
|
| 195 |
# return(lavaanC::m_vechru_idx(n, diagonal)) |
|
| 196 |
# } |
|
| 197 | 8571x |
if (n < 100L) {
|
| 198 |
# FIXME!! make this more efficient (without creating 3 n*n matrices!) |
|
| 199 | 8571x |
ROW <- matrix(seq_len(n), n, n) |
| 200 | 8571x |
COL <- matrix(seq_len(n), n, n, byrow = TRUE) |
| 201 | 8571x |
tmp <- matrix(seq_len(n * n), n, n, byrow = TRUE) |
| 202 | 3045x |
if (diagonal) tmp[ROW >= COL] else tmp[ROW > COL] |
| 203 |
} else {
|
|
| 204 |
# ldw version |
|
| 205 | ! |
if (diagonal) {
|
| 206 | ! |
unlist(lapply( |
| 207 | ! |
seq_len(n), |
| 208 | ! |
function(j) seq.int(j - 1, n - 1) * n + j |
| 209 |
)) |
|
| 210 |
} else {
|
|
| 211 | ! |
unlist(lapply( |
| 212 | ! |
seq_len(n - 1L), |
| 213 | ! |
function(j) seq.int(j, n - 1) * n + j |
| 214 |
)) |
|
| 215 |
} |
|
| 216 |
} |
|
| 217 |
} |
|
| 218 | ||
| 219 | ||
| 220 |
# vech.reverse and vechru.reverse (aka `upper2full') |
|
| 221 |
# |
|
| 222 |
# given the output of vech(S) --or vechru(S) which is identical-- |
|
| 223 |
# reconstruct S |
|
| 224 |
lav_matrix_vech_reverse <- lav_matrix_vechru_reverse <- |
|
| 225 |
lav_matrix_upper2full <- |
|
| 226 |
function(x, diagonal = TRUE) {
|
|
| 227 |
# if (lav_use_lavaanC()) {
|
|
| 228 |
# return(lavaanC::m_vech_reverse(x, diagonal)) |
|
| 229 |
# } |
|
| 230 |
# guess dimensions |
|
| 231 | 2622x |
if (diagonal) {
|
| 232 | 2622x |
p <- (sqrt(1 + 8 * length(x)) - 1) / 2 |
| 233 |
} else {
|
|
| 234 | ! |
p <- (sqrt(1 + 8 * length(x)) + 1) / 2 |
| 235 |
} |
|
| 236 | ||
| 237 | 2622x |
S <- numeric(p * p) |
| 238 | 2622x |
S[lav_matrix_vech_idx(p, diagonal = diagonal)] <- x |
| 239 | 2622x |
S[lav_matrix_vechru_idx(p, diagonal = diagonal)] <- x |
| 240 | ||
| 241 | 2622x |
attr(S, "dim") <- c(p, p) |
| 242 | 2622x |
S |
| 243 |
} |
|
| 244 | ||
| 245 | ||
| 246 |
# vechr.reverse vechu.reversie (aka `lower2full') |
|
| 247 |
# |
|
| 248 |
# given the output of vechr(S) --or vechu(S) which is identical-- |
|
| 249 |
# reconstruct S |
|
| 250 |
lav_matrix_vechr_reverse <- lav_matrix_vechu_reverse <- |
|
| 251 |
lav_matrix_lower2full <- function(x, diagonal = TRUE) {
|
|
| 252 |
# if (lav_use_lavaanC()) {
|
|
| 253 |
# return(lavaanC::m_vechr_reverse(x, diagonal)) |
|
| 254 |
# } |
|
| 255 |
# guess dimensions |
|
| 256 | 3x |
if (diagonal) {
|
| 257 | 3x |
p <- (sqrt(1 + 8 * length(x)) - 1) / 2 |
| 258 |
} else {
|
|
| 259 | ! |
p <- (sqrt(1 + 8 * length(x)) + 1) / 2 |
| 260 |
} |
|
| 261 | 3x |
stopifnot(p == round(p, 0)) |
| 262 | ||
| 263 | 3x |
S <- numeric(p * p) |
| 264 | 3x |
S[lav_matrix_vechr_idx(p, diagonal = diagonal)] <- x |
| 265 | 3x |
S[lav_matrix_vechu_idx(p, diagonal = diagonal)] <- x |
| 266 | ||
| 267 | 3x |
attr(S, "dim") <- c(p, p) |
| 268 | 3x |
S |
| 269 |
} |
|
| 270 | ||
| 271 | ||
| 272 |
# return the *vector* indices of the diagonal elements of a symmetric |
|
| 273 |
# matrix of size 'n' |
|
| 274 |
lav_matrix_diag_idx <- function(n = 1L) {
|
|
| 275 |
# if(n < 1L) return(integer(0L)) |
|
| 276 | 83811x |
n <- as.integer(n) |
| 277 | 83811x |
if (n < 1L) {
|
| 278 | ! |
return(integer(0L)) |
| 279 |
} |
|
| 280 |
# if (lav_use_lavaanC()) {
|
|
| 281 |
# return(lavaanC::m_diag_idx(n)) |
|
| 282 |
# } |
|
| 283 | 83811x |
1L + (seq_len(n) - 1L) * (n + 1L) |
| 284 |
} |
|
| 285 | ||
| 286 | ||
| 287 |
# return the *vector* indices of the diagonal elements of the LOWER part |
|
| 288 |
# of a symmatrix matrix of size 'n' |
|
| 289 |
lav_matrix_diagh_idx <- function(n = 1L) {
|
|
| 290 | 38x |
n <- as.integer(n) |
| 291 | 38x |
if (n < 1L) {
|
| 292 | ! |
return(integer(0L)) |
| 293 |
} |
|
| 294 | 38x |
if (n == 1L) {
|
| 295 | ! |
return(1L) |
| 296 |
} |
|
| 297 |
# if (lav_use_lavaanC()) {
|
|
| 298 |
# return(lavaanC::m_diagh_idx(n)) |
|
| 299 |
# } |
|
| 300 | 38x |
c(1L, cumsum(n:2L) + 1L) |
| 301 |
} |
|
| 302 | ||
| 303 | ||
| 304 |
# return the *vector* indices of the ANTI diagonal elements of a symmetric |
|
| 305 |
# matrix of size 'n' |
|
| 306 |
lav_matrix_antidiag_idx <- function(n = 1L) {
|
|
| 307 | ! |
if (n < 1L) {
|
| 308 | ! |
return(integer(0L)) |
| 309 |
} |
|
| 310 |
# if (lav_use_lavaanC()) {
|
|
| 311 |
# return(lavaanC::m_antidiag_idx(n)) |
|
| 312 |
# } |
|
| 313 | ! |
1L + seq_len(n) * (n - 1L) |
| 314 |
} |
|
| 315 | ||
| 316 |
# return the *vector* indices of 'idx' elements in a vech() matrix |
|
| 317 |
# |
|
| 318 |
# eg if n = 4 and type == "and" and idx = c(2,4) |
|
| 319 |
# we create matrix A = |
|
| 320 |
# [,1] [,2] [,3] [,4] |
|
| 321 |
# [1,] FALSE FALSE FALSE FALSE |
|
| 322 |
# [2,] FALSE TRUE FALSE TRUE |
|
| 323 |
# [3,] FALSE FALSE FALSE FALSE |
|
| 324 |
# [4,] FALSE TRUE FALSE TRUE |
|
| 325 |
# |
|
| 326 |
# and the result is c(5,7,10) |
|
| 327 |
# |
|
| 328 |
# eg if n = 4 and type == "or" and idx = c(2,4) |
|
| 329 |
# we create matrix A = |
|
| 330 |
# [,1] [,2] [,3] [,4] |
|
| 331 |
# [1,] FALSE TRUE FALSE TRUE |
|
| 332 |
# [2,] TRUE TRUE TRUE TRUE |
|
| 333 |
# [3,] FALSE TRUE FALSE TRUE |
|
| 334 |
# [4,] TRUE TRUE TRUE TRUE |
|
| 335 |
# |
|
| 336 |
# and the result is c(2, 4, 5, 6, 7, 9, 10) |
|
| 337 |
# |
|
| 338 |
lav_matrix_vech_which_idx <- function(n = 1L, diagonal = TRUE, |
|
| 339 |
idx = integer(0L), type = "and", |
|
| 340 |
add.idx.at.start = FALSE) {
|
|
| 341 | 108x |
if (length(idx) == 0L) {
|
| 342 | ! |
return(integer(0L)) |
| 343 |
} |
|
| 344 | 108x |
n <- as.integer(n) |
| 345 | 108x |
idx <- as.integer(idx) |
| 346 |
# if (lav_use_lavaanC()) {
|
|
| 347 |
# return(lavaanC::m_vech_which_idx(n, diagonal, idx, type, add.idx.at.start)) |
|
| 348 |
# } |
|
| 349 | 108x |
A <- matrix(FALSE, n, n) |
| 350 | 108x |
if (type == "and") {
|
| 351 | 108x |
A[idx, idx] <- TRUE |
| 352 | ! |
} else if (type == "or") {
|
| 353 | ! |
A[idx, ] <- TRUE |
| 354 | ! |
A[, idx] <- TRUE |
| 355 |
} |
|
| 356 | 108x |
pstar.idx <- which(lav_matrix_vech(A, diagonal = diagonal)) |
| 357 | ||
| 358 | 108x |
if (add.idx.at.start) {
|
| 359 | 78x |
pstar.idx <- c(idx, pstar.idx + n) |
| 360 |
} |
|
| 361 | ||
| 362 | 108x |
pstar.idx |
| 363 |
} |
|
| 364 | ||
| 365 |
# similar to lav_matrix_vech_which_idx(), but |
|
| 366 |
# - only 'type = and' |
|
| 367 |
# - order of idx matters! |
|
| 368 |
lav_matrix_vech_match_idx <- function(n = 1L, diagonal = TRUE, |
|
| 369 |
idx = integer(0L)) {
|
|
| 370 | ! |
if (length(idx) == 0L) {
|
| 371 | ! |
return(integer(0L)) |
| 372 |
} |
|
| 373 | ! |
n <- as.integer(n) |
| 374 | ! |
idx <- as.integer(idx) |
| 375 |
# if (lav_use_lavaanC()) {
|
|
| 376 |
# return(lavaanC::m_vech_match_idx(n, diagonal, idx)) |
|
| 377 |
# } |
|
| 378 | ! |
pstar <- n * (n + 1) / 2 |
| 379 | ! |
A <- lav_matrix_vech_reverse(seq_len(pstar)) |
| 380 | ! |
B <- A[idx, idx, drop = FALSE] |
| 381 | ! |
lav_matrix_vech(B, diagonal = diagonal) |
| 382 |
} |
|
| 383 | ||
| 384 |
# check if square matrix is diagonal (no tolerance!) |
|
| 385 |
lav_matrix_is_diagonal <- function(A = NULL) {
|
|
| 386 | ! |
A <- as.matrix.default(A) |
| 387 | ! |
stopifnot(nrow(A) == ncol(A)) |
| 388 |
# if (lav_use_lavaanC()) {
|
|
| 389 |
# return(lavaanC::m_is_diagonal(A)) |
|
| 390 |
# } |
|
| 391 | ! |
diag(A) <- 0 |
| 392 | ! |
all(A == 0) |
| 393 |
} |
|
| 394 | ||
| 395 | ||
| 396 |
# create the duplication matrix (D_n): it 'duplicates' the elements |
|
| 397 |
# in vech(S) to create vec(S) (where S is symmetric) |
|
| 398 |
# |
|
| 399 |
# D %*% vech(S) == vec(S) |
|
| 400 |
# |
|
| 401 |
# M&N book: pages 48-50 |
|
| 402 |
# |
|
| 403 | ||
| 404 |
# dup3: using col idx only |
|
| 405 |
# D7 <- dup(7L); x<- apply(D7, 1, function(x) which(x > 0)); matrix(x,7,7) |
|
| 406 |
lav_matrix_duplication <- function(n = 1L) {
|
|
| 407 | ! |
n <- as.integer(n) |
| 408 |
# if (lav_use_lavaanC()) {
|
|
| 409 |
# return(lavaanC::m_duplication(n)) |
|
| 410 |
# } |
|
| 411 | ! |
if ((n < 1L) || (round(n) != n)) {
|
| 412 | ! |
lav_msg_stop(gettext("n must be a positive integer"))
|
| 413 |
} |
|
| 414 | ||
| 415 | ! |
if (n > 255L) {
|
| 416 | ! |
lav_msg_stop(gettext("n is too large"))
|
| 417 |
} |
|
| 418 | ||
| 419 | ! |
nstar <- n * (n + 1) / 2 |
| 420 | ! |
n2 <- n * n |
| 421 |
# THIS is the real bottleneck: allocating an ocean of zeroes... |
|
| 422 | ! |
x <- numeric(n2 * nstar) |
| 423 | ||
| 424 | ! |
tmp <- matrix(0L, n, n) |
| 425 | ! |
tmp[lav_matrix_vech_idx(n)] <- 1:nstar |
| 426 | ! |
tmp[lav_matrix_vechru_idx(n)] <- 1:nstar |
| 427 | ||
| 428 | ! |
idx <- (1:n2) + (lav_matrix_vec(tmp) - 1L) * n2 |
| 429 | ||
| 430 | ! |
x[idx] <- 1.0 |
| 431 | ||
| 432 | ! |
attr(x, "dim") <- c(n2, nstar) |
| 433 | ! |
x |
| 434 |
} |
|
| 435 | ||
| 436 | ||
| 437 |
# dup4: using Matrix package, returning a sparse matrix |
|
| 438 |
# .dup4 <- function(n = 1L) {
|
|
| 439 |
# if ((n < 1L) || (round(n) != n)) {
|
|
| 440 |
# stop("n must be a positive integer")
|
|
| 441 |
# } |
|
| 442 |
# |
|
| 443 |
# if(n > 255L) {
|
|
| 444 |
# stop("n is too large")
|
|
| 445 |
# } |
|
| 446 |
# |
|
| 447 |
# nstar <- n * (n+1)/2 |
|
| 448 |
# #n2 <- n * n |
|
| 449 |
# |
|
| 450 |
# tmp <- matrix(0L, n, n) |
|
| 451 |
# tmp[lav_matrix_vech_idx(n)] <- 1:nstar |
|
| 452 |
# tmp[lav_matrix_vechru_idx(n)] <- 1:nstar |
|
| 453 |
# |
|
| 454 |
# x <- Matrix::sparseMatrix(i = 1:(n*n), j = vec(tmp), x = 1.0) |
|
| 455 |
# |
|
| 456 |
# x |
|
| 457 |
# } |
|
| 458 | ||
| 459 |
# duplication matrix for correlation matrices: |
|
| 460 |
# - it returns a matrix of size p^2 * (p*(p-1))/2 |
|
| 461 |
# - the columns corresponding to the diagonal elements have been removed |
|
| 462 |
lav_matrix_duplication_cor <- function(n = 1L) {
|
|
| 463 | ! |
n <- as.integer(n) |
| 464 |
# if (lav_use_lavaanC()) {
|
|
| 465 |
# return(lavaanC::m_duplication_cor(n)) |
|
| 466 |
# } |
|
| 467 | ! |
out <- lav_matrix_duplication(n = n) |
| 468 | ! |
diag.idx <- lav_matrix_diagh_idx(n = n) |
| 469 | ! |
out[, -diag.idx, drop = FALSE] |
| 470 |
} |
|
| 471 | ||
| 472 |
# compute t(D) %*% A (without explicitly computing D) |
|
| 473 |
# sqrt(nrow(A)) is an integer |
|
| 474 |
# A is not symmetric, and not even square, only n^2 ROWS |
|
| 475 |
lav_matrix_duplication_pre <- function(A = matrix(0, 0, 0)) {
|
|
| 476 |
# if (lav_use_lavaanC()) {
|
|
| 477 |
# return(lavaanC::m_duplication_pre(A)) |
|
| 478 |
# } |
|
| 479 |
# number of rows |
|
| 480 | 118x |
n2 <- NROW(A) |
| 481 | ||
| 482 |
# square nrow(A) only, n2 = n^2 |
|
| 483 | 118x |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 484 | ||
| 485 |
# dimension |
|
| 486 | 118x |
n <- sqrt(n2) |
| 487 | ||
| 488 |
# dup idx |
|
| 489 | 118x |
idx1 <- lav_matrix_vech_idx(n) |
| 490 | 118x |
idx2 <- lav_matrix_vechru_idx(n) |
| 491 | ||
| 492 | 118x |
OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE] |
| 493 | 118x |
u <- which(idx1 %in% idx2) |
| 494 | 118x |
OUT[u, ] <- OUT[u, ] / 2.0 |
| 495 | ||
| 496 | 118x |
OUT |
| 497 |
} |
|
| 498 | ||
| 499 |
# dupr_pre is faster... |
|
| 500 |
lav_matrix_duplication_dup_pre2 <- function(A = matrix(0, 0, 0)) {
|
|
| 501 |
# number of rows |
|
| 502 | ! |
n2 <- NROW(A) |
| 503 | ||
| 504 |
# square nrow(A) only, n2 = n^2 |
|
| 505 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 506 | ||
| 507 |
# dimension |
|
| 508 | ! |
n <- sqrt(n2) |
| 509 | ||
| 510 |
# dup idx |
|
| 511 | ! |
idx1 <- lav_matrix_vech_idx(n) |
| 512 | ! |
idx2 <- lav_matrix_vechru_idx(n) |
| 513 | ||
| 514 | ! |
OUT <- A[idx1, , drop = FALSE] |
| 515 | ! |
u <- which(!idx1 %in% idx2) |
| 516 | ! |
OUT[u, ] <- OUT[u, ] + A[idx2[u], ] |
| 517 | ||
| 518 | ! |
OUT |
| 519 |
} |
|
| 520 | ||
| 521 |
# compute t(D) %*% A (without explicitly computing D) |
|
| 522 |
# sqrt(nrow(A)) is an integer |
|
| 523 |
# A is not symmetric, and not even square, only n^2 ROWS |
|
| 524 |
# correlation version: ignoring diagonal elements |
|
| 525 |
lav_matrix_duplication_cor_pre <- function(A = matrix(0, 0, 0)) {
|
|
| 526 |
# if (lav_use_lavaanC()) {
|
|
| 527 |
# return(lavaanC::m_duplication_cor_pre(A)) |
|
| 528 |
# } |
|
| 529 |
# number of rows |
|
| 530 | ! |
n2 <- NROW(A) |
| 531 | ||
| 532 |
# square nrow(A) only, n2 = n^2 |
|
| 533 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 534 | ||
| 535 |
# dimension |
|
| 536 | ! |
n <- sqrt(n2) |
| 537 | ||
| 538 |
# dup idx |
|
| 539 | ! |
idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE) |
| 540 | ! |
idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE) |
| 541 | ||
| 542 | ! |
OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE] |
| 543 | ! |
u <- which(idx1 %in% idx2) |
| 544 | ! |
OUT[u, ] <- OUT[u, ] / 2.0 |
| 545 | ||
| 546 | ! |
OUT |
| 547 |
} |
|
| 548 | ||
| 549 |
# compute A %*% D (without explicitly computing D) |
|
| 550 |
# sqrt(ncol(A)) must be an integer |
|
| 551 |
# A is not symmetric, and not even square, only n^2 COLUMNS |
|
| 552 |
lav_matrix_duplication_post <- function(A = matrix(0, 0, 0)) {
|
|
| 553 |
# if (lav_use_lavaanC()) {
|
|
| 554 |
# return(lavaanC::m_duplication_post(A)) |
|
| 555 |
# } |
|
| 556 |
# number of columns |
|
| 557 | ! |
n2 <- NCOL(A) |
| 558 | ||
| 559 |
# square A only, n2 = n^2 |
|
| 560 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 561 | ||
| 562 |
# dimension |
|
| 563 | ! |
n <- sqrt(n2) |
| 564 | ||
| 565 |
# dup idx |
|
| 566 | ! |
idx1 <- lav_matrix_vech_idx(n) |
| 567 | ! |
idx2 <- lav_matrix_vechru_idx(n) |
| 568 | ||
| 569 | ! |
OUT <- A[, idx1, drop = FALSE] + A[, idx2, drop = FALSE] |
| 570 | ! |
u <- which(idx1 %in% idx2) |
| 571 | ! |
OUT[, u] <- OUT[, u] / 2.0 |
| 572 | ||
| 573 | ! |
OUT |
| 574 |
} |
|
| 575 | ||
| 576 |
# compute A %*% D (without explicitly computing D) |
|
| 577 |
# sqrt(ncol(A)) must be an integer |
|
| 578 |
# A is not symmetric, and not even square, only n^2 COLUMNS |
|
| 579 |
# correlation version: ignoring the diagonal elements |
|
| 580 |
lav_matrix_duplication_cor_post <- function(A = matrix(0, 0, 0)) {
|
|
| 581 |
# if (lav_use_lavaanC()) {
|
|
| 582 |
# return(lavaanC::m_duplication_cor_post(A)) |
|
| 583 |
# } |
|
| 584 |
# number of columns |
|
| 585 | ! |
n2 <- NCOL(A) |
| 586 | ||
| 587 |
# square A only, n2 = n^2 |
|
| 588 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 589 | ||
| 590 |
# dimension |
|
| 591 | ! |
n <- sqrt(n2) |
| 592 | ||
| 593 |
# dup idx |
|
| 594 | ! |
idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE) |
| 595 | ! |
idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE) |
| 596 | ||
| 597 | ! |
OUT <- A[, idx1, drop = FALSE] + A[, idx2, drop = FALSE] |
| 598 | ! |
u <- which(idx1 %in% idx2) |
| 599 | ! |
OUT[, u] <- OUT[, u] / 2.0 |
| 600 | ||
| 601 | ! |
OUT |
| 602 |
} |
|
| 603 | ||
| 604 | ||
| 605 |
# compute t(D) %*% A %*% D (without explicitly computing D) |
|
| 606 |
# A must be a square matrix and sqrt(ncol) an integer |
|
| 607 |
lav_matrix_duplication_pre_post <- function(A = matrix(0, 0, 0)) {
|
|
| 608 |
# if (lav_use_lavaanC()) {
|
|
| 609 |
# return(lavaanC::m_duplication_pre_post(A)) |
|
| 610 |
# } |
|
| 611 |
# number of columns |
|
| 612 | 230x |
n2 <- NCOL(A) |
| 613 | ||
| 614 |
# square A only, n2 = n^2 |
|
| 615 | 230x |
stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2))) |
| 616 | ||
| 617 |
# dimension |
|
| 618 | 230x |
n <- sqrt(n2) |
| 619 | ||
| 620 |
# dup idx |
|
| 621 | 230x |
idx1 <- lav_matrix_vech_idx(n) |
| 622 | 230x |
idx2 <- lav_matrix_vechru_idx(n) |
| 623 | ||
| 624 | 230x |
OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE] |
| 625 | 230x |
u <- which(idx1 %in% idx2) |
| 626 | 230x |
OUT[u, ] <- OUT[u, ] / 2.0 |
| 627 | 230x |
OUT <- OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE] |
| 628 | 230x |
OUT[, u] <- OUT[, u] / 2.0 |
| 629 | ||
| 630 | 230x |
OUT |
| 631 |
} |
|
| 632 | ||
| 633 |
# compute t(D) %*% A %*% D (without explicitly computing D) |
|
| 634 |
# A must be a square matrix and sqrt(ncol) an integer |
|
| 635 |
# correlation version: ignoring diagonal elements |
|
| 636 |
lav_matrix_duplication_cor_pre_post <- function(A = matrix(0, 0, 0)) {
|
|
| 637 |
# if (lav_use_lavaanC()) {
|
|
| 638 |
# return(lavaanC::m_duplication_cor_pre_post(A)) |
|
| 639 |
# } |
|
| 640 |
# number of columns |
|
| 641 | ! |
n2 <- NCOL(A) |
| 642 | ||
| 643 |
# square A only, n2 = n^2 |
|
| 644 | ! |
stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2))) |
| 645 | ||
| 646 |
# dimension |
|
| 647 | ! |
n <- sqrt(n2) |
| 648 | ||
| 649 |
# dup idx |
|
| 650 | ! |
idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE) |
| 651 | ! |
idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE) |
| 652 | ||
| 653 | ! |
OUT <- A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE] |
| 654 | ! |
u <- which(idx1 %in% idx2) |
| 655 | ! |
OUT[u, ] <- OUT[u, ] / 2.0 |
| 656 | ! |
OUT <- OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE] |
| 657 | ! |
OUT[, u] <- OUT[, u] / 2.0 |
| 658 | ||
| 659 | ! |
OUT |
| 660 |
} |
|
| 661 | ||
| 662 |
# create the elimination matrix L_n: |
|
| 663 |
# it removes the duplicated elements in vec(A) to create vech(A) |
|
| 664 |
# even if A is not symmetric |
|
| 665 |
# |
|
| 666 |
# L %*% vec(A) == vech(A) |
|
| 667 |
lav_matrix_elimination <- function(n = 1L) {
|
|
| 668 | ! |
if ((n < 1L) || (round(n) != n)) {
|
| 669 | ! |
lav_msg_stop(gettext("n must be a positive integer"))
|
| 670 |
} |
|
| 671 | ||
| 672 | ! |
if (n > 255L) {
|
| 673 | ! |
lav_msg_stop(gettext("n is too large"))
|
| 674 |
} |
|
| 675 | ||
| 676 | ! |
nstar <- n * (n + 1) / 2 |
| 677 | ! |
n2 <- n * n |
| 678 | ||
| 679 |
# THIS is the real bottleneck: allocating an ocean of zeroes... |
|
| 680 | ! |
L <- matrix(0, nrow = nstar, ncol = n2) |
| 681 | ! |
L[ cbind(seq_len(nstar), lav_matrix_vech_idx(n)) ] <- 1 |
| 682 | ||
| 683 | ! |
L |
| 684 |
} |
|
| 685 | ||
| 686 |
# compute L %*% A (without explicitly computing L) |
|
| 687 |
# sqrt(nrow(A)) is an integer |
|
| 688 |
# A is not symmetric, and not even square, only n^2 ROWS |
|
| 689 |
lav_matrix_elimination_pre <- function(A = matrix(0, 0, 0)) {
|
|
| 690 |
# number of rows |
|
| 691 | ! |
n2 <- NROW(A) |
| 692 | ||
| 693 |
# square nrow(A) only, n2 = n^2 |
|
| 694 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 695 | ||
| 696 |
# dimension |
|
| 697 | ! |
n <- sqrt(n2) |
| 698 | ||
| 699 |
# select vech idx rows |
|
| 700 | ! |
idx <- lav_matrix_vech_idx(n) |
| 701 | ! |
OUT <- A[idx, , drop = FALSE] |
| 702 | ||
| 703 | ! |
OUT |
| 704 |
} |
|
| 705 | ||
| 706 |
# compute A %*% t(L)(without explicitly computing L) |
|
| 707 |
# sqrt(nrow(A)) is an integer |
|
| 708 |
# A is not symmetric, and not even square, only n^2 COLS |
|
| 709 |
lav_matrix_elimination_post <- function(A = matrix(0, 0, 0)) {
|
|
| 710 |
# number of rows |
|
| 711 | ! |
n2 <- NCOL(A) |
| 712 | ||
| 713 |
# square nrow(A) only, n2 = n^2 |
|
| 714 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 715 | ||
| 716 |
# dimension |
|
| 717 | ! |
n <- sqrt(n2) |
| 718 | ||
| 719 |
# select vech idx rows |
|
| 720 | ! |
idx <- lav_matrix_vech_idx(n) |
| 721 | ! |
OUT <- A[, idx, drop = FALSE] |
| 722 | ||
| 723 | ! |
OUT |
| 724 |
} |
|
| 725 | ||
| 726 |
# compute L %*% A %*% t(L) (without explicitly computing L) |
|
| 727 |
# A must be a square matrix and sqrt(ncol) an integer |
|
| 728 |
lav_matrix_elimination_pre_post <- function(A = matrix(0, 0, 0)) {
|
|
| 729 |
# number of rows |
|
| 730 | ! |
n2 <- NCOL(A) |
| 731 | ||
| 732 |
# square A only, n2 = n^2 |
|
| 733 | ! |
stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2))) |
| 734 | ||
| 735 |
# dimension |
|
| 736 | ! |
n <- sqrt(n2) |
| 737 | ||
| 738 |
# select vech idx rows |
|
| 739 | ! |
idx <- lav_matrix_vech_idx(n) |
| 740 | ! |
OUT <- A[idx, idx, drop = FALSE] |
| 741 | ||
| 742 | ! |
OUT |
| 743 |
} |
|
| 744 | ||
| 745 | ||
| 746 | ||
| 747 | ||
| 748 | ||
| 749 |
# create the generalized inverse of the duplication matrix (D^+_n): |
|
| 750 |
# it removes the duplicated elements in vec(S) to create vech(S) |
|
| 751 |
# if S is symmetric |
|
| 752 |
# |
|
| 753 |
# D^+ %*% vec(S) == vech(S) |
|
| 754 |
# |
|
| 755 |
# M&N book: page 49 |
|
| 756 |
# |
|
| 757 |
# D^+ == solve(t(D_n %*% D_n) %*% t(D_n) |
|
| 758 | ||
| 759 |
# create DUP.ginv without transpose |
|
| 760 |
lav_matrix_duplication_ginv <- function(n = 1L) {
|
|
| 761 |
# if (lav_use_lavaanC()) {
|
|
| 762 |
# n <- as.integer(n) |
|
| 763 |
# return(lavaanC::m_duplication_ginv(n)) |
|
| 764 |
# } |
|
| 765 | ! |
if ((n < 1L) || (round(n) != n)) {
|
| 766 | ! |
lav_msg_stop(gettext("n must be a positive integer"))
|
| 767 |
} |
|
| 768 | ||
| 769 | ! |
if (n > 255L) {
|
| 770 | ! |
lav_msg_stop(gettext("n is too large"))
|
| 771 |
} |
|
| 772 | ||
| 773 | ! |
nstar <- n * (n + 1) / 2 |
| 774 | ! |
n2 <- n * n |
| 775 |
# THIS is the real bottleneck: allocating an ocean of zeroes... |
|
| 776 | ! |
x <- numeric(nstar * n2) |
| 777 | ||
| 778 | ! |
x[(lav_matrix_vech_idx(n) - 1L) * nstar + 1:nstar] <- 0.5 |
| 779 | ! |
x[(lav_matrix_vechru_idx(n) - 1L) * nstar + 1:nstar] <- 0.5 |
| 780 | ! |
x[(lav_matrix_diag_idx(n) - 1L) * nstar + lav_matrix_diagh_idx(n)] <- 1.0 |
| 781 | ||
| 782 | ! |
attr(x, "dim") <- c(nstar, n2) |
| 783 | ! |
x |
| 784 |
} |
|
| 785 | ||
| 786 |
# pre-multiply with D^+ |
|
| 787 |
# number of rows in A must be 'square' (n*n) |
|
| 788 |
lav_matrix_duplication_ginv_pre <- function(A = matrix(0, 0, 0)) {
|
|
| 789 | ! |
A <- as.matrix.default(A) |
| 790 | ||
| 791 |
# number of rows |
|
| 792 | ! |
n2 <- NROW(A) |
| 793 | ||
| 794 |
# square nrow(A) only, n2 = n^2 |
|
| 795 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 796 | ||
| 797 |
# dimension |
|
| 798 | ! |
n <- sqrt(n2) |
| 799 | ! |
nstar <- n * (n + 1) / 2 |
| 800 | ||
| 801 | ! |
idx1 <- lav_matrix_vech_idx(n) |
| 802 | ! |
idx2 <- lav_matrix_vechru_idx(n) |
| 803 | ! |
OUT <- (A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]) / 2 |
| 804 | ! |
OUT |
| 805 |
} |
|
| 806 | ||
| 807 |
# post-multiply with t(D^+) |
|
| 808 |
# number of columns in A must be 'square' (n*n) |
|
| 809 |
lav_matrix_duplication_ginv_post <- function(A = matrix(0, 0, 0)) {
|
|
| 810 | ! |
A <- as.matrix.default(A) |
| 811 | ||
| 812 |
# number of columns |
|
| 813 | ! |
n2 <- NCOL(A) |
| 814 | ||
| 815 |
# square A only, n2 = n^2 |
|
| 816 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 817 | ||
| 818 |
# dimension |
|
| 819 | ! |
n <- sqrt(n2) |
| 820 | ||
| 821 | ! |
idx1 <- lav_matrix_vech_idx(n) |
| 822 | ! |
idx2 <- lav_matrix_vechru_idx(n) |
| 823 | ! |
OUT <- (A[, idx1, drop = FALSE] + A[, idx2, drop = FALSE]) / 2 |
| 824 | ! |
OUT |
| 825 |
} |
|
| 826 | ||
| 827 |
# pre AND post-multiply with D^+: D^+ %*% A %*% t(D^+) |
|
| 828 |
# for square matrices only, with ncol = nrow = n^2 |
|
| 829 |
lav_matrix_duplication_ginv_pre_post <- function(A = matrix(0, 0, 0)) {
|
|
| 830 | ! |
A <- as.matrix.default(A) |
| 831 |
# if (lav_use_lavaanC()) {
|
|
| 832 |
# return(lavaanC::m_duplication_ginv_pre_post(A)) |
|
| 833 |
# } |
|
| 834 |
# number of columns |
|
| 835 | ! |
n2 <- NCOL(A) |
| 836 | ||
| 837 |
# square A only, n2 = n^2 |
|
| 838 | ! |
stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2))) |
| 839 | ||
| 840 |
# dimension |
|
| 841 | ! |
n <- sqrt(n2) |
| 842 | ||
| 843 | ! |
idx1 <- lav_matrix_vech_idx(n) |
| 844 | ! |
idx2 <- lav_matrix_vechru_idx(n) |
| 845 | ! |
OUT <- (A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]) / 2 |
| 846 | ! |
OUT <- (OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE]) / 2 |
| 847 | ! |
OUT |
| 848 |
} |
|
| 849 | ||
| 850 |
# pre AND post-multiply with D^+: D^+ %*% A %*% t(D^+) |
|
| 851 |
# for square matrices only, with ncol = nrow = n^2 |
|
| 852 |
# - ignoring diagonal elements |
|
| 853 |
lav_matrix_duplication_ginv_cor_pre_post <- function(A = matrix(0, 0, 0)) {
|
|
| 854 | ! |
A <- as.matrix.default(A) |
| 855 | ||
| 856 |
# number of columns |
|
| 857 | ! |
n2 <- NCOL(A) |
| 858 | ||
| 859 |
# square A only, n2 = n^2 |
|
| 860 | ! |
stopifnot(NROW(A) == n2, sqrt(n2) == round(sqrt(n2))) |
| 861 | ||
| 862 |
# dimension |
|
| 863 | ! |
n <- sqrt(n2) |
| 864 | ||
| 865 | ! |
idx1 <- lav_matrix_vech_idx(n, diagonal = FALSE) |
| 866 | ! |
idx2 <- lav_matrix_vechru_idx(n, diagonal = FALSE) |
| 867 | ! |
OUT <- (A[idx1, , drop = FALSE] + A[idx2, , drop = FALSE]) / 2 |
| 868 | ! |
OUT <- (OUT[, idx1, drop = FALSE] + OUT[, idx2, drop = FALSE]) / 2 |
| 869 | ! |
OUT |
| 870 |
} |
|
| 871 | ||
| 872 | ||
| 873 |
# create the commutation matrix (K_mn) |
|
| 874 |
# the mn x mx commutation matrix is a permutation matrix which |
|
| 875 |
# transforms vec(A) into vec(A') |
|
| 876 |
# |
|
| 877 |
# K_mn %*% vec(A) == vec(A') |
|
| 878 |
# |
|
| 879 |
# (in Henderson & Searle 1979, it is called the vec-permutation matrix) |
|
| 880 |
# M&N book: pages 46-48 |
|
| 881 |
# |
|
| 882 |
# note: K_mn is a permutation matrix, so it is orthogonal: t(K_mn) = K_mn^-1 |
|
| 883 |
# K_nm %*% K_mn == I_mn |
|
| 884 |
# |
|
| 885 |
# it is called the 'commutation' matrix because it enables us to interchange |
|
| 886 |
# ('commute') the two matrices of a Kronecker product, eg
|
|
| 887 |
# K_pm (A %x% B) K_nq == (B %x% A) |
|
| 888 |
# |
|
| 889 |
# important property: it allows us to transform a vec of a Kronecker product |
|
| 890 |
# into the Kronecker product of the vecs (if A is m x n and B is p x q): |
|
| 891 |
# vec(A %x% B) == (I_n %x% K_qm %x% I_p)(vec A %x% vec B) |
|
| 892 | ||
| 893 |
# first attempt |
|
| 894 |
lav_matrix_commutation <- function(m = 1L, n = 1L) {
|
|
| 895 |
# if (lav_use_lavaanC()) {
|
|
| 896 |
# m <- as.integer(m) |
|
| 897 |
# n <- as.integer(n) |
|
| 898 |
# return(lavaanC::m_commutation(m, n)) |
|
| 899 |
# } |
|
| 900 | ||
| 901 | ! |
if ((m < 1L) || (round(m) != m)) {
|
| 902 | ! |
lav_msg_stop(gettext("n must be a positive integer"))
|
| 903 |
} |
|
| 904 | ||
| 905 | ! |
if ((n < 1L) || (round(n) != n)) {
|
| 906 | ! |
lav_msg_stop(gettext("n must be a positive integer"))
|
| 907 |
} |
|
| 908 | ||
| 909 | ! |
p <- m * n |
| 910 | ! |
x <- numeric(p * p) |
| 911 | ||
| 912 | ! |
pattern <- rep(c(rep((m + 1L) * n, (m - 1L)), n + 1L), n) |
| 913 | ! |
idx <- c(1L, 1L + cumsum(pattern)[-p]) |
| 914 | ||
| 915 | ! |
x[idx] <- 1.0 |
| 916 | ! |
attr(x, "dim") <- c(p, p) |
| 917 | ||
| 918 | ! |
x |
| 919 |
} |
|
| 920 | ||
| 921 |
# compute K_n %*% A without explicitly computing K |
|
| 922 |
# K_n = K_nn, so sqrt(nrow(A)) must be an integer! |
|
| 923 |
# = permuting the rows of A |
|
| 924 |
lav_matrix_commutation_pre <- function(A = matrix(0, 0, 0)) {
|
|
| 925 | ! |
A <- as.matrix(A) |
| 926 | ||
| 927 |
# if (lav_use_lavaanC()) {
|
|
| 928 |
# return(lavaanC::m_commutation_pre(A)) |
|
| 929 |
# } |
|
| 930 | ||
| 931 |
# number of rows of A |
|
| 932 | ! |
n2 <- nrow(A) |
| 933 | ||
| 934 |
# K_nn only (n2 = m * n) |
|
| 935 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 936 | ||
| 937 |
# dimension |
|
| 938 | ! |
n <- sqrt(n2) |
| 939 | ||
| 940 |
# compute row indices |
|
| 941 |
# row.idx <- as.integer(t(matrix(1:n2, n, n))) |
|
| 942 | ! |
row.idx <- rep(1:n, each = n) + (0:(n - 1L)) * n |
| 943 | ||
| 944 | ! |
OUT <- A[row.idx, , drop = FALSE] |
| 945 | ! |
OUT |
| 946 |
} |
|
| 947 | ||
| 948 |
# compute A %*% K_n without explicitly computing K |
|
| 949 |
# K_n = K_nn, so sqrt(ncol(A)) must be an integer! |
|
| 950 |
# = permuting the columns of A |
|
| 951 |
lav_matrix_commutation_post <- function(A = matrix(0, 0, 0)) {
|
|
| 952 | ! |
A <- as.matrix(A) |
| 953 | ||
| 954 |
# if (lav_use_lavaanC()) {
|
|
| 955 |
# return(lavaanC::m_commutation_post(A)) |
|
| 956 |
# } |
|
| 957 | ||
| 958 |
# number of columns of A |
|
| 959 | ! |
n2 <- ncol(A) |
| 960 | ||
| 961 |
# K_nn only (n2 = m * n) |
|
| 962 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 963 | ||
| 964 |
# dimension |
|
| 965 | ! |
n <- sqrt(n2) |
| 966 | ||
| 967 |
# compute col indices |
|
| 968 |
# row.idx <- as.integer(t(matrix(1:n2, n, n))) |
|
| 969 | ! |
col.idx <- rep(1:n, each = n) + (0:(n - 1L)) * n |
| 970 | ||
| 971 | ! |
OUT <- A[, col.idx, drop = FALSE] |
| 972 | ! |
OUT |
| 973 |
} |
|
| 974 | ||
| 975 |
# compute K_n %*% A %*% K_n without explicitly computing K |
|
| 976 |
# K_n = K_nn, so sqrt(ncol(A)) must be an integer! |
|
| 977 |
# = permuting both the rows AND columns of A |
|
| 978 |
lav_matrix_commutation_pre_post <- function(A = matrix(0, 0, 0)) {
|
|
| 979 | ! |
A <- as.matrix(A) |
| 980 |
# if (lav_use_lavaanC()) {
|
|
| 981 |
# return(lavaanC::m_commutation_pre_post(A)) |
|
| 982 |
# } |
|
| 983 |
# number of columns of A |
|
| 984 | ! |
n2 <- NCOL(A) |
| 985 | ||
| 986 |
# K_nn only (n2 = m * n) |
|
| 987 | ! |
stopifnot(sqrt(n2) == round(sqrt(n2))) |
| 988 | ||
| 989 |
# dimension |
|
| 990 | ! |
n <- sqrt(n2) |
| 991 | ||
| 992 |
# compute col indices |
|
| 993 | ! |
row.idx <- rep(1:n, each = n) + (0:(n - 1L)) * n |
| 994 | ! |
col.idx <- row.idx |
| 995 | ||
| 996 | ! |
OUT <- A[row.idx, col.idx, drop = FALSE] |
| 997 | ! |
OUT |
| 998 |
} |
|
| 999 | ||
| 1000 | ||
| 1001 | ||
| 1002 |
# compute K_mn %*% A without explicitly computing K |
|
| 1003 |
# = permuting the rows of A |
|
| 1004 |
lav_matrix_commutation_mn_pre <- function(A, m = 1L, n = 1L) {
|
|
| 1005 |
# number of rows of A |
|
| 1006 | ! |
mn <- NROW(A) |
| 1007 | ! |
stopifnot(mn == m * n) |
| 1008 | ||
| 1009 |
# compute row indices |
|
| 1010 |
# row.idx <- as.integer(t(matrix(1:mn, m, n))) |
|
| 1011 | ! |
row.idx <- rep(1:m, each = n) + (0:(n - 1L)) * m |
| 1012 | ||
| 1013 | ! |
OUT <- A[row.idx, , drop = FALSE] |
| 1014 | ! |
OUT |
| 1015 |
} |
|
| 1016 | ||
| 1017 |
# N_n == 1/2 (I_n^2 + K_nn) |
|
| 1018 |
# see MN page 48 |
|
| 1019 |
# |
|
| 1020 |
# N_n == D_n %*% D^+_n |
|
| 1021 |
# |
|
| 1022 |
lav_matrix_commutation_Nn <- function(n = 1L) {
|
|
| 1023 | ! |
lav_msg_stop(gettext("not implemented yet"))
|
| 1024 |
} |
|
| 1025 | ||
| 1026 |
# (simplified) kronecker product for square matrices |
|
| 1027 |
lav_matrix_kronecker_square <- function(A, check = TRUE) {
|
|
| 1028 | ! |
dimA <- dim(A) |
| 1029 | ! |
n <- dimA[1L] |
| 1030 | ! |
n2 <- n * n |
| 1031 | ! |
if (check) {
|
| 1032 | ! |
stopifnot(dimA[2L] == n) |
| 1033 |
} |
|
| 1034 | ||
| 1035 |
# all possible combinations |
|
| 1036 | ! |
out <- tcrossprod(as.vector(A)) |
| 1037 | ||
| 1038 |
# break up in n*n pieces, and rearrange |
|
| 1039 | ! |
dim(out) <- c(n, n, n, n) |
| 1040 | ! |
out <- aperm(out, perm = c(3, 1, 4, 2)) |
| 1041 | ||
| 1042 |
# reshape again, to form n2 x n2 matrix |
|
| 1043 | ! |
dim(out) <- c(n2, n2) |
| 1044 | ||
| 1045 | ! |
out |
| 1046 |
} |
|
| 1047 | ||
| 1048 |
# (simplified) faster kronecker product for symmetric matrices |
|
| 1049 |
# note: not faster, but the logic extends to vech versions |
|
| 1050 |
lav_matrix_kronecker_symmetric <- function(S, check = TRUE) {
|
|
| 1051 | ! |
dimS <- dim(S) |
| 1052 | ! |
n <- dimS[1L] |
| 1053 | ! |
n2 <- n * n |
| 1054 | ! |
if (check) {
|
| 1055 | ! |
stopifnot(dimS[2L] == n) |
| 1056 |
} |
|
| 1057 | ||
| 1058 |
# all possible combinations |
|
| 1059 | ! |
out <- tcrossprod(as.vector(S)) |
| 1060 | ||
| 1061 |
# break up in n*(n*n) pieces, and rearrange |
|
| 1062 | ! |
dim(out) <- c(n, n * n, n) |
| 1063 | ! |
out <- aperm(out, perm = c(3L, 2L, 1L)) |
| 1064 | ||
| 1065 |
# reshape again, to form n2 x n2 matrix |
|
| 1066 | ! |
dim(out) <- c(n2, n2) |
| 1067 | ||
| 1068 | ! |
out |
| 1069 |
} |
|
| 1070 | ||
| 1071 |
# shortcut for the idiom 't(S2) %*% (S %x% S) %*% S2' |
|
| 1072 |
# where S is symmetric, and the rows of S2 correspond to |
|
| 1073 |
# the elements of S |
|
| 1074 |
# eg - S2 = DELTA (the jacobian dS/dtheta) |
|
| 1075 |
lav_matrix_tS2_SxS_S2 <- function(S2, S, check = TRUE) {
|
|
| 1076 |
# size of S |
|
| 1077 | ! |
n <- NROW(S) |
| 1078 | ||
| 1079 | ! |
if (check) {
|
| 1080 | ! |
stopifnot(NROW(S2) == n * n) |
| 1081 |
} |
|
| 1082 | ||
| 1083 | ! |
A <- matrix(S %*% matrix(S2, n, ), n * n, ) |
| 1084 | ! |
A2 <- A[rep(1:n, each = n) + (0:(n - 1L)) * n, , drop = FALSE] |
| 1085 | ! |
crossprod(A, A2) |
| 1086 |
} |
|
| 1087 | ||
| 1088 |
# shortcut for the idiom 't(D) %*% (S %x% S) %*% D' |
|
| 1089 |
# where S is symmetric, and D is the duplication matrix |
|
| 1090 |
# lav_matrix_tD_SxS_D <- function(S) {
|
|
| 1091 | ||
| 1092 |
# TODO!! |
|
| 1093 | ||
| 1094 |
# } |
|
| 1095 | ||
| 1096 |
# square root of a positive definite symmetric matrix |
|
| 1097 |
lav_matrix_symmetric_sqrt <- function(S = matrix(0, 0, 0)) {
|
|
| 1098 | ! |
n <- NROW(S) |
| 1099 | ||
| 1100 |
# eigen decomposition, assume symmetric matrix |
|
| 1101 | ! |
S.eigen <- eigen(S, symmetric = TRUE) |
| 1102 | ! |
V <- S.eigen$vectors |
| 1103 | ! |
d <- S.eigen$values |
| 1104 | ||
| 1105 |
# 'fix' slightly negative tiny numbers |
|
| 1106 | ! |
d[d < 0] <- 0.0 |
| 1107 | ||
| 1108 |
# sqrt the eigenvalues and reconstruct |
|
| 1109 | ! |
S.sqrt <- V %*% diag(sqrt(d), n, n) %*% t(V) |
| 1110 | ||
| 1111 | ! |
S.sqrt |
| 1112 |
} |
|
| 1113 | ||
| 1114 |
# orthogonal complement of a matrix A |
|
| 1115 |
# see Satorra (1992). Sociological Methodology, 22, 249-278, footnote 3: |
|
| 1116 |
# |
|
| 1117 |
# To compute such an orthogonal matrix, consider the p* x p* matrix P = I - |
|
| 1118 |
# A(A'A)^-1A', which is idempotent of rank p* - q. Consider the singular value |
|
| 1119 |
# decomposition P = HVH', where H is a p* x (p* - q) matrix of full column rank, |
|
| 1120 |
# and V is a (p* - q) x (p* - q) diagonal matrix. It is obvious that H'A = 0; |
|
| 1121 |
# hence, H is the desired orthogonal complement. This method of constructing an |
|
| 1122 |
# orthogonal complement was proposed by Heinz Neudecker (1990, pers. comm.). |
|
| 1123 |
# |
|
| 1124 |
# update YR 21 okt 2014: |
|
| 1125 |
# - note that A %*% solve(t(A) %*% A) %*% t(A) == tcrossprod(qr.Q(qr(A))) |
|
| 1126 |
# - if we are using qr, we can as well use qr.Q to get the complement |
|
| 1127 |
# |
|
| 1128 |
lav_matrix_orthogonal_complement <- function(A = matrix(0, 0, 0)) {
|
|
| 1129 | ! |
QR <- qr(A) |
| 1130 | ! |
ranK <- QR$rank |
| 1131 | ||
| 1132 |
# following Heinz Neudecker: |
|
| 1133 |
# n <- nrow(A) |
|
| 1134 |
# P <- diag(n) - tcrossprod(qr.Q(QR)) |
|
| 1135 |
# OUT <- svd(P)$u[, seq_len(n - ranK), drop = FALSE] |
|
| 1136 | ||
| 1137 | ! |
Q <- qr.Q(QR, complete = TRUE) |
| 1138 |
# get rid of the first ranK columns |
|
| 1139 | ! |
OUT <- Q[, -seq_len(ranK), drop = FALSE] |
| 1140 | ||
| 1141 | ! |
OUT |
| 1142 |
} |
|
| 1143 | ||
| 1144 |
# construct block diagonal matrix from a list of matrices |
|
| 1145 |
# ... can contain multiple arguments, which will be coerced to a list |
|
| 1146 |
# or it can be a single list (of matrices) |
|
| 1147 |
lav_matrix_bdiag <- function(...) {
|
|
| 1148 | 122x |
if (nargs() == 0L) {
|
| 1149 | ! |
return(matrix(0, 0, 0)) |
| 1150 |
} |
|
| 1151 | 122x |
dots <- list(...) |
| 1152 | ||
| 1153 |
# create list of matrices |
|
| 1154 | 122x |
if (is.list(dots[[1]])) {
|
| 1155 | 64x |
mlist <- dots[[1]] |
| 1156 |
} else {
|
|
| 1157 | 58x |
mlist <- dots |
| 1158 |
} |
|
| 1159 | 122x |
if (length(mlist) == 1L) {
|
| 1160 | 64x |
return(mlist[[1]]) |
| 1161 |
} |
|
| 1162 | ||
| 1163 |
# more than 1 matrix |
|
| 1164 | 58x |
nmat <- length(mlist) |
| 1165 | 58x |
nrows <- sapply(mlist, NROW) |
| 1166 | 58x |
crows <- cumsum(nrows) |
| 1167 | 58x |
ncols <- sapply(mlist, NCOL) |
| 1168 | 58x |
ccols <- cumsum(ncols) |
| 1169 | 58x |
trows <- sum(nrows) |
| 1170 | 58x |
tcols <- sum(ncols) |
| 1171 |
# empty names will shorten the c/r-names vector |
|
| 1172 | 58x |
cnames <- unlist(lapply(mlist, colnames)) |
| 1173 | 58x |
rnames <- unlist(lapply(mlist, rownames)) |
| 1174 | ||
| 1175 | 58x |
x <- numeric(trows * tcols) |
| 1176 | ||
| 1177 | 58x |
for (m in seq_len(nmat)) {
|
| 1178 | 116x |
if (m > 1L) {
|
| 1179 | 58x |
rcoffset <- trows * ccols[m - 1] + crows[m - 1] |
| 1180 |
} else {
|
|
| 1181 | 58x |
rcoffset <- 0L |
| 1182 |
} |
|
| 1183 | 116x |
m.idx <- (rep((0:(ncols[m] - 1L)) * trows, each = nrows[m]) + |
| 1184 | 116x |
rep(1:nrows[m], ncols[m]) + rcoffset) |
| 1185 | 116x |
x[m.idx] <- mlist[[m]] |
| 1186 |
} |
|
| 1187 | ||
| 1188 | 58x |
attr(x, "dim") <- c(trows, tcols) |
| 1189 |
# col/row names (only if complete) |
|
| 1190 | 58x |
if (nrow(x) == length(rnames) && ncol(x) == length(cnames)) {
|
| 1191 | ! |
attr(x, "dimnames") <- list(rnames, cnames) |
| 1192 |
} |
|
| 1193 | ||
| 1194 | 58x |
x |
| 1195 |
} |
|
| 1196 | ||
| 1197 |
# trace of a single square matrix, or the trace of a product of (compatible) |
|
| 1198 |
# matrices resulting in a single square matrix |
|
| 1199 |
lav_matrix_trace <- function(..., check = TRUE) {
|
|
| 1200 | ! |
if (nargs() == 0L) {
|
| 1201 | ! |
return(as.numeric(NA)) |
| 1202 |
} |
|
| 1203 | ! |
dots <- list(...) |
| 1204 | ||
| 1205 |
# create list of matrices |
|
| 1206 | ! |
if (is.list(dots[[1]])) {
|
| 1207 | ! |
mlist <- dots[[1]] |
| 1208 |
} else {
|
|
| 1209 | ! |
mlist <- dots |
| 1210 |
} |
|
| 1211 | ||
| 1212 |
# number of matrices |
|
| 1213 | ! |
nMat <- length(mlist) |
| 1214 | ||
| 1215 |
# single matrix |
|
| 1216 | ! |
if (nMat == 1L) {
|
| 1217 | ! |
S <- mlist[[1]] |
| 1218 | ! |
if (check) {
|
| 1219 |
# check if square |
|
| 1220 | ! |
stopifnot(NROW(S) == NCOL(S)) |
| 1221 |
} |
|
| 1222 | ! |
out <- sum(S[lav_matrix_diag_idx(n = NROW(S))]) |
| 1223 | ! |
} else if (nMat == 2L) {
|
| 1224 |
# dimension check is done by '*' |
|
| 1225 | ! |
out <- sum(mlist[[1]] * t(mlist[[2]])) |
| 1226 | ! |
} else if (nMat == 3L) {
|
| 1227 | ! |
A <- mlist[[1]] |
| 1228 | ! |
B <- mlist[[2]] |
| 1229 | ! |
C <- mlist[[3]] |
| 1230 | ||
| 1231 |
# A, B, C |
|
| 1232 |
# below is the logic; to be coded inline |
|
| 1233 |
# DIAG <- numeric( NROW(A) ) |
|
| 1234 |
# for(i in seq_len(NROW(A))) {
|
|
| 1235 |
# DIAG[i] <- sum( rep(A[i,], times = NCOL(B)) * |
|
| 1236 |
# as.vector(B) * |
|
| 1237 |
# rep(C[,i], each=NROW(B)) ) |
|
| 1238 |
# } |
|
| 1239 |
# out <- sum(DIAG) |
|
| 1240 | ||
| 1241 |
# FIXME: |
|
| 1242 | ||
| 1243 |
# dimension check is automatic |
|
| 1244 | ! |
B2 <- B %*% C |
| 1245 | ! |
out <- sum(A * t(B2)) |
| 1246 |
} else {
|
|
| 1247 |
# nRows <- sapply(mlist, NROW) |
|
| 1248 |
# nCols <- sapply(mlist, NCOL) |
|
| 1249 | ||
| 1250 |
# check if product is ok |
|
| 1251 |
# stopifnot(all(nCols[seq_len(nMat-1L)] == nRows[2:nMat])) |
|
| 1252 | ||
| 1253 |
# check if product is square |
|
| 1254 |
# stopifnot(nRows[1] == nCols[nMat]) |
|
| 1255 | ||
| 1256 | ! |
M1 <- mlist[[1]] |
| 1257 | ! |
M2 <- mlist[[2]] |
| 1258 | ! |
for (m in 3L:nMat) {
|
| 1259 | ! |
M2 <- M2 %*% mlist[[m]] |
| 1260 |
} |
|
| 1261 | ! |
out <- sum(M1 * t(M2)) |
| 1262 |
} |
|
| 1263 | ||
| 1264 | ! |
out |
| 1265 |
} |
|
| 1266 | ||
| 1267 |
# crossproduct, but handling NAs pairwise, if needed |
|
| 1268 |
# otherwise, just call base::crossprod |
|
| 1269 |
lav_matrix_crossprod <- function(A, B) {
|
|
| 1270 |
# single argument? |
|
| 1271 | 1288x |
if (missing(B)) {
|
| 1272 | 28x |
if (!anyNA(A)) {
|
| 1273 | 26x |
return(base::crossprod(A)) |
| 1274 |
} |
|
| 1275 | 2x |
B <- A |
| 1276 |
# no missings? |
|
| 1277 | 1260x |
} else if (!anyNA(A) && !anyNA(B)) {
|
| 1278 | 72x |
return(base::crossprod(A, B)) |
| 1279 |
} |
|
| 1280 | ||
| 1281 |
# A and B must be matrices |
|
| 1282 | 1190x |
if (!inherits(A, "matrix")) {
|
| 1283 | 964x |
A <- matrix(A) |
| 1284 |
} |
|
| 1285 | 1190x |
if (!inherits(B, "matrix")) {
|
| 1286 | 564x |
B <- matrix(B) |
| 1287 |
} |
|
| 1288 | ||
| 1289 | 1190x |
out <- apply(B, 2L, function(x) colSums(A * x, na.rm = TRUE)) |
| 1290 | ||
| 1291 |
# only when A is a vector, and B is a matrix, we get back a vector |
|
| 1292 |
# while the result should be a matrix with 1-row |
|
| 1293 | 1190x |
if (!is.matrix(out)) {
|
| 1294 | 1144x |
out <- t(matrix(out)) |
| 1295 |
} |
|
| 1296 | ||
| 1297 | 1190x |
out |
| 1298 |
} |
|
| 1299 | ||
| 1300 | ||
| 1301 |
# reduced row echelon form of A |
|
| 1302 |
lav_matrix_rref <- function(A, tol = sqrt(.Machine$double.eps)) {
|
|
| 1303 |
# MATLAB documentation says rref uses: tol = (max(size(A))*eps *norm(A,inf) |
|
| 1304 | ! |
if (missing(tol)) {
|
| 1305 | ! |
A.norm <- max(abs(apply(A, 1, sum))) |
| 1306 | ! |
tol <- max(dim(A)) * A.norm * .Machine$double.eps |
| 1307 |
} |
|
| 1308 | ||
| 1309 |
# check if A is a matrix |
|
| 1310 | ! |
stopifnot(is.matrix(A)) |
| 1311 | ||
| 1312 |
# dimensions |
|
| 1313 | ! |
nRow <- NROW(A) |
| 1314 | ! |
nCol <- NCOL(A) |
| 1315 | ! |
pivot <- integer(0L) |
| 1316 | ||
| 1317 |
# catch empty matrix |
|
| 1318 | ! |
if (nRow == 0 && nCol == 0) {
|
| 1319 | ! |
return(matrix(0, 0, 0)) |
| 1320 |
} |
|
| 1321 | ||
| 1322 | ! |
rowIndex <- colIndex <- 1 |
| 1323 | ! |
while (rowIndex <= nRow && |
| 1324 | ! |
colIndex <= nCol) {
|
| 1325 |
# look for largest (in absolute value) element in this column: |
|
| 1326 | ! |
i.below <- which.max(abs(A[rowIndex:nRow, colIndex])) |
| 1327 | ! |
i <- i.below + rowIndex - 1L |
| 1328 | ! |
p <- A[i, colIndex] |
| 1329 | ||
| 1330 |
# check if column is empty |
|
| 1331 | ! |
if (abs(p) <= tol) {
|
| 1332 | ! |
A[rowIndex:nRow, colIndex] <- 0L # clean up |
| 1333 | ! |
colIndex <- colIndex + 1 |
| 1334 |
} else {
|
|
| 1335 |
# store pivot column |
|
| 1336 | ! |
pivot <- c(pivot, colIndex) |
| 1337 | ||
| 1338 |
# do we need to swap column? |
|
| 1339 | ! |
if (rowIndex != i) {
|
| 1340 | ! |
A[c(rowIndex, i), colIndex:nCol] <- |
| 1341 | ! |
A[c(i, rowIndex), colIndex:nCol] |
| 1342 |
} |
|
| 1343 | ||
| 1344 |
# scale pivot to be 1.0 |
|
| 1345 | ! |
A[rowIndex, colIndex:nCol] <- A[rowIndex, colIndex:nCol] / p |
| 1346 | ||
| 1347 |
# create zeroes below and above pivot |
|
| 1348 | ! |
other <- seq_len(nRow)[-rowIndex] |
| 1349 | ! |
A[other, colIndex:nCol] <- |
| 1350 | ! |
A[other, colIndex:nCol] - tcrossprod( |
| 1351 | ! |
A[other, colIndex], |
| 1352 | ! |
A[rowIndex, colIndex:nCol] |
| 1353 |
) |
|
| 1354 |
# next row/col |
|
| 1355 | ! |
rowIndex <- rowIndex + 1 |
| 1356 | ! |
colIndex <- colIndex + 1 |
| 1357 |
} |
|
| 1358 |
} |
|
| 1359 | ||
| 1360 |
# rounding? |
|
| 1361 | ||
| 1362 | ! |
list(R = A, pivot = pivot) |
| 1363 |
} |
|
| 1364 | ||
| 1365 |
# non-orthonoramal (left) null space basis, using rref |
|
| 1366 |
lav_matrix_orthogonal_complement2 <- function( |
|
| 1367 |
A, |
|
| 1368 |
tol = sqrt(.Machine$double.eps)) {
|
|
| 1369 |
# left |
|
| 1370 | ! |
A <- t(A) |
| 1371 | ||
| 1372 |
# compute rref |
|
| 1373 | ! |
out <- lav_matrix_rref(A = A, tol = tol) |
| 1374 | ||
| 1375 |
# number of free columns in R (if any) |
|
| 1376 | ! |
nfree <- NCOL(A) - length(out$pivot) |
| 1377 | ||
| 1378 | ! |
if (nfree) {
|
| 1379 | ! |
R <- out$R |
| 1380 | ||
| 1381 |
# remove all-zero rows |
|
| 1382 | ! |
zero.idx <- which(apply(R, 1, function(x) {
|
| 1383 | ! |
all(abs(x) < tol) |
| 1384 |
})) |
|
| 1385 | ! |
if (length(zero.idx) > 0) {
|
| 1386 | ! |
R <- R[-zero.idx, , drop = FALSE] |
| 1387 |
} |
|
| 1388 | ||
| 1389 | ! |
FREE <- R[, -out$pivot, drop = FALSE] |
| 1390 | ! |
I <- diag(nfree) |
| 1391 | ! |
N <- rbind(-FREE, I) |
| 1392 |
} else {
|
|
| 1393 | ! |
N <- matrix(0, nrow = NCOL(A), ncol = 0L) |
| 1394 |
} |
|
| 1395 | ||
| 1396 | ! |
N |
| 1397 |
} |
|
| 1398 | ||
| 1399 | ||
| 1400 |
# inverse of a non-singular (not necessarily positive-definite) symmetric matrix |
|
| 1401 |
# FIXME: error handling? |
|
| 1402 |
lav_matrix_symmetric_inverse <- function(S, logdet = FALSE, |
|
| 1403 |
Sinv.method = "eigen", |
|
| 1404 |
zero.warn = FALSE) {
|
|
| 1405 |
# catch zero cols/rows |
|
| 1406 | 7023x |
zero.idx <- which(colSums(S) == 0 & diag(S) == 0 & rowSums(S) == 0) |
| 1407 | 7023x |
S.orig <- S |
| 1408 | 7023x |
if (length(zero.idx) > 0L) {
|
| 1409 | 12x |
if (zero.warn) {
|
| 1410 | ! |
lav_msg_warn(gettext("matrix to be inverted contains zero cols/rows"))
|
| 1411 |
} |
|
| 1412 | 12x |
S <- S[-zero.idx, -zero.idx, drop = FALSE] |
| 1413 |
} |
|
| 1414 | ||
| 1415 | 7023x |
P <- NCOL(S) |
| 1416 | ||
| 1417 | 7023x |
if (P == 0L) {
|
| 1418 | ! |
S.inv <- matrix(0, 0, 0) |
| 1419 | ! |
if (logdet) {
|
| 1420 | ! |
attr(S.inv, "logdet") <- 0 |
| 1421 |
} |
|
| 1422 | ! |
return(S.inv) |
| 1423 | 7023x |
} else if (P == 1L) {
|
| 1424 | ! |
tmp <- S[1, 1] |
| 1425 | ! |
S.inv <- matrix(1 / tmp, 1, 1) |
| 1426 | ! |
if (logdet) {
|
| 1427 | ! |
if (tmp > 0) {
|
| 1428 | ! |
attr(S.inv, "logdet") <- log(tmp) |
| 1429 |
} else {
|
|
| 1430 | ! |
attr(S.inv, "logdet") <- -Inf |
| 1431 |
} |
|
| 1432 |
} |
|
| 1433 | 7023x |
} else if (P == 2L) {
|
| 1434 | 708x |
a11 <- S[1, 1] |
| 1435 | 708x |
a12 <- S[1, 2] |
| 1436 | 708x |
a21 <- S[2, 1] |
| 1437 | 708x |
a22 <- S[2, 2] |
| 1438 | 708x |
tmp <- a11 * a22 - a12 * a21 |
| 1439 | 708x |
if (tmp == 0) {
|
| 1440 | ! |
S.inv <- matrix(c(Inf, Inf, Inf, Inf), 2, 2) |
| 1441 | ! |
if (logdet) {
|
| 1442 | ! |
attr(S.inv, "logdet") <- -Inf |
| 1443 |
} |
|
| 1444 |
} else {
|
|
| 1445 | 708x |
S.inv <- matrix(c(a22 / tmp, -a21 / tmp, -a12 / tmp, a11 / tmp), 2, 2) |
| 1446 | 708x |
if (logdet) {
|
| 1447 | 708x |
if (tmp > 0) {
|
| 1448 | 708x |
attr(S.inv, "logdet") <- log(tmp) |
| 1449 |
} else {
|
|
| 1450 | ! |
attr(S.inv, "logdet") <- -Inf |
| 1451 |
} |
|
| 1452 |
} |
|
| 1453 |
} |
|
| 1454 | 6315x |
} else if (Sinv.method == "eigen") {
|
| 1455 | 6315x |
EV <- eigen(S, symmetric = TRUE) |
| 1456 |
# V %*% diag(1/d) %*% V^{-1}, where V^{-1} = V^T
|
|
| 1457 | 6315x |
S.inv <- |
| 1458 | 6315x |
tcrossprod( |
| 1459 | 6315x |
EV$vectors / rep(EV$values, each = length(EV$values)), |
| 1460 | 6315x |
EV$vectors |
| 1461 |
) |
|
| 1462 | ||
| 1463 |
# 0.5 version |
|
| 1464 |
# S.inv <- tcrossprod(sweep(EV$vectors, 2L, |
|
| 1465 |
# STATS = (1/EV$values), FUN="*"), EV$vectors) |
|
| 1466 | ||
| 1467 | 6315x |
if (logdet) {
|
| 1468 | 2162x |
if (all(EV$values >= 0)) {
|
| 1469 | 2154x |
attr(S.inv, "logdet") <- sum(log(EV$values)) |
| 1470 |
} else {
|
|
| 1471 | 8x |
attr(S.inv, "logdet") <- as.numeric(NA) |
| 1472 |
} |
|
| 1473 |
} |
|
| 1474 | ! |
} else if (Sinv.method == "solve") {
|
| 1475 | ! |
S.inv <- solve.default(S) |
| 1476 | ! |
if (logdet) {
|
| 1477 | ! |
ev <- eigen(S, symmetric = TRUE, only.values = TRUE) |
| 1478 | ! |
if (all(ev$values >= 0)) {
|
| 1479 | ! |
attr(S.inv, "logdet") <- sum(log(ev$values)) |
| 1480 |
} else {
|
|
| 1481 | ! |
attr(S.inv, "logdet") <- as.numeric(NA) |
| 1482 |
} |
|
| 1483 |
} |
|
| 1484 | ! |
} else if (Sinv.method == "chol") {
|
| 1485 |
# this will break if S is not positive definite |
|
| 1486 | ! |
cS <- chol.default(S) |
| 1487 | ! |
S.inv <- chol2inv(cS) |
| 1488 | ! |
if (logdet) {
|
| 1489 | ! |
diag.cS <- diag(cS) |
| 1490 | ! |
attr(S.inv, "logdet") <- sum(log(diag.cS * diag.cS)) |
| 1491 |
} |
|
| 1492 |
} else {
|
|
| 1493 | ! |
lav_msg_stop(gettext("method must be either `eigen', `solve' or `chol'"))
|
| 1494 |
} |
|
| 1495 | ||
| 1496 | 7023x |
if (length(zero.idx) > 0L) {
|
| 1497 | 12x |
logdet <- attr(S.inv, "logdet") |
| 1498 | 12x |
tmp <- S.orig |
| 1499 | 12x |
tmp[-zero.idx, -zero.idx] <- S.inv |
| 1500 | 12x |
S.inv <- tmp |
| 1501 | 12x |
attr(S.inv, "logdet") <- logdet |
| 1502 | 12x |
attr(S.inv, "zero.idx") <- zero.idx |
| 1503 |
} |
|
| 1504 | ||
| 1505 | 7023x |
S.inv |
| 1506 |
} |
|
| 1507 | ||
| 1508 |
# update inverse of A, after removing 1 or more rows (and corresponding |
|
| 1509 |
# colums) from A |
|
| 1510 |
# |
|
| 1511 |
# - this is just an application of the inverse of partitioned matrices |
|
| 1512 |
# - only removal for now |
|
| 1513 |
# |
|
| 1514 |
lav_matrix_inverse_update <- function(A.inv, rm.idx = integer(0L)) {
|
|
| 1515 | ! |
ndel <- length(rm.idx) |
| 1516 | ||
| 1517 |
# rank-1 update |
|
| 1518 | ! |
if (ndel == 1L) {
|
| 1519 | ! |
a <- A.inv[-rm.idx, rm.idx, drop = FALSE] |
| 1520 | ! |
b <- A.inv[rm.idx, -rm.idx, drop = FALSE] |
| 1521 | ! |
h <- A.inv[rm.idx, rm.idx] |
| 1522 | ! |
out <- A.inv[-rm.idx, -rm.idx, drop = FALSE] - (a %*% b) / h |
| 1523 |
} |
|
| 1524 | ||
| 1525 |
# rank-n update |
|
| 1526 | ! |
else if (ndel < NCOL(A.inv)) {
|
| 1527 | ! |
A <- A.inv[-rm.idx, rm.idx, drop = FALSE] |
| 1528 | ! |
B <- A.inv[rm.idx, -rm.idx, drop = FALSE] |
| 1529 | ! |
H <- A.inv[rm.idx, rm.idx, drop = FALSE] |
| 1530 | ! |
out <- A.inv[-rm.idx, -rm.idx, drop = FALSE] - A %*% solve.default(H, B) |
| 1531 | ||
| 1532 |
# erase all col/rows... |
|
| 1533 | ! |
} else if (ndel == NCOL(A.inv)) {
|
| 1534 | ! |
out <- matrix(0, 0, 0) |
| 1535 |
} |
|
| 1536 | ||
| 1537 | ! |
out |
| 1538 |
} |
|
| 1539 | ||
| 1540 |
# update inverse of S, after removing 1 or more rows (and corresponding |
|
| 1541 |
# colums) from S, a symmetric matrix |
|
| 1542 |
# |
|
| 1543 |
# - only removal for now! |
|
| 1544 |
# |
|
| 1545 |
lav_matrix_symmetric_inverse_update <- function(S.inv, rm.idx = integer(0L), |
|
| 1546 |
logdet = FALSE, |
|
| 1547 |
S.logdet = NULL) {
|
|
| 1548 | 1168x |
ndel <- length(rm.idx) |
| 1549 | ||
| 1550 | 1168x |
if (ndel == 0L) {
|
| 1551 | ! |
out <- S.inv |
| 1552 | ! |
if (logdet) {
|
| 1553 | ! |
attr(out, "logdet") <- S.logdet |
| 1554 |
} |
|
| 1555 |
} |
|
| 1556 | ||
| 1557 |
# rank-1 update |
|
| 1558 | 1168x |
else if (ndel == 1L) {
|
| 1559 | 120x |
h <- S.inv[rm.idx, rm.idx] |
| 1560 | 120x |
a <- S.inv[-rm.idx, rm.idx, drop = FALSE] / sqrt(h) |
| 1561 | 120x |
out <- S.inv[-rm.idx, -rm.idx, drop = FALSE] - tcrossprod(a) |
| 1562 | 120x |
if (logdet) {
|
| 1563 | 96x |
attr(out, "logdet") <- S.logdet + log(h) |
| 1564 |
} |
|
| 1565 |
} |
|
| 1566 | ||
| 1567 |
# rank-n update |
|
| 1568 | 1048x |
else if (ndel < NCOL(S.inv)) {
|
| 1569 | 1048x |
A <- S.inv[rm.idx, -rm.idx, drop = FALSE] |
| 1570 | 1048x |
H <- S.inv[rm.idx, rm.idx, drop = FALSE] |
| 1571 | 1048x |
out <- (S.inv[-rm.idx, -rm.idx, drop = FALSE] - |
| 1572 | 1048x |
crossprod(A, solve.default(H, A))) |
| 1573 | 1048x |
if (logdet) {
|
| 1574 |
# cH <- chol.default(Re(H)); diag.cH <- diag(cH) |
|
| 1575 |
# H.logdet <- sum(log(diag.cH * diag.cH)) |
|
| 1576 | 968x |
H.logdet <- log(det(H)) |
| 1577 | 968x |
attr(out, "logdet") <- S.logdet + H.logdet |
| 1578 |
} |
|
| 1579 | ||
| 1580 |
# erase all col/rows... |
|
| 1581 | ! |
} else if (ndel == NCOL(S.inv)) {
|
| 1582 | ! |
out <- matrix(0, 0, 0) |
| 1583 |
} else {
|
|
| 1584 | ! |
lav_msg_stop(gettext("column indices exceed number of columns in S.inv"))
|
| 1585 |
} |
|
| 1586 | ||
| 1587 | 1168x |
out |
| 1588 |
} |
|
| 1589 | ||
| 1590 | ||
| 1591 |
# update determinant of A, after removing 1 or more rows (and corresponding |
|
| 1592 |
# colums) from A |
|
| 1593 |
# |
|
| 1594 |
lav_matrix_det_update <- function(det.A, A.inv, rm.idx = integer(0L)) {
|
|
| 1595 | ! |
ndel <- length(rm.idx) |
| 1596 | ||
| 1597 |
# rank-1 update |
|
| 1598 | ! |
if (ndel == 1L) {
|
| 1599 | ! |
h <- A.inv[rm.idx, rm.idx] |
| 1600 | ! |
out <- det.A * h |
| 1601 |
} |
|
| 1602 | ||
| 1603 |
# rank-n update |
|
| 1604 | ! |
else if (ndel < NCOL(A.inv)) {
|
| 1605 | ! |
H <- A.inv[rm.idx, rm.idx, drop = FALSE] |
| 1606 | ! |
det.H <- det(H) |
| 1607 | ! |
out <- det.A * det.H |
| 1608 | ||
| 1609 |
# erase all col/rows... |
|
| 1610 | ! |
} else if (ndel == NCOL(A.inv)) {
|
| 1611 | ! |
out <- matrix(0, 0, 0) |
| 1612 |
} |
|
| 1613 | ||
| 1614 | ! |
out |
| 1615 |
} |
|
| 1616 | ||
| 1617 |
# update determinant of S, after removing 1 or more rows (and corresponding |
|
| 1618 |
# colums) from S, a symmetric matrix |
|
| 1619 |
# |
|
| 1620 |
lav_matrix_symmetric_det_update <- function(det.S, S.inv, rm.idx = integer(0L)) {
|
|
| 1621 | ! |
ndel <- length(rm.idx) |
| 1622 | ||
| 1623 |
# rank-1 update |
|
| 1624 | ! |
if (ndel == 1L) {
|
| 1625 | ! |
h <- S.inv[rm.idx, rm.idx] |
| 1626 | ! |
out <- det.S * h |
| 1627 |
} |
|
| 1628 | ||
| 1629 |
# rank-n update |
|
| 1630 | ! |
else if (ndel < NCOL(S.inv)) {
|
| 1631 | ! |
H <- S.inv[rm.idx, rm.idx, drop = FALSE] |
| 1632 | ! |
cH <- chol.default(H) |
| 1633 | ! |
diag.cH <- diag(cH) |
| 1634 | ! |
det.H <- prod(diag.cH * diag.cH) |
| 1635 | ! |
out <- det.S * det.H |
| 1636 | ||
| 1637 |
# erase all col/rows... |
|
| 1638 | ! |
} else if (ndel == NCOL(S.inv)) {
|
| 1639 | ! |
out <- numeric(0L) |
| 1640 |
} |
|
| 1641 | ||
| 1642 | ! |
out |
| 1643 |
} |
|
| 1644 | ||
| 1645 |
# update log determinant of S, after removing 1 or more rows (and corresponding |
|
| 1646 |
# colums) from S, a symmetric matrix |
|
| 1647 |
# |
|
| 1648 |
lav_matrix_symmetric_logdet_update <- function(S.logdet, S.inv, |
|
| 1649 |
rm.idx = integer(0L)) {
|
|
| 1650 | ! |
ndel <- length(rm.idx) |
| 1651 | ||
| 1652 |
# rank-1 update |
|
| 1653 | ! |
if (ndel == 1L) {
|
| 1654 | ! |
h <- S.inv[rm.idx, rm.idx] |
| 1655 | ! |
out <- S.logdet + log(h) |
| 1656 |
} |
|
| 1657 | ||
| 1658 |
# rank-n update |
|
| 1659 | ! |
else if (ndel < NCOL(S.inv)) {
|
| 1660 | ! |
H <- S.inv[rm.idx, rm.idx, drop = FALSE] |
| 1661 | ! |
cH <- chol.default(H) |
| 1662 | ! |
diag.cH <- diag(cH) |
| 1663 | ! |
H.logdet <- sum(log(diag.cH * diag.cH)) |
| 1664 | ! |
out <- S.logdet + H.logdet |
| 1665 | ||
| 1666 |
# erase all col/rows... |
|
| 1667 | ! |
} else if (ndel == NCOL(S.inv)) {
|
| 1668 | ! |
out <- numeric(0L) |
| 1669 |
} |
|
| 1670 | ||
| 1671 | ! |
out |
| 1672 |
} |
|
| 1673 | ||
| 1674 |
# compute `lambda': the smallest root of the determinantal equation |
|
| 1675 |
# |M - lambda*P| = 0 (see Fuller 1987, p.125 or p.172 |
|
| 1676 |
# |
|
| 1677 |
# the function allows for zero rows/columns in P, by regressing them out |
|
| 1678 |
# this approach was suggested to me by Wayne A. Fuller, personal communication, |
|
| 1679 |
# 12 Nov 2020 |
|
| 1680 |
# |
|
| 1681 |
lav_matrix_symmetric_diff_smallest_root <- function(M = NULL, P = NULL) {
|
|
| 1682 |
# check input (we will 'assume' they are square and symmetric) |
|
| 1683 | ! |
stopifnot(is.matrix(M), is.matrix(P)) |
| 1684 | ||
| 1685 |
# check if P is diagonal or not |
|
| 1686 | ! |
PdiagFlag <- FALSE |
| 1687 | ! |
tmp <- P |
| 1688 | ! |
diag(tmp) <- 0 |
| 1689 | ! |
if (all(abs(tmp) < sqrt(.Machine$double.eps))) {
|
| 1690 | ! |
PdiagFlag <- TRUE |
| 1691 |
} |
|
| 1692 | ||
| 1693 |
# diagonal elements of P |
|
| 1694 | ! |
nP <- nrow(P) |
| 1695 | ! |
diagP <- P[lav_matrix_diag_idx(nP)] |
| 1696 | ||
| 1697 |
# force diagonal elements of P to be nonnegative (warn?) |
|
| 1698 | ! |
neg.idx <- which(diagP < 0) |
| 1699 | ! |
if (length(neg.idx) > 0L) {
|
| 1700 | ! |
lav_msg_warn(gettext( |
| 1701 | ! |
"some diagonal elements of P are negative (and set to zero)")) |
| 1702 | ! |
diag(P)[neg.idx] <- diagP[neg.idx] <- 0 |
| 1703 |
} |
|
| 1704 | ||
| 1705 |
# check for (near)zero diagonal elements |
|
| 1706 | ! |
zero.idx <- which(abs(diagP) < sqrt(.Machine$double.eps)) |
| 1707 | ||
| 1708 |
# three cases: |
|
| 1709 |
# 1. all elements are zero (P=0) -> lambda = 0 |
|
| 1710 |
# 2. no elements are zero |
|
| 1711 |
# 3. some elements are zero -> regress out |
|
| 1712 | ||
| 1713 |
# 1. all elements are zero |
|
| 1714 | ! |
if (length(zero.idx) == nP) {
|
| 1715 | ! |
return(0.0) |
| 1716 |
} |
|
| 1717 | ||
| 1718 |
# 2. no elements are zero |
|
| 1719 | ! |
else if (length(zero.idx) == 0L) {
|
| 1720 | ! |
if (PdiagFlag) {
|
| 1721 | ! |
Ldiag <- 1 / sqrt(diagP) |
| 1722 | ! |
LML <- t(Ldiag * M) * Ldiag |
| 1723 |
} else {
|
|
| 1724 | ! |
L <- solve(lav_matrix_symmetric_sqrt(P)) |
| 1725 | ! |
LML <- L %*% M %*% t(L) |
| 1726 |
} |
|
| 1727 | ||
| 1728 |
# compute lambda |
|
| 1729 | ! |
lambda <- eigen(LML, symmetric = TRUE, only.values = TRUE)$values[nP] |
| 1730 | ||
| 1731 |
# 3. some elements are zero |
|
| 1732 |
} else {
|
|
| 1733 |
# regress out M-block corresponding to zero diagonal elements in P |
|
| 1734 | ||
| 1735 |
# partition M accordingly: p = positive, n = negative |
|
| 1736 | ! |
M.pp <- M[-zero.idx, -zero.idx, drop = FALSE] |
| 1737 | ! |
M.pn <- M[-zero.idx, zero.idx, drop = FALSE] |
| 1738 | ! |
M.np <- M[zero.idx, -zero.idx, drop = FALSE] |
| 1739 | ! |
M.nn <- M[zero.idx, zero.idx, drop = FALSE] |
| 1740 | ||
| 1741 |
# create Mp.n |
|
| 1742 | ! |
Mp.n <- M.pp - M.pn %*% solve(M.nn) %*% M.np |
| 1743 | ||
| 1744 |
# extract positive part of P |
|
| 1745 | ! |
P.p <- P[-zero.idx, -zero.idx, drop = FALSE] |
| 1746 | ||
| 1747 |
# compute smallest root |
|
| 1748 | ! |
if (PdiagFlag) {
|
| 1749 | ! |
diagPp <- diag(P.p) |
| 1750 | ! |
Ldiag <- 1 / sqrt(diagPp) |
| 1751 | ! |
LML <- t(Ldiag * Mp.n) * Ldiag |
| 1752 |
} else {
|
|
| 1753 | ! |
L <- solve(lav_matrix_symmetric_sqrt(P.p)) |
| 1754 | ! |
LML <- L %*% Mp.n %*% t(L) |
| 1755 |
} |
|
| 1756 | ! |
lambda <- eigen(LML, |
| 1757 | ! |
symmetric = TRUE, |
| 1758 | ! |
only.values = TRUE |
| 1759 | ! |
)$values[nrow(P.p)] |
| 1760 |
} |
|
| 1761 | ||
| 1762 | ! |
lambda |
| 1763 |
} |
|
| 1764 | ||
| 1765 |
# force a symmetric matrix to be positive definite |
|
| 1766 |
# simple textbook version (see Matrix::nearPD for a more sophisticated version) |
|
| 1767 |
# |
|
| 1768 |
lav_matrix_symmetric_force_pd <- function(S, tol = 1e-06) {
|
|
| 1769 | 79x |
if (ncol(S) == 1L) {
|
| 1770 | ! |
return(matrix(max(S[1, 1], tol), 1L, 1L)) |
| 1771 |
} |
|
| 1772 | ||
| 1773 |
# eigen decomposition |
|
| 1774 | 79x |
S.eigen <- eigen(S, symmetric = TRUE) |
| 1775 | ||
| 1776 |
# eigen values |
|
| 1777 | 79x |
ev <- S.eigen$values |
| 1778 | ||
| 1779 |
# replace small/negative eigen values |
|
| 1780 | 79x |
ev[ev / abs(ev[1]) < tol] <- tol * abs(ev[1]) |
| 1781 | ||
| 1782 |
# reconstruct |
|
| 1783 | 79x |
out <- S.eigen$vectors %*% diag(ev) %*% t(S.eigen$vectors) |
| 1784 | ||
| 1785 | 79x |
out |
| 1786 |
} |
|
| 1787 | ||
| 1788 |
# compute sample covariance matrix, divided by 'N' (not N-1, as in cov) |
|
| 1789 |
# |
|
| 1790 |
# Mu is not supposed to be ybar, but close |
|
| 1791 |
# if provided, we compute S as 1/N*crossprod(Y - Mu) instead of |
|
| 1792 |
# 1/N*crossprod(Y - ybar) |
|
| 1793 |
lav_matrix_cov <- function(Y, Mu = NULL) {
|
|
| 1794 | 8x |
N <- NROW(Y) |
| 1795 | 8x |
S1 <- stats::cov(Y) # uses a corrected two-pass algorithm |
| 1796 | 8x |
S <- S1 * (N - 1) / N |
| 1797 | ||
| 1798 |
# Mu? |
|
| 1799 | 8x |
if (!is.null(Mu)) {
|
| 1800 | ! |
P <- NCOL(Y) |
| 1801 | ! |
ybar <- base::.colMeans(Y, m = N, n = P) |
| 1802 | ! |
S <- S + tcrossprod(ybar - Mu) |
| 1803 |
} |
|
| 1804 | ||
| 1805 | 8x |
S |
| 1806 |
} |
|
| 1807 | ||
| 1808 |
# transform a matrix to match a given target mean/covariance |
|
| 1809 |
lav_matrix_transform_mean_cov <- function(Y, |
|
| 1810 |
target.mean = numeric(NCOL(Y)), |
|
| 1811 |
target.cov = diag(NCOL(Y))) {
|
|
| 1812 |
# coerce to matrix |
|
| 1813 | ! |
Y <- as.matrix.default(Y) |
| 1814 | ||
| 1815 |
# convert to vector |
|
| 1816 | ! |
target.mean <- as.vector(target.mean) |
| 1817 | ||
| 1818 | ! |
S <- lav_matrix_cov(Y) |
| 1819 | ! |
S.inv <- solve.default(S) |
| 1820 | ! |
S.inv.sqrt <- lav_matrix_symmetric_sqrt(S.inv) |
| 1821 | ! |
target.cov.sqrt <- lav_matrix_symmetric_sqrt(target.cov) |
| 1822 | ||
| 1823 |
# transform cov |
|
| 1824 | ! |
X <- Y %*% S.inv.sqrt %*% target.cov.sqrt |
| 1825 | ||
| 1826 |
# shift mean |
|
| 1827 | ! |
xbar <- colMeans(X) |
| 1828 | ! |
X <- t(t(X) - xbar + target.mean) |
| 1829 | ||
| 1830 | ! |
X |
| 1831 |
} |
|
| 1832 | ||
| 1833 |
# weighted column means |
|
| 1834 |
# |
|
| 1835 |
# for each column in Y: mean = sum(wt * Y)/sum(wt) |
|
| 1836 |
# |
|
| 1837 |
# if we have missing values, we use only the observations and weights |
|
| 1838 |
# that are NOT missing |
|
| 1839 |
# |
|
| 1840 |
lav_matrix_mean_wt <- function(Y, wt = NULL) {
|
|
| 1841 | ! |
Y <- unname(as.matrix.default(Y)) |
| 1842 | ! |
DIM <- dim(Y) |
| 1843 | ||
| 1844 | ! |
if (is.null(wt)) {
|
| 1845 | ! |
return(colMeans(Y, na.rm = TRUE)) |
| 1846 |
} |
|
| 1847 | ||
| 1848 | ! |
if (anyNA(Y)) {
|
| 1849 | ! |
WT <- wt * !is.na(Y) |
| 1850 | ! |
wN <- .colSums(WT, m = DIM[1], n = DIM[2]) |
| 1851 | ! |
out <- .colSums(wt * Y, m = DIM[1], n = DIM[2], na.rm = TRUE) / wN |
| 1852 |
} else {
|
|
| 1853 | ! |
out <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt) |
| 1854 |
} |
|
| 1855 | ||
| 1856 | ! |
out |
| 1857 |
} |
|
| 1858 | ||
| 1859 |
# weighted column variances |
|
| 1860 |
# |
|
| 1861 |
# for each column in Y: var = sum(wt * (Y - w.mean(Y))^2) / N |
|
| 1862 |
# |
|
| 1863 |
# where N = sum(wt) - 1 (method = "unbiased") assuming wt are frequency weights |
|
| 1864 |
# or N = sum(wt) (method = "ML") |
|
| 1865 |
# |
|
| 1866 |
# Note: another approach (when the weights are 'reliability weights' is to |
|
| 1867 |
# use N = sum(wt) - sum(wt^2)/sum(wt) (not implemented here) |
|
| 1868 |
# |
|
| 1869 |
# if we have missing values, we use only the observations and weights |
|
| 1870 |
# that are NOT missing |
|
| 1871 |
# |
|
| 1872 |
lav_matrix_var_wt <- function(Y, wt = NULL, method = c("unbiased", "ML")) {
|
|
| 1873 | ! |
Y <- unname(as.matrix.default(Y)) |
| 1874 | ! |
DIM <- dim(Y) |
| 1875 | ||
| 1876 | ! |
if (is.null(wt)) {
|
| 1877 | ! |
wt <- rep(1, nrow(Y)) |
| 1878 |
} |
|
| 1879 | ||
| 1880 | ! |
if (anyNA(Y)) {
|
| 1881 | ! |
WT <- wt * !is.na(Y) |
| 1882 | ! |
wN <- .colSums(WT, m = DIM[1], n = DIM[2]) |
| 1883 | ! |
w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2], na.rm = TRUE) / wN |
| 1884 | ! |
Ytc <- t(t(Y) - w.mean) |
| 1885 | ! |
tmp <- .colSums(wt * Ytc * Ytc, m = DIM[1], n = DIM[2], na.rm = TRUE) |
| 1886 | ! |
out <- switch(match.arg(method), |
| 1887 | ! |
unbiased = tmp / (wN - 1), |
| 1888 | ! |
ML = tmp / wN |
| 1889 |
) |
|
| 1890 |
} else {
|
|
| 1891 | ! |
w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt) |
| 1892 | ! |
Ytc <- t(t(Y) - w.mean) |
| 1893 | ! |
tmp <- .colSums(wt * Ytc * Ytc, m = DIM[1], n = DIM[2]) |
| 1894 | ! |
out <- switch(match.arg(method), |
| 1895 | ! |
unbiased = tmp / (sum(wt) - 1), |
| 1896 | ! |
ML = tmp / sum(wt) |
| 1897 |
) |
|
| 1898 |
} |
|
| 1899 | ||
| 1900 | ! |
out |
| 1901 |
} |
|
| 1902 | ||
| 1903 |
# weighted variance-covariance matrix |
|
| 1904 |
# |
|
| 1905 |
# always dividing by sum(wt) (for now) (=ML version) |
|
| 1906 |
# |
|
| 1907 |
# if we have missing values, we use only the observations and weights |
|
| 1908 |
# that are NOT missing |
|
| 1909 |
# |
|
| 1910 |
# same as cov.wt(Y, wt, method = "ML") |
|
| 1911 |
# |
|
| 1912 |
lav_matrix_cov_wt <- function(Y, wt = NULL) {
|
|
| 1913 | ! |
Y <- unname(as.matrix.default(Y)) |
| 1914 | ! |
DIM <- dim(Y) |
| 1915 | ||
| 1916 | ! |
if (is.null(wt)) {
|
| 1917 | ! |
wt <- rep(1, nrow(Y)) |
| 1918 |
} |
|
| 1919 | ||
| 1920 | ! |
if (anyNA(Y)) {
|
| 1921 | ! |
tmp <- na.omit(cbind(Y, wt)) |
| 1922 | ! |
Y <- tmp[, seq_len(DIM[2]), drop = FALSE] |
| 1923 | ! |
wt <- tmp[, DIM[2] + 1L] |
| 1924 | ! |
DIM[1] <- nrow(Y) |
| 1925 | ! |
w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt) |
| 1926 | ! |
Ytc <- t(t(Y) - w.mean) |
| 1927 | ! |
tmp <- crossprod(sqrt(wt) * Ytc) |
| 1928 | ! |
out <- tmp / sum(wt) |
| 1929 |
} else {
|
|
| 1930 | ! |
w.mean <- .colSums(wt * Y, m = DIM[1], n = DIM[2]) / sum(wt) |
| 1931 | ! |
Ytc <- t(t(Y) - w.mean) |
| 1932 | ! |
tmp <- crossprod(sqrt(wt) * Ytc) |
| 1933 | ! |
out <- tmp / sum(wt) |
| 1934 |
} |
|
| 1935 | ||
| 1936 | ! |
out |
| 1937 |
} |
|
| 1938 | ||
| 1939 |
# compute (I-A)^{-1} where A is square
|
|
| 1940 |
# using a (truncated) Neumann series: (I-A)^{-1} = \sum_k=0^{\infty} A^k
|
|
| 1941 |
# = I + A + A^2 + A^3 + ... |
|
| 1942 |
# |
|
| 1943 |
# note: this only works if the largest eigenvalue for A is < 1; but if A |
|
| 1944 |
# represents regressions, the diagonal will be zero, and all eigenvalues |
|
| 1945 |
# are zero |
|
| 1946 |
# |
|
| 1947 |
# as A is typically sparse, we can stop if all elements in A^k are zero for, |
|
| 1948 |
# say, k<=6 |
|
| 1949 |
lav_matrix_inverse_iminus <- function(A = NULL) {
|
|
| 1950 | ! |
nr <- nrow(A) |
| 1951 | ! |
nc <- ncol(A) |
| 1952 | ! |
stopifnot(nr == nc) |
| 1953 | ||
| 1954 |
# create I + A |
|
| 1955 | ! |
IA <- A |
| 1956 | ! |
diag.idx <- lav_matrix_diag_idx(nr) |
| 1957 | ! |
IA[diag.idx] <- IA[diag.idx] + 1 |
| 1958 | ||
| 1959 |
# initial approximation |
|
| 1960 | ! |
IA.inv <- IA |
| 1961 | ||
| 1962 |
# first order |
|
| 1963 | ! |
A2 <- A %*% A |
| 1964 | ! |
if (all(A2 == 0)) {
|
| 1965 |
# we are done |
|
| 1966 | ! |
return(IA.inv) |
| 1967 |
} else {
|
|
| 1968 | ! |
IA.inv <- IA.inv + A2 |
| 1969 |
} |
|
| 1970 | ||
| 1971 |
# second order |
|
| 1972 | ! |
A3 <- A2 %*% A |
| 1973 | ! |
if (all(A3 == 0)) {
|
| 1974 |
# we are done |
|
| 1975 | ! |
return(IA.inv) |
| 1976 |
} else {
|
|
| 1977 | ! |
IA.inv <- IA.inv + A3 |
| 1978 |
} |
|
| 1979 | ||
| 1980 |
# third order |
|
| 1981 | ! |
A4 <- A3 %*% A |
| 1982 | ! |
if (all(A4 == 0)) {
|
| 1983 |
# we are done |
|
| 1984 | ! |
return(IA.inv) |
| 1985 |
} else {
|
|
| 1986 | ! |
IA.inv <- IA.inv + A4 |
| 1987 |
} |
|
| 1988 | ||
| 1989 |
# fourth order |
|
| 1990 | ! |
A5 <- A4 %*% A |
| 1991 | ! |
if (all(A5 == 0)) {
|
| 1992 |
# we are done |
|
| 1993 | ! |
return(IA.inv) |
| 1994 |
} else {
|
|
| 1995 | ! |
IA.inv <- IA.inv + A5 |
| 1996 |
} |
|
| 1997 | ||
| 1998 |
# fifth order |
|
| 1999 | ! |
A6 <- A5 %*% A |
| 2000 | ! |
if (all(A6 == 0)) {
|
| 2001 |
# we are done |
|
| 2002 | ! |
return(IA.inv) |
| 2003 |
} else {
|
|
| 2004 |
# naive version (for now) |
|
| 2005 | ! |
tmp <- -A |
| 2006 | ! |
tmp[diag.idx] <- tmp[diag.idx] + 1 |
| 2007 | ! |
IA.inv <- solve(tmp) |
| 2008 | ! |
return(IA.inv) |
| 2009 |
} |
|
| 2010 |
} |
| 1 |
# various ways to compute a (scaled) difference chi-square test statistic |
|
| 2 | ||
| 3 |
# - 0.6-13: fix multiple-group UG^2 bug in Satorra.2000 (reported by |
|
| 4 |
# Gronneberg, Foldnes and Moss) when Satterthwaite = TRUE and |
|
| 5 |
# ngroups > 1L (use old.approach = TRUE to get the old result) |
|
| 6 | ||
| 7 |
lav_test_diff_Satorra2000 <- function(m1, m0, H1 = TRUE, A.method = "delta", |
|
| 8 |
A = NULL, |
|
| 9 |
Satterthwaite = FALSE, |
|
| 10 |
scaled.shifted = FALSE, |
|
| 11 |
old.approach = FALSE) {
|
|
| 12 | ! |
if (scaled.shifted) {
|
| 13 | ! |
Satterthwaite <- TRUE |
| 14 |
} |
|
| 15 | ||
| 16 |
# extract information from m1 and m2 |
|
| 17 | ! |
T1 <- m1@test[[1]]$stat |
| 18 | ! |
r1 <- m1@test[[1]]$df |
| 19 | ||
| 20 | ! |
T0 <- m0@test[[1]]$stat |
| 21 | ! |
r0 <- m0@test[[1]]$df |
| 22 | ||
| 23 |
# m = difference between the df's |
|
| 24 | ! |
m <- r0 - r1 |
| 25 | ||
| 26 |
# check for identical df setting |
|
| 27 | ! |
if (m == 0L) {
|
| 28 | ! |
return(list( |
| 29 | ! |
T.delta = (T0 - T1), scaling.factor = as.numeric(NA), |
| 30 | ! |
df.delta = m, a = as.numeric(NA), b = as.numeric(NA) |
| 31 |
)) |
|
| 32 |
} |
|
| 33 | ||
| 34 |
# check for (near) identical test statistics (despite m > 0) |
|
| 35 | ! |
if (abs(T1 - T0) < sqrt(.Machine$double.eps)) {
|
| 36 | ! |
lav_msg_warn(gettext("the test statistic of the restriced model is (nearly)
|
| 37 | ! |
identical to the test statistic of the full model; |
| 38 | ! |
check your models.")) |
| 39 |
} |
|
| 40 | ||
| 41 | ||
| 42 |
# bail out here, if m == 0 (but we should catch this earlier) |
|
| 43 |
# if(m < 1L) {
|
|
| 44 |
# txt <- paste("Can not compute (scaled) difference test when ",
|
|
| 45 |
# "the degrees of freedom (df) are the same for both ", |
|
| 46 |
# "models:\n", |
|
| 47 |
# "Df model 1 = ", r1, ", and Df model 2 = ", r0, "\n", |
|
| 48 |
# sep = "") |
|
| 49 |
# stop(lav_txt2message(txt, header = "lavaan ERROR:")) |
|
| 50 |
# } |
|
| 51 | ||
| 52 | ! |
Gamma <- lavTech(m1, "Gamma") # the same for m1 and m0 |
| 53 |
# check for NULL |
|
| 54 | ! |
if (is.null(Gamma)) {
|
| 55 | ! |
lav_msg_stop(gettext( |
| 56 | ! |
"can not compute Gamma matrix; perhaps missing = \"ml\"?")) |
| 57 |
} |
|
| 58 | ||
| 59 | ! |
if (H1) {
|
| 60 | ! |
WLS.V <- lavTech(m1, "WLS.V") |
| 61 | ! |
PI <- lav_model_delta(m1@Model) |
| 62 | ! |
P <- lavTech(m1, "information") |
| 63 |
# needed? (yes, if H1 already has eq constraints) |
|
| 64 | ! |
P.inv <- lav_model_information_augment_invert(m1@Model, |
| 65 | ! |
information = P, |
| 66 | ! |
inverted = TRUE |
| 67 |
) |
|
| 68 |
# compute 'A' matrix |
|
| 69 |
# NOTE: order of parameters may change between H1 and H0, so be |
|
| 70 |
# careful! |
|
| 71 | ! |
if (is.null(A)) {
|
| 72 | ! |
A <- lav_test_diff_A(m1, m0, method = A.method, reference = "H1") |
| 73 |
# take into account equality constraints m1 |
|
| 74 | ! |
if (A.method == "delta") {
|
| 75 | ! |
if (m1@Model@eq.constraints) {
|
| 76 | ! |
A <- A %*% t(m1@Model@eq.constraints.K) |
| 77 | ! |
} else if (m1@Model@ceq.simple.only) {
|
| 78 | ! |
A <- A %*% t(m1@Model@ceq.simple.K) |
| 79 |
} |
|
| 80 |
} |
|
| 81 | ! |
if (lav_debug()) print(A) |
| 82 |
} |
|
| 83 |
} else {
|
|
| 84 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 85 | ||
| 86 | ! |
WLS.V <- lavTech(m0, "WLS.V") |
| 87 | ! |
PI <- lav_model_delta(m0@Model) |
| 88 | ! |
P <- lavTech(m0, "information") |
| 89 |
# needed? |
|
| 90 | ! |
P.inv <- lav_model_information_augment_invert(m0@Model, |
| 91 | ! |
information = P, |
| 92 | ! |
inverted = TRUE |
| 93 |
) |
|
| 94 | ||
| 95 |
# compute 'A' matrix |
|
| 96 |
# NOTE: order of parameters may change between H1 and H0, so be |
|
| 97 |
# careful! |
|
| 98 | ! |
if (is.null(A)) {
|
| 99 |
# m1, m0 OR m0, m1 (works for delta, but not for exact) |
|
| 100 | ! |
A <- lav_test_diff_A(m1, m0, method = A.method, reference = "H0") |
| 101 |
# take into account equality constraints m1 |
|
| 102 | ! |
if (m0@Model@eq.constraints) {
|
| 103 | ! |
A <- A %*% t(m0@Model@eq.constraints.K) |
| 104 | ! |
} else if (m0@Model@ceq.simple.only) {
|
| 105 | ! |
A <- A %*% t(m0@Model@ceq.simple.K) |
| 106 |
} |
|
| 107 | ! |
if (lav_debug()) print(A) |
| 108 |
} |
|
| 109 |
} |
|
| 110 | ||
| 111 |
# compute tr UG per group |
|
| 112 | ! |
ngroups <- m1@SampleStats@ngroups |
| 113 | ! |
UG.group <- vector("list", length = ngroups)
|
| 114 | ||
| 115 |
# safety check: A %*% P.inv %*% t(A) should NOT contain all-zero |
|
| 116 |
# rows/columns |
|
| 117 |
# FIXME: is this really needed? As we use ginv later on |
|
| 118 | ! |
APA <- A %*% P.inv %*% t(A) |
| 119 | ! |
cSums <- colSums(APA) |
| 120 | ! |
rSums <- rowSums(APA) |
| 121 | ! |
empty.idx <- which(abs(cSums) < .Machine$double.eps^0.5 & |
| 122 | ! |
abs(rSums) < .Machine$double.eps^0.5) |
| 123 | ! |
if (length(empty.idx) > 0) {
|
| 124 | ! |
A <- A[-empty.idx, , drop = FALSE] |
| 125 |
} |
|
| 126 | ! |
if (nrow(A) == 0L) {
|
| 127 |
# oops... abort! |
|
| 128 | ! |
return(list( |
| 129 | ! |
T.delta = (T0 - T1), scaling.factor = as.numeric(NA), |
| 130 | ! |
df.delta = m, a = as.numeric(NA), b = as.numeric(NA) |
| 131 |
)) |
|
| 132 |
} |
|
| 133 | ||
| 134 |
# PAAPAAP |
|
| 135 | ! |
PAAPAAP <- P.inv %*% t(A) %*% MASS::ginv(A %*% P.inv %*% t(A)) %*% A %*% P.inv |
| 136 | ||
| 137 |
# compute scaling factor |
|
| 138 | ! |
fg <- unlist(m1@SampleStats@nobs) / m1@SampleStats@ntotal |
| 139 | ||
| 140 | ||
| 141 |
# this is what we did <0.6-13 |
|
| 142 | ! |
if (old.approach) {
|
| 143 | ! |
trace.UGamma <- numeric(ngroups) |
| 144 | ! |
trace.UGamma2 <- numeric(ngroups) |
| 145 | ! |
for (g in 1:ngroups) {
|
| 146 | ! |
UG.group <- WLS.V[[g]] %*% Gamma[[g]] %*% WLS.V[[g]] %*% |
| 147 | ! |
PI[[g]] %*% PAAPAAP %*% t(PI[[g]]) |
| 148 | ! |
trace.UGamma[g] <- sum(diag(UG.group)) |
| 149 | ! |
if (Satterthwaite) {
|
| 150 | ! |
trace.UGamma2[g] <- sum(diag(UG.group %*% UG.group)) |
| 151 |
} |
|
| 152 |
} |
|
| 153 | ||
| 154 | ! |
trace.UGamma <- sum(fg * trace.UGamma) |
| 155 | ! |
if (Satterthwaite) {
|
| 156 | ! |
trace.UGamma2 <- sum(fg * trace.UGamma2) |
| 157 |
} |
|
| 158 |
} else {
|
|
| 159 |
# for trace.UGamma, we can compute the trace per group |
|
| 160 |
# as in Satorra (2000) eq. 23 |
|
| 161 | ! |
trace.UGamma <- numeric(ngroups) |
| 162 | ! |
for (g in 1:ngroups) {
|
| 163 | ! |
UG.group <- WLS.V[[g]] %*% Gamma[[g]] %*% WLS.V[[g]] %*% |
| 164 | ! |
PI[[g]] %*% PAAPAAP %*% t(PI[[g]]) |
| 165 | ! |
trace.UGamma[g] <- sum(diag(UG.group)) |
| 166 |
} |
|
| 167 | ! |
trace.UGamma <- sum(fg * trace.UGamma) |
| 168 | ||
| 169 |
# but for trace.UGamma2, we can no longer compute the trace per group |
|
| 170 | ! |
trace.UGamma2 <- as.numeric(NA) |
| 171 | ! |
if (Satterthwaite) {
|
| 172 |
# global approach (not group-specific) |
|
| 173 | ! |
Gamma.f <- Gamma |
| 174 | ! |
for (g in seq_along(Gamma)) {
|
| 175 | ! |
Gamma.f[[g]] <- fg[g] * Gamma[[g]] |
| 176 |
} |
|
| 177 | ! |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 178 | ! |
V.all <- lav_matrix_bdiag(WLS.V) |
| 179 | ! |
PI.all <- do.call(rbind, PI) |
| 180 | ! |
U.all <- V.all %*% PI.all %*% PAAPAAP %*% t(PI.all) %*% V.all |
| 181 | ! |
UG.all <- U.all %*% Gamma.all |
| 182 | ! |
UG.all2 <- UG.all %*% UG.all |
| 183 | ! |
trace.UGamma2 <- sum(diag(UG.all2)) |
| 184 |
} |
|
| 185 |
} |
|
| 186 | ||
| 187 | ! |
if (Satterthwaite && !scaled.shifted) {
|
| 188 | ! |
cd <- trace.UGamma2 / trace.UGamma |
| 189 | ! |
df.delta <- trace.UGamma^2 / trace.UGamma2 |
| 190 | ! |
T.delta <- (T0 - T1) / cd |
| 191 | ! |
a <- as.numeric(NA) |
| 192 | ! |
b <- as.numeric(NA) |
| 193 | ! |
} else if (Satterthwaite && scaled.shifted) {
|
| 194 | ! |
a <- sqrt(m / trace.UGamma2) |
| 195 |
# b <- m - sqrt(m * trace.UGamma^2 / trace.UGamma2) |
|
| 196 | ! |
b <- m - a * trace.UGamma |
| 197 | ! |
df.delta <- m |
| 198 | ! |
T.delta <- (T0 - T1) * a + b |
| 199 | ! |
cd <- as.numeric(NA) |
| 200 |
} else {
|
|
| 201 | ! |
cd <- 1 / m * trace.UGamma |
| 202 | ! |
df.delta <- m |
| 203 | ! |
T.delta <- (T0 - T1) / cd |
| 204 | ! |
a <- as.numeric(NA) |
| 205 | ! |
b <- as.numeric(NA) |
| 206 |
} |
|
| 207 | ||
| 208 | ! |
list( |
| 209 | ! |
T.delta = T.delta, scaling.factor = cd, df.delta = df.delta, |
| 210 | ! |
trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2, |
| 211 | ! |
a = a, b = b |
| 212 |
) |
|
| 213 |
} |
|
| 214 | ||
| 215 |
lav_test_diff_SatorraBentler2001 <- function(m1, m0, test = 2) {
|
|
| 216 |
# extract information from m1 and m2 |
|
| 217 | ! |
T1 <- m1@test[[1]]$stat |
| 218 | ! |
r1 <- m1@test[[1]]$df |
| 219 | ! |
c1 <- m1@test[[test]]$scaling.factor |
| 220 | ||
| 221 |
## check for situations when scaling.factor would be NA |
|
| 222 | ! |
if (r1 == 0) {
|
| 223 |
## saturated model |
|
| 224 | ! |
c1 <- 1 # canceled out by 0 when calculating "cd" |
| 225 | ||
| 226 | ! |
} else if (r1 > 0 && isTRUE(all.equal(T1, 0))) {
|
| 227 |
## perfect fit |
|
| 228 | ! |
c1 <- 0 # cancels out r1 when calculating "cd" |
| 229 |
} |
|
| 230 | ||
| 231 | ! |
T0 <- m0@test[[1]]$stat |
| 232 | ! |
r0 <- m0@test[[1]]$df |
| 233 | ! |
c0 <- m0@test[[test]]$scaling.factor |
| 234 | ||
| 235 |
# m = difference between the df's |
|
| 236 | ! |
m <- r0 - r1 |
| 237 | ||
| 238 |
# check for identical df setting |
|
| 239 | ! |
if (m == 0L) {
|
| 240 | ! |
return(list( |
| 241 | ! |
T.delta = (T0 - T1), scaling.factor = as.numeric(NA), |
| 242 | ! |
df.delta = m |
| 243 |
)) |
|
| 244 |
} |
|
| 245 | ||
| 246 |
# compute c_d |
|
| 247 | ! |
cd <- (r0 * c0 - r1 * c1) / m |
| 248 | ||
| 249 |
# warn if cd is negative |
|
| 250 | ! |
if (cd < 0) {
|
| 251 | ! |
lav_msg_warn(gettext("scaling factor is negative"))
|
| 252 | ! |
cd <- as.numeric(NA) |
| 253 |
} |
|
| 254 | ||
| 255 |
# compute scaled difference test |
|
| 256 | ! |
T.delta <- (T0 - T1) / cd |
| 257 | ||
| 258 | ! |
list(T.delta = T.delta, scaling.factor = cd, df.delta = m) |
| 259 |
} |
|
| 260 | ||
| 261 |
lav_test_diff_SatorraBentler2010 <- function(m1, m0, test = 2, |
|
| 262 |
H1 = FALSE) {
|
|
| 263 |
### FIXME: check if models are nested at the parameter level!!! |
|
| 264 | ||
| 265 |
# extract information from m1 and m2 |
|
| 266 | ! |
T1 <- m1@test[[1]]$stat |
| 267 | ! |
r1 <- m1@test[[1]]$df |
| 268 | ! |
c1 <- m1@test[[test]]$scaling.factor |
| 269 | ! |
if (r1 == 0) { # saturated model
|
| 270 | ! |
c1 <- 1 |
| 271 |
} |
|
| 272 | ||
| 273 | ! |
T0 <- m0@test[[1]]$stat |
| 274 | ! |
r0 <- m0@test[[1]]$df |
| 275 | ! |
c0 <- m0@test[[test]]$scaling.factor |
| 276 | ! |
if (r0 == 0) { # should never happen
|
| 277 | ! |
c0 <- 1 |
| 278 |
} |
|
| 279 | ||
| 280 |
# m = difference between the df's |
|
| 281 | ! |
m <- r0 - r1 |
| 282 | ||
| 283 |
# check for identical df setting |
|
| 284 | ! |
if (m == 0L) {
|
| 285 | ! |
return(list( |
| 286 | ! |
T.delta = (T0 - T1), scaling.factor = as.numeric(NA), |
| 287 | ! |
df.delta = m |
| 288 |
)) |
|
| 289 |
} |
|
| 290 | ||
| 291 |
# generate `M10' model |
|
| 292 | ! |
if (H1) {
|
| 293 |
# M0 with M1 parameters |
|
| 294 | ! |
M01 <- lav_test_diff_m10(m0, m1, test = TRUE) |
| 295 | ! |
c01 <- M01@test[[test]]$scaling.factor |
| 296 | ||
| 297 |
# check if vcov is positive definite (new in 0.6) |
|
| 298 |
# if not, we may get negative values |
|
| 299 | ! |
eigvals <- eigen(lavTech(M01, "information"), |
| 300 | ! |
symmetric = TRUE, only.values = TRUE |
| 301 | ! |
)$values |
| 302 | ! |
if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
|
| 303 | ! |
lav_msg_warn(gettext( |
| 304 | ! |
"information matrix of the M01 model is not positive definite." |
| 305 |
)) |
|
| 306 |
# " As a result, the scale-factor can not be computed.") |
|
| 307 |
# cd <- as.numeric(NA) |
|
| 308 |
} # else {
|
|
| 309 |
# compute c_d |
|
| 310 |
# cd.01 <- (r0 * c01 - r1 * c0) / m ??? |
|
| 311 | ! |
cd <- (r0 * c0 - r1 * c01) / m |
| 312 |
# } |
|
| 313 |
} else {
|
|
| 314 |
# M1 with M0 parameters (as in Satorra & Bentler 2010) |
|
| 315 | ! |
M10 <- lav_test_diff_m10(m1, m0, test = TRUE) |
| 316 | ! |
c10 <- M10@test[[test]]$scaling.factor |
| 317 | ||
| 318 |
# check if vcov is positive definite (new in 0.6) |
|
| 319 |
# if not, we may get negative values |
|
| 320 | ! |
eigvals <- eigen(lavTech(M10, "information"), |
| 321 | ! |
symmetric = TRUE, only.values = TRUE |
| 322 | ! |
)$values |
| 323 | ! |
if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
|
| 324 | ! |
lav_msg_warn(gettext( |
| 325 | ! |
"information matrix of the M10 model is not positive definite." |
| 326 |
)) |
|
| 327 |
# " As a result, the scale-factor can not be computed.") |
|
| 328 |
# cd <- as.numeric(NA) |
|
| 329 |
} # else {
|
|
| 330 |
# compute c_d |
|
| 331 | ! |
cd <- (r0 * c0 - r1 * c10) / m |
| 332 |
# } |
|
| 333 |
} |
|
| 334 | ||
| 335 |
# compute scaled difference test |
|
| 336 | ! |
T.delta <- (T0 - T1) / cd |
| 337 | ||
| 338 | ! |
list( |
| 339 | ! |
T.delta = T.delta, scaling.factor = cd, df.delta = m, |
| 340 | ! |
T.delta.unscaled = (T0 - T1) |
| 341 |
) |
|
| 342 |
} |
|
| 343 | ||
| 344 |
# create a new model 'm10', where we use model 'm1', but we |
|
| 345 |
# inject it with the values of 'm0' |
|
| 346 |
lav_test_diff_m10 <- function(m1, m0, test = FALSE) {
|
|
| 347 |
# switch of verbose/se/test |
|
| 348 | ! |
Options <- m1@Options |
| 349 |
# switch of optim.gradient check |
|
| 350 | ! |
Options$check.gradient <- FALSE |
| 351 | ||
| 352 |
# should we compute se/test statistics? |
|
| 353 | ! |
if (!test) {
|
| 354 | ! |
Options$se <- "none" |
| 355 | ! |
Options$test <- "none" |
| 356 |
} |
|
| 357 | ||
| 358 | ! |
PT.M0 <- lav_partable_set_cache(m0@ParTable, m0@pta) |
| 359 | ! |
PT.M1 <- lav_partable_set_cache(m1@ParTable, m1@pta) |
| 360 | ||
| 361 |
# `extend' PT.M1 partable to include all `fixed-to-zero parameters' |
|
| 362 | ! |
PT.M1.FULL <- lav_partable_full( |
| 363 | ! |
partable = PT.M1, |
| 364 | ! |
free = TRUE, start = TRUE |
| 365 |
) |
|
| 366 | ! |
PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL, |
| 367 | ! |
remove.duplicated = TRUE, warn = FALSE |
| 368 |
) |
|
| 369 | ||
| 370 |
# remove most columns |
|
| 371 | ! |
PT.M1.extended$start <- NULL # new in 0.6-4! (otherwise, they are used) |
| 372 | ! |
PT.M1.extended$est <- NULL |
| 373 | ! |
PT.M1.extended$se <- NULL |
| 374 | ||
| 375 |
# in addition, use 'NA' for free parameters in ustart column |
|
| 376 | ! |
free.par.idx <- which(PT.M1.extended$free > 0L) |
| 377 | ! |
PT.M1.extended$ustart[free.par.idx] <- as.numeric(NA) |
| 378 | ||
| 379 |
# `extend' PT.M0 partable to include all `fixed-to-zero parameters' |
|
| 380 | ! |
PT.M0.FULL <- lav_partable_full( |
| 381 | ! |
partable = PT.M0, |
| 382 | ! |
free = TRUE, start = TRUE |
| 383 |
) |
|
| 384 | ! |
PT.M0.extended <- lav_partable_merge(PT.M0, PT.M0.FULL, |
| 385 | ! |
remove.duplicated = TRUE, warn = FALSE |
| 386 |
) |
|
| 387 |
# remove most columns, but not 'est' |
|
| 388 | ! |
PT.M0.extended$ustart <- NULL |
| 389 | ! |
PT.M0.extended$start <- NULL |
| 390 | ! |
PT.M0.extended$se <- NULL |
| 391 | ||
| 392 | ||
| 393 |
# FIXME: |
|
| 394 |
# - check if H0 does not contain additional parameters... |
|
| 395 | ||
| 396 | ! |
Options$optim.method <- "none" |
| 397 | ! |
Options$optim.force.converged <- TRUE |
| 398 | ! |
Options$baseline <- FALSE |
| 399 | ! |
Options$h1 <- TRUE # needed after all (yuan.benter.mplus) |
| 400 | ! |
Options$start <- PT.M0.extended # new in 0.6! |
| 401 | ! |
m10 <- lavaan( |
| 402 | ! |
model = PT.M1.extended, |
| 403 | ! |
slotOptions = Options, |
| 404 | ! |
slotSampleStats = m1@SampleStats, |
| 405 | ! |
slotData = m1@Data, |
| 406 | ! |
slotCache = m1@Cache, |
| 407 | ! |
verbose = FALSE |
| 408 |
) |
|
| 409 | ||
| 410 | ! |
m10 |
| 411 |
} |
|
| 412 | ||
| 413 |
# compute the `A' matrix: the jacobian of the constraint function a(\delta) |
|
| 414 |
# (see Satorra 2000) |
|
| 415 |
# |
|
| 416 |
# |
|
| 417 |
# |
|
| 418 |
lav_test_diff_A <- function(m1, m0, method = "delta", reference = "H1") {
|
|
| 419 |
# FIXME!!!! |
|
| 420 | ||
| 421 | ! |
if (method == "exact") {
|
| 422 | ! |
if (reference == "H1") {
|
| 423 | ! |
af <- lav_test_diff_af_h1(m1 = m1, m0 = m0) |
| 424 | ! |
xx <- m1@optim$x |
| 425 |
} else { # evaluate under H0
|
|
| 426 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 427 |
# af <- .test_compute_partable_A_diff_h0(m1 = m1, m0 = m0) |
|
| 428 | ! |
xx <- m0@optim$x |
| 429 |
} |
|
| 430 | ! |
A <- try(lav_func_jacobian_complex(func = af, x = xx), silent = TRUE) |
| 431 | ! |
if (inherits(A, "try-error")) {
|
| 432 | ! |
A <- lav_func_jacobian_simple(func = af, x = xx) |
| 433 |
} |
|
| 434 | ! |
} else if (method == "delta") {
|
| 435 |
# use a numeric approximation of `A' |
|
| 436 | ! |
Delta1.list <- lav_model_delta(m1@Model) |
| 437 | ! |
Delta0.list <- lav_model_delta(m0@Model) |
| 438 | ! |
Delta1 <- do.call(rbind, Delta1.list) |
| 439 | ! |
Delta0 <- do.call(rbind, Delta0.list) |
| 440 | ||
| 441 |
# take into account equality constraints m0 |
|
| 442 | ! |
if (m0@Model@eq.constraints) {
|
| 443 | ! |
Delta0 <- Delta0 %*% m0@Model@eq.constraints.K |
| 444 | ! |
} else if (m0@Model@ceq.simple.only) {
|
| 445 | ! |
Delta0 <- Delta0 %*% t(m0@Model@ceq.simple.K) |
| 446 |
} |
|
| 447 | ||
| 448 |
# take into account equality constraints m1 |
|
| 449 | ! |
if (m1@Model@eq.constraints) {
|
| 450 | ! |
Delta1 <- Delta1 %*% m1@Model@eq.constraints.K |
| 451 | ! |
} else if (m1@Model@ceq.simple.only) {
|
| 452 | ! |
Delta1 <- Delta1 %*% t(m1@Model@ceq.simple.K) |
| 453 |
} |
|
| 454 | ||
| 455 |
# H <- solve(t(Delta1) %*% Delta1) %*% t(Delta1) %*% Delta0 |
|
| 456 | ! |
H <- MASS::ginv(Delta1) %*% Delta0 |
| 457 | ! |
A <- t(lav_matrix_orthogonal_complement(H)) |
| 458 |
} |
|
| 459 | ||
| 460 | ! |
A |
| 461 |
} |
|
| 462 | ||
| 463 | ||
| 464 |
# for each parameter in H1 (m1), see if we have somehow constrained |
|
| 465 |
# this parameter under H0 (m0) |
|
| 466 |
# |
|
| 467 |
# since we work 'under H0', we need to use the labels/constraints/def |
|
| 468 |
# as they appear in H0. Unfortunately, the order of the parameters, and |
|
| 469 |
# even the (p)labels may be different in the two models... |
|
| 470 |
# |
|
| 471 |
# Therefore, we will attempt to: |
|
| 472 |
# - change the 'order' of the 'free' column in m0, so that they map to |
|
| 473 |
# to the 'x' that we will provide from H1 |
|
| 474 |
# - the plabels used in "==" constraints must be renamed, if necessary |
|
| 475 |
# |
|
| 476 |
lav_test_diff_af_h1 <- function(m1, m0) {
|
|
| 477 | ! |
PT.M0 <- lav_partable_set_cache(parTable(m0), m0@pta) |
| 478 | ! |
PT.M1 <- lav_partable_set_cache(parTable(m1), m1@pta) |
| 479 | ||
| 480 |
# select .p*. parameters only |
|
| 481 | ! |
M0.p.idx <- which(grepl("\\.p", PT.M0$plabel))
|
| 482 | ! |
np0 <- length(M0.p.idx) |
| 483 | ! |
M1.p.idx <- which(grepl("\\.p", PT.M1$plabel))
|
| 484 | ! |
np1 <- length(M1.p.idx) |
| 485 | ||
| 486 |
# check if parameter space is the same |
|
| 487 | ! |
if (np0 != np1) {
|
| 488 | ! |
lav_msg_stop(gettext( |
| 489 | ! |
"unconstrained parameter set is not the same in m0 and m1")) |
| 490 |
} |
|
| 491 | ||
| 492 |
# split partable in 'parameter' and 'constraints' section |
|
| 493 | ! |
PT.M0.part1 <- PT.M0[M0.p.idx, ] |
| 494 | ! |
PT.M0.part2 <- PT.M0[-M0.p.idx, ] |
| 495 | ||
| 496 | ! |
PT.M1.part1 <- PT.M1[M1.p.idx, ] |
| 497 | ! |
PT.M1.part2 <- PT.M1[-M1.p.idx, ] |
| 498 | ||
| 499 |
# figure out relationship between m0 and m1 |
|
| 500 | ! |
p1.id <- lav_partable_map_id_p1_in_p2(PT.M0.part1, PT.M1.part1) |
| 501 | ! |
p0.free.idx <- which(PT.M0.part1$free > 0) |
| 502 | ||
| 503 |
# change 'free' order in m0 |
|
| 504 |
# NOTE: this only works all the free parameters in h0 are also free |
|
| 505 |
# in h1 (and if not, they will become fixed in h0) |
|
| 506 | ! |
PT.M0.part1$free[p0.free.idx] <- |
| 507 | ! |
PT.M1.part1$free[PT.M0.part1$id[p1.id][p0.free.idx]] |
| 508 | ||
| 509 |
# paste back |
|
| 510 | ! |
PT.M0 <- rbind(PT.M0.part1, PT.M0.part2) |
| 511 | ! |
PT.M1 <- rbind(PT.M1.part1, PT.M1.part2) |
| 512 | ||
| 513 |
# `extend' PT.M1 partable to include all `fixed-to-zero parameters' |
|
| 514 | ! |
PT.M1.FULL <- lav_partable_full( |
| 515 | ! |
partable = PT.M1, |
| 516 | ! |
free = TRUE, start = TRUE |
| 517 |
) |
|
| 518 | ! |
PT.M1.extended <- lav_partable_merge(PT.M1, PT.M1.FULL, |
| 519 | ! |
remove.duplicated = TRUE, warn = FALSE |
| 520 |
) |
|
| 521 | ||
| 522 |
# `extend' PT.M0 partable to include all `fixed-to-zero parameters' |
|
| 523 | ! |
PT.M0.FULL <- lav_partable_full( |
| 524 | ! |
partable = PT.M0, |
| 525 | ! |
free = TRUE, start = TRUE |
| 526 |
) |
|
| 527 | ! |
PT.M0.extended <- lav_partable_merge(PT.M0, PT.M0.FULL, |
| 528 | ! |
remove.duplicated = TRUE, warn = FALSE |
| 529 |
) |
|
| 530 | ||
| 531 | ! |
p1 <- PT.M1.extended |
| 532 | ! |
np1 <- length(p1$lhs) |
| 533 | ! |
p0 <- PT.M0.extended |
| 534 | ! |
np0 <- length(p0$lhs) |
| 535 | ||
| 536 | ! |
con.function <- function() NULL |
| 537 | ! |
formals(con.function) <- alist(.x. = , ... = ) |
| 538 | ! |
BODY.txt <- paste("{\nout <- numeric(0L)\n", sep = "")
|
| 539 | ||
| 540 | ||
| 541 |
# first handle def + == constraints |
|
| 542 |
# but FIRST, remove == constraints that also appear in H1!!! |
|
| 543 | ||
| 544 |
# remove equivalent eq constraints from p0 |
|
| 545 | ! |
P0 <- p0 |
| 546 | ||
| 547 | ! |
p0.eq.idx <- which(p0$op == "==") |
| 548 | ! |
p1.eq.idx <- which(p1$op == "==") |
| 549 | ! |
p0.remove.idx <- integer(0L) |
| 550 | ! |
if (length(p0.eq.idx) > 0L) {
|
| 551 | ! |
for (i in seq_along(p0.eq.idx)) {
|
| 552 |
# e0 in p0 |
|
| 553 | ! |
e0 <- p0.eq.idx[i] |
| 554 | ! |
lhs <- p0$lhs[e0] |
| 555 | ! |
rhs <- p0$rhs[e0] |
| 556 | ||
| 557 |
# do we have an equivalent constraint in H1? |
|
| 558 |
# NOTE!! the (p)labels may differ |
|
| 559 | ||
| 560 |
# SO, we will use an 'empirical' approach: if we fill in (random) |
|
| 561 |
# values, and work out the constraint, do we get identical values? |
|
| 562 |
# if yes, constraint is equivalent, and we should NOT add it here |
|
| 563 | ||
| 564 | ! |
if (length(p1.eq.idx) > 0) {
|
| 565 |
# generate random parameter values |
|
| 566 | ! |
xx1 <- rnorm(length(M1.p.idx)) |
| 567 | ! |
xx0 <- xx1[p1.id] |
| 568 | ||
| 569 | ! |
con.h0.value <- m0@Model@ceq.function(xx0)[i] |
| 570 | ! |
con.h1.values <- m1@Model@ceq.function(xx1) |
| 571 | ||
| 572 | ! |
if (con.h0.value %in% con.h1.values) {
|
| 573 | ! |
p0.remove.idx <- c(p0.remove.idx, e0) |
| 574 |
} |
|
| 575 |
} |
|
| 576 |
} |
|
| 577 |
} |
|
| 578 | ! |
if (length(p0.remove.idx) > 0L) {
|
| 579 | ! |
P0 <- P0[-p0.remove.idx, ] |
| 580 |
} |
|
| 581 | ||
| 582 |
# only for the UNIQUE equality constraints in H0, generate syntax |
|
| 583 | ! |
DEFCON.txt <- lav_partable_constraints_ceq(P0, txtOnly = TRUE) |
| 584 | ! |
BODY.txt <- paste(BODY.txt, DEFCON.txt, "\n", sep = "") |
| 585 | ||
| 586 | ||
| 587 |
# for each parameter in p1, we 'check' is it is fixed to a constant in p0 |
|
| 588 | ! |
ncon <- length(which(P0$op == "==")) |
| 589 | ! |
for (i in seq_len(np1)) {
|
| 590 |
# p in p1 |
|
| 591 | ! |
lhs <- p1$lhs[i] |
| 592 | ! |
op <- p1$op[i] |
| 593 | ! |
rhs <- p1$rhs[i] |
| 594 | ! |
group <- p1$group[i] |
| 595 | ||
| 596 |
# ignore '==', '<', '>' and ':=' for now |
|
| 597 | ! |
if (op == "==" || op == ">" || op == "<" || op == ":=") next |
| 598 | ||
| 599 |
# search for corresponding parameter in p0 |
|
| 600 | ! |
p0.idx <- which(p0$lhs == lhs & p0$op == op & p0$rhs == rhs & |
| 601 | ! |
p0$group == group) |
| 602 | ! |
if (length(p0.idx) == 0L) {
|
| 603 | ! |
lav_msg_stop( |
| 604 | ! |
gettextf("parameter in H1 not found in H0: %s",
|
| 605 | ! |
paste(lhs, op, rhs, "(group = ", group, ")", sep = " ") |
| 606 |
)) |
|
| 607 |
} |
|
| 608 | ||
| 609 |
# 4 possibilities: p is free/fixed in p1, p is free/fixed in p0 |
|
| 610 | ! |
if (p1$free[i] == 0L) {
|
| 611 | ! |
if (p0$free[p0.idx] == 0L) {
|
| 612 |
# match, nothing to do |
|
| 613 |
} else {
|
|
| 614 | ! |
lav_msg_warn( |
| 615 | ! |
gettextf("fixed parameter in H1 is free in H0: %s",
|
| 616 | ! |
paste("\"", lhs, " ", op, " ", rhs,
|
| 617 | ! |
"\" (group = ", group, ")", |
| 618 | ! |
sep = "" |
| 619 |
) |
|
| 620 |
)) |
|
| 621 |
} |
|
| 622 |
} else {
|
|
| 623 | ! |
if (p0$free[p0.idx] == 0L) {
|
| 624 |
# match, this is a contrained parameter in H0 |
|
| 625 | ! |
ncon <- ncon + 1L |
| 626 | ! |
BODY.txt <- paste(BODY.txt, |
| 627 | ! |
"out[", ncon, "] = .x.[", p1$free[i], "] - ", |
| 628 | ! |
p0$ustart[p0.idx], "\n", |
| 629 | ! |
sep = "" |
| 630 |
) |
|
| 631 | ! |
next |
| 632 |
} else {
|
|
| 633 |
# match, nothing to do |
|
| 634 |
} |
|
| 635 |
} |
|
| 636 |
} |
|
| 637 | ||
| 638 | ||
| 639 |
# wrap function |
|
| 640 | ! |
BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "") |
| 641 | ! |
body(con.function) <- parse(file = "", text = BODY.txt) |
| 642 | ||
| 643 | ! |
con.function |
| 644 |
} |
| 1 |
# and matrix-representation specific functions: |
|
| 2 |
# - lav_model_sigma |
|
| 3 |
# - lav_model_mu |
|
| 4 |
# - derivative.F |
|
| 5 | ||
| 6 |
# initital version: YR 2011-01-21: LISREL stuff |
|
| 7 |
# updates: YR 2011-12-01: group specific extraction |
|
| 8 |
# YR 2012-05-17: thresholds |
|
| 9 |
# YR 2021-10-04: rename representation.LISREL -> lav_lisrel |
|
| 10 | ||
| 11 |
lav_lisrel <- function(lavpartable = NULL, |
|
| 12 |
target = NULL, |
|
| 13 |
extra = FALSE, |
|
| 14 |
allow.composites = TRUE, |
|
| 15 |
remove.nonexisting = TRUE) {
|
|
| 16 |
# prepare target list |
|
| 17 | 144x |
if (is.null(target)) target <- lavpartable |
| 18 | ||
| 19 | 144x |
stopifnot(!is.null(target$block)) |
| 20 | ||
| 21 |
# prepare output |
|
| 22 | 144x |
N <- length(target$lhs) |
| 23 | 144x |
tmp.mat <- character(N) |
| 24 | 144x |
tmp.row <- integer(N) |
| 25 | 144x |
tmp.col <- integer(N) |
| 26 | ||
| 27 |
# global settings |
|
| 28 | 144x |
meanstructure <- any(lavpartable$op == "~1") |
| 29 | 144x |
categorical <- any(lavpartable$op == "|") |
| 30 | 144x |
composites <- any(lavpartable$op == "<~") && allow.composites |
| 31 | 144x |
group.w.free <- any(lavpartable$lhs == "group" & lavpartable$op == "%") |
| 32 | ||
| 33 |
# gamma?only if conditional.x |
|
| 34 | 144x |
if (any(lavpartable$op %in% c("~", "<~") & lavpartable$exo == 1L) &&
|
| 35 | 144x |
!composites) {
|
| 36 | 4x |
gamma <- TRUE |
| 37 |
} else {
|
|
| 38 | 140x |
gamma <- FALSE |
| 39 |
} |
|
| 40 | ||
| 41 |
# number of blocks |
|
| 42 | 144x |
nblocks <- lav_partable_nblocks(lavpartable) |
| 43 | ||
| 44 |
# multilevel? |
|
| 45 | 144x |
nlevels <- lav_partable_nlevels(lavpartable) |
| 46 | 144x |
ngroups <- lav_partable_ngroups(lavpartable) |
| 47 | ||
| 48 | 144x |
ov.dummy.names.nox <- vector("list", nblocks)
|
| 49 | 144x |
ov.dummy.names.x <- vector("list", nblocks)
|
| 50 | 144x |
if (extra) {
|
| 51 | 144x |
REP.mmNames <- vector("list", nblocks)
|
| 52 | 144x |
REP.mmNumber <- vector("list", nblocks)
|
| 53 | 144x |
REP.mmRows <- vector("list", nblocks)
|
| 54 | 144x |
REP.mmCols <- vector("list", nblocks)
|
| 55 | 144x |
REP.mmDimNames <- vector("list", nblocks)
|
| 56 | 144x |
REP.mmSymmetric <- vector("list", nblocks)
|
| 57 |
} |
|
| 58 | ||
| 59 | 144x |
for (g in 1:nblocks) {
|
| 60 |
# info from user model per block |
|
| 61 | 161x |
if (gamma) {
|
| 62 | 4x |
ov.names <- lav_partable_vnames(lavpartable, "ov.nox", block = g) |
| 63 |
} else {
|
|
| 64 | 157x |
ov.names <- lav_partable_vnames(lavpartable, "ov", block = g) |
| 65 |
} |
|
| 66 | 161x |
nvar <- length(ov.names) |
| 67 | 161x |
lv.names <- lav_partable_vnames(lavpartable, "lv", block = g) |
| 68 | 161x |
nfac <- length(lv.names) |
| 69 | 161x |
ov.th <- lav_partable_vnames(lavpartable, "th", block = g) |
| 70 | 161x |
nth <- length(ov.th) |
| 71 | 161x |
ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g) |
| 72 | 161x |
nexo <- length(ov.names.x) |
| 73 | 161x |
ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g) |
| 74 | ||
| 75 |
# in this representation, we need to create 'phantom/dummy' latent |
|
| 76 |
# variables for all `x' and `y' variables not in lv.names |
|
| 77 |
# (only y if conditional.x = TRUE) |
|
| 78 | ||
| 79 |
# regression dummys |
|
| 80 | 161x |
if (gamma) {
|
| 81 | 4x |
tmp.names <- |
| 82 | 4x |
unique(lavpartable$lhs[(lavpartable$op == "~" | |
| 83 | 4x |
lavpartable$op == "<~") & |
| 84 | 4x |
lavpartable$block == g]) |
| 85 |
# new in 0.6-12: fix for multilevel + conditional.x: splitted ov.x |
|
| 86 |
# are removed from ov.x |
|
| 87 | 4x |
if (nlevels > 1L) {
|
| 88 | ! |
if (ngroups == 1L) {
|
| 89 | ! |
OTHER.BLOCK.NAMES <- lav_partable_vnames(lavpartable, "ov", |
| 90 | ! |
block = seq_len(nblocks)[-g] |
| 91 |
) |
|
| 92 |
} else {
|
|
| 93 |
# TEST ME |
|
| 94 | ! |
this.group <- ceiling(g / nlevels) |
| 95 | ! |
blocks.within.group <- (this.group - 1L) * nlevels + seq_len(nlevels) |
| 96 | ! |
OTHER.BLOCK.NAMES <- lav_partable_vnames(lavpartable, |
| 97 | ! |
"ov", |
| 98 | ! |
block = blocks.within.group[-g] |
| 99 |
) |
|
| 100 |
} |
|
| 101 | ! |
if (length(ov.names.x) > 0L) {
|
| 102 | ! |
idx <- which(ov.names.x %in% OTHER.BLOCK.NAMES) |
| 103 | ! |
if (length(idx) > 0L) {
|
| 104 | ! |
tmp.names <- unique(c(tmp.names, ov.names.x[idx])) |
| 105 | ! |
ov.names.nox <- unique(c(ov.names.nox, ov.names.x[idx])) |
| 106 | ! |
ov.names.x <- ov.names.x[-idx] |
| 107 | ! |
nexo <- length(ov.names.x) |
| 108 | ! |
ov.names <- ov.names.nox |
| 109 | ! |
nvar <- length(ov.names) |
| 110 |
} |
|
| 111 |
} |
|
| 112 |
} |
|
| 113 |
} else {
|
|
| 114 | 157x |
if (composites) {
|
| 115 | ! |
tmp.names <- |
| 116 | ! |
unique(c( |
| 117 | ! |
lavpartable$lhs[(lavpartable$op == "~") & |
| 118 | ! |
lavpartable$block == g], |
| 119 | ! |
lavpartable$rhs[(lavpartable$op == "~") & |
| 120 | ! |
lavpartable$block == g] |
| 121 |
)) |
|
| 122 |
} else {
|
|
| 123 |
# old behavior < 0.6-20 |
|
| 124 | 157x |
tmp.names <- |
| 125 | 157x |
unique(c( |
| 126 | 157x |
lavpartable$lhs[(lavpartable$op == "~" | |
| 127 | 157x |
lavpartable$op == "<~") & |
| 128 | 157x |
lavpartable$block == g], |
| 129 | 157x |
lavpartable$rhs[(lavpartable$op == "~" | |
| 130 | 157x |
lavpartable$op == "<~") & |
| 131 | 157x |
lavpartable$block == g] |
| 132 |
)) |
|
| 133 |
} |
|
| 134 |
} |
|
| 135 | 161x |
dummy.names1 <- tmp.names[!tmp.names %in% lv.names] |
| 136 |
# covariances involving dummys |
|
| 137 | 161x |
dummy.cov.idx <- which(lavpartable$op == "~~" & lavpartable$block == g & |
| 138 | 161x |
(lavpartable$lhs %in% dummy.names1 | |
| 139 | 161x |
lavpartable$rhs %in% dummy.names1)) |
| 140 |
# new in 0.5-21: also include covariances involving these covariances... |
|
| 141 | 161x |
dummy.cov.idx1 <- which(lavpartable$op == "~~" & lavpartable$block == g & |
| 142 | 161x |
(lavpartable$lhs %in% lavpartable$lhs[dummy.cov.idx] | |
| 143 | 161x |
lavpartable$rhs %in% lavpartable$rhs[dummy.cov.idx])) |
| 144 | 161x |
dummy.cov.idx <- unique(c(dummy.cov.idx, dummy.cov.idx1)) |
| 145 | ||
| 146 | 161x |
dummy.names2 <- unique(c( |
| 147 | 161x |
lavpartable$lhs[dummy.cov.idx], |
| 148 | 161x |
lavpartable$rhs[dummy.cov.idx] |
| 149 |
)) |
|
| 150 | ||
| 151 | ||
| 152 |
# new in 0.6-7: ~~ between latent and observed |
|
| 153 | 161x |
dummy.cov.ov.lv.idx1 <- which(lavpartable$op == "~~" & |
| 154 | 161x |
lavpartable$block == g & |
| 155 | 161x |
lavpartable$lhs %in% ov.names & |
| 156 | 161x |
lavpartable$rhs %in% lv.names) |
| 157 | 161x |
dummy.cov.ov.lv.idx2 <- which(lavpartable$op == "~~" & |
| 158 | 161x |
lavpartable$block == g & |
| 159 | 161x |
lavpartable$lhs %in% lv.names & |
| 160 | 161x |
lavpartable$rhs %in% ov.names) |
| 161 | 161x |
dummy.names3 <- unique(c( |
| 162 | 161x |
lavpartable$lhs[dummy.cov.ov.lv.idx1], |
| 163 | 161x |
lavpartable$rhs[dummy.cov.ov.lv.idx2] |
| 164 |
)) |
|
| 165 | ||
| 166 |
# new in 0.6-10: ~~ between observed and observed, but not in ~ |
|
| 167 | 161x |
dummy.orphan.idx <- which(lavpartable$op == "~~" & |
| 168 | 161x |
lavpartable$block == g & |
| 169 | 161x |
lavpartable$lhs %in% ov.names & |
| 170 | 161x |
lavpartable$rhs %in% ov.names & |
| 171 | 161x |
(!lavpartable$lhs %in% c( |
| 172 | 161x |
dummy.names1, |
| 173 | 161x |
dummy.names2 |
| 174 |
) | |
|
| 175 | 161x |
!lavpartable$rhs %in% c( |
| 176 | 161x |
dummy.names1, |
| 177 | 161x |
dummy.names2 |
| 178 |
))) |
|
| 179 | ||
| 180 |
# collect all dummy variables |
|
| 181 | 161x |
dummy.names <- unique(c(dummy.names1, dummy.names2, dummy.names3)) |
| 182 | ||
| 183 | ||
| 184 | 161x |
if (length(dummy.names)) {
|
| 185 |
# make sure order is the same as ov.names |
|
| 186 | 38x |
ov.dummy.names.nox[[g]] <- |
| 187 | 38x |
ov.names.nox[ov.names.nox %in% dummy.names] |
| 188 | 38x |
ov.dummy.names.x[[g]] <- |
| 189 | 38x |
ov.names.x[ov.names.x %in% dummy.names] |
| 190 | ||
| 191 |
# combine them, make sure order is identical to ov.names |
|
| 192 | 38x |
tmp <- ov.names[ov.names %in% dummy.names] |
| 193 | ||
| 194 |
# same for ov.names.x (if they are not in ov.names) (conditional.x) |
|
| 195 | 38x |
if (length(ov.names.x) > 0L) {
|
| 196 | 28x |
tmp.x <- ov.names.x[ov.names.x %in% dummy.names] |
| 197 | 28x |
tmp <- unique(c(tmp, tmp.x)) |
| 198 |
} |
|
| 199 | ||
| 200 |
# extend lv.names |
|
| 201 | 38x |
lv.names <- c(lv.names, tmp) |
| 202 | 38x |
nfac <- length(lv.names) |
| 203 | ||
| 204 |
# add 'dummy' =~ entries |
|
| 205 | 38x |
dummy.mat <- rep("lambda", length(dummy.names))
|
| 206 |
} else {
|
|
| 207 | 123x |
ov.dummy.names.nox[[g]] <- character(0) |
| 208 | 123x |
ov.dummy.names.x[[g]] <- character(0) |
| 209 |
} |
|
| 210 | ||
| 211 |
# 1a. "=~" regular indicators |
|
| 212 | 161x |
idx <- which(target$block == g & |
| 213 | 161x |
target$op == "=~" & !(target$rhs %in% lv.names)) |
| 214 | 161x |
tmp.mat[idx] <- "lambda" |
| 215 | 161x |
tmp.row[idx] <- match(target$rhs[idx], ov.names) |
| 216 | 161x |
tmp.col[idx] <- match(target$lhs[idx], lv.names) |
| 217 | ||
| 218 |
# 1b. "=~" regular higher-order lv indicators |
|
| 219 | 161x |
idx <- which(target$block == g & |
| 220 | 161x |
target$op == "=~" & !(target$rhs %in% ov.names)) |
| 221 | 161x |
tmp.mat[idx] <- "beta" |
| 222 | 161x |
tmp.row[idx] <- match(target$rhs[idx], lv.names) |
| 223 | 161x |
tmp.col[idx] <- match(target$lhs[idx], lv.names) |
| 224 | ||
| 225 |
# 1c. "=~" indicators that are both in ov and lv |
|
| 226 | 161x |
idx <- which(target$block == g & |
| 227 | 161x |
target$op == "=~" & target$rhs %in% ov.names & |
| 228 | 161x |
target$rhs %in% lv.names) |
| 229 | 161x |
tmp.mat[idx] <- "beta" |
| 230 | 161x |
tmp.row[idx] <- match(target$rhs[idx], lv.names) |
| 231 | 161x |
tmp.col[idx] <- match(target$lhs[idx], lv.names) |
| 232 | ||
| 233 |
# 1d. "<~" indicators |
|
| 234 | 161x |
if (composites) {
|
| 235 | ! |
idx <- which(target$block == g & |
| 236 | ! |
target$op == "<~" & !(target$rhs %in% lv.names)) |
| 237 | ! |
tmp.mat[idx] <- "wmat" |
| 238 | ! |
tmp.row[idx] <- match(target$rhs[idx], ov.names) |
| 239 | ! |
tmp.col[idx] <- match(target$lhs[idx], lv.names) |
| 240 |
} |
|
| 241 | ||
| 242 |
# 2. "~" regressions |
|
| 243 | 161x |
if (gamma) {
|
| 244 |
# gamma |
|
| 245 | 4x |
if (composites) {
|
| 246 | ! |
idx <- which(target$rhs %in% ov.names.x & |
| 247 | ! |
target$block == g & target$op == "~") |
| 248 |
} else {
|
|
| 249 | 4x |
idx <- which(target$rhs %in% ov.names.x & |
| 250 | 4x |
target$block == g & (target$op == "~" | |
| 251 | 4x |
target$op == "<~")) |
| 252 |
} |
|
| 253 | 4x |
tmp.mat[idx] <- "gamma" |
| 254 | 4x |
tmp.row[idx] <- match(target$lhs[idx], lv.names) |
| 255 | 4x |
tmp.col[idx] <- match(target$rhs[idx], ov.names.x) |
| 256 | ||
| 257 |
# beta |
|
| 258 | 4x |
if (composites) {
|
| 259 | ! |
idx <- which(!target$rhs %in% ov.names.x & |
| 260 | ! |
target$block == g & target$op == "~") |
| 261 |
} else {
|
|
| 262 | 4x |
idx <- which(!target$rhs %in% ov.names.x & |
| 263 | 4x |
target$block == g & (target$op == "~" | |
| 264 | 4x |
target$op == "<~")) |
| 265 |
} |
|
| 266 | 4x |
tmp.mat[idx] <- "beta" |
| 267 | 4x |
tmp.row[idx] <- match(target$lhs[idx], lv.names) |
| 268 | 4x |
tmp.col[idx] <- match(target$rhs[idx], lv.names) |
| 269 |
} else {
|
|
| 270 | 157x |
if (composites) {
|
| 271 | ! |
idx <- which(target$block == g & target$op == "~") |
| 272 |
} else {
|
|
| 273 | 157x |
idx <- which(target$block == g & (target$op == "~" | |
| 274 | 157x |
target$op == "<~")) |
| 275 |
} |
|
| 276 | 157x |
tmp.mat[idx] <- "beta" |
| 277 | 157x |
tmp.row[idx] <- match(target$lhs[idx], lv.names) |
| 278 | 157x |
tmp.col[idx] <- match(target$rhs[idx], lv.names) |
| 279 |
} |
|
| 280 | ||
| 281 |
# 3a. "~~" ov |
|
| 282 | 161x |
idx <- which(target$block == g & |
| 283 | 161x |
target$op == "~~" & !(target$lhs %in% lv.names)) |
| 284 | 161x |
tmp.mat[idx] <- "theta" |
| 285 | 161x |
tmp.row[idx] <- match(target$lhs[idx], ov.names) |
| 286 | 161x |
tmp.col[idx] <- match(target$rhs[idx], ov.names) |
| 287 | ||
| 288 |
# 3aa. "~~" ov.x |
|
| 289 | 161x |
if (gamma) {
|
| 290 | 4x |
idx <- which(target$block == g & |
| 291 | 4x |
target$op == "~~" & (target$lhs %in% ov.names.x)) |
| 292 | 4x |
tmp.mat[idx] <- "cov.x" |
| 293 | 4x |
tmp.row[idx] <- match(target$lhs[idx], ov.names.x) |
| 294 | 4x |
tmp.col[idx] <- match(target$rhs[idx], ov.names.x) |
| 295 |
} |
|
| 296 | ||
| 297 |
# 3b. "~~" lv |
|
| 298 | 161x |
idx <- which(target$block == g & |
| 299 | 161x |
target$op == "~~" & target$rhs %in% lv.names) |
| 300 | 161x |
tmp.mat[idx] <- "psi" |
| 301 | 161x |
tmp.row[idx] <- match(target$lhs[idx], lv.names) |
| 302 | 161x |
tmp.col[idx] <- match(target$rhs[idx], lv.names) |
| 303 | ||
| 304 |
# 4a. "~1" ov |
|
| 305 | 161x |
idx <- which(target$block == g & |
| 306 | 161x |
target$op == "~1" & !(target$lhs %in% lv.names)) |
| 307 | 161x |
tmp.mat[idx] <- "nu" |
| 308 | 161x |
tmp.row[idx] <- match(target$lhs[idx], ov.names) |
| 309 | 161x |
tmp.col[idx] <- 1L |
| 310 | ||
| 311 |
# 4aa, "~1" ov.x |
|
| 312 | 161x |
if (gamma) {
|
| 313 | 4x |
idx <- which(target$block == g & |
| 314 | 4x |
target$op == "~1" & (target$lhs %in% ov.names.x)) |
| 315 | 4x |
tmp.mat[idx] <- "mean.x" |
| 316 | 4x |
tmp.row[idx] <- match(target$lhs[idx], ov.names.x) |
| 317 | 4x |
tmp.col[idx] <- 1L |
| 318 |
} |
|
| 319 | ||
| 320 |
# 4b. "~1" lv |
|
| 321 | 161x |
idx <- which(target$block == g & |
| 322 | 161x |
target$op == "~1" & target$lhs %in% lv.names) |
| 323 | 161x |
tmp.mat[idx] <- "alpha" |
| 324 | 161x |
tmp.row[idx] <- match(target$lhs[idx], lv.names) |
| 325 | 161x |
tmp.col[idx] <- 1L |
| 326 | ||
| 327 |
# 5. "|" th |
|
| 328 | 161x |
LABEL <- paste(target$lhs, target$op, target$rhs, sep = "") |
| 329 | 161x |
idx <- which(target$block == g & |
| 330 | 161x |
target$op == "|" & LABEL %in% ov.th) |
| 331 | 161x |
TH <- paste(target$lhs[idx], "|", target$rhs[idx], sep = "") |
| 332 | 161x |
tmp.mat[idx] <- "tau" |
| 333 | 161x |
tmp.row[idx] <- match(TH, ov.th) |
| 334 | 161x |
tmp.col[idx] <- 1L |
| 335 | ||
| 336 |
# 6. "~*~" scales |
|
| 337 | 161x |
idx <- which(target$block == g & |
| 338 | 161x |
target$op == "~*~") |
| 339 | 161x |
tmp.mat[idx] <- "delta" |
| 340 | 161x |
tmp.row[idx] <- match(target$lhs[idx], ov.names) |
| 341 | 161x |
tmp.col[idx] <- 1L |
| 342 | ||
| 343 |
# new 0.5-12: catch lower-elements in theta/psi |
|
| 344 | 161x |
idx.lower <- which(tmp.mat %in% c("theta", "psi") & tmp.row > tmp.col)
|
| 345 | 161x |
if (length(idx.lower) > 0L) {
|
| 346 | ! |
tmp <- tmp.row[idx.lower] |
| 347 | ! |
tmp.row[idx.lower] <- tmp.col[idx.lower] |
| 348 | ! |
tmp.col[idx.lower] <- tmp |
| 349 |
} |
|
| 350 | ||
| 351 |
# new 0.5-16: group weights |
|
| 352 | 161x |
idx <- which(target$block == g & target$lhs == "group" & |
| 353 | 161x |
target$op == "%") |
| 354 | 161x |
tmp.mat[idx] <- "gw" |
| 355 | 161x |
tmp.row[idx] <- 1L |
| 356 | 161x |
tmp.col[idx] <- 1L |
| 357 | ||
| 358 | 161x |
if (extra) {
|
| 359 |
# mRows |
|
| 360 | 161x |
mmRows <- list( |
| 361 | 161x |
tau = nth, |
| 362 | 161x |
delta = nvar, |
| 363 | 161x |
nu = nvar, |
| 364 | 161x |
lambda = nvar, |
| 365 | 161x |
wmat = nvar, |
| 366 | 161x |
theta = nvar, |
| 367 | 161x |
alpha = nfac, |
| 368 | 161x |
beta = nfac, |
| 369 | 161x |
gamma = nfac, |
| 370 | 161x |
cov.x = nexo, |
| 371 | 161x |
mean.x = nexo, |
| 372 | 161x |
gw = 1L, |
| 373 | 161x |
psi = nfac |
| 374 |
) |
|
| 375 | ||
| 376 |
# mCols |
|
| 377 | 161x |
mmCols <- list( |
| 378 | 161x |
tau = 1L, |
| 379 | 161x |
delta = 1L, |
| 380 | 161x |
nu = 1L, |
| 381 | 161x |
lambda = nfac, |
| 382 | 161x |
wmat = nfac, |
| 383 | 161x |
theta = nvar, |
| 384 | 161x |
alpha = 1L, |
| 385 | 161x |
beta = nfac, |
| 386 | 161x |
gamma = nexo, |
| 387 | 161x |
cov.x = nexo, |
| 388 | 161x |
mean.x = 1L, |
| 389 | 161x |
gw = 1L, |
| 390 | 161x |
psi = nfac |
| 391 |
) |
|
| 392 | ||
| 393 |
# dimNames for LISREL model matrices |
|
| 394 | 161x |
mmDimNames <- list( |
| 395 | 161x |
tau = list(ov.th, "threshold"), |
| 396 | 161x |
delta = list(ov.names, "scales"), |
| 397 | 161x |
nu = list(ov.names, "intercept"), |
| 398 | 161x |
lambda = list(ov.names, lv.names), |
| 399 | 161x |
wmat = list(ov.names, lv.names), |
| 400 | 161x |
theta = list(ov.names, ov.names), |
| 401 | 161x |
alpha = list(lv.names, "intercept"), |
| 402 | 161x |
beta = list(lv.names, lv.names), |
| 403 | 161x |
gamma = list(lv.names, ov.names.x), |
| 404 | 161x |
cov.x = list(ov.names.x, ov.names.x), |
| 405 | 161x |
mean.x = list(ov.names.x, "intercepts"), |
| 406 | 161x |
gw = list("group", "weight"),
|
| 407 | 161x |
psi = list(lv.names, lv.names) |
| 408 |
) |
|
| 409 | ||
| 410 |
# isSymmetric |
|
| 411 | 161x |
mmSymmetric <- list( |
| 412 | 161x |
tau = FALSE, |
| 413 | 161x |
delta = FALSE, |
| 414 | 161x |
nu = FALSE, |
| 415 | 161x |
lambda = FALSE, |
| 416 | 161x |
wmat = FALSE, |
| 417 | 161x |
theta = TRUE, |
| 418 | 161x |
alpha = FALSE, |
| 419 | 161x |
beta = FALSE, |
| 420 | 161x |
gamma = FALSE, |
| 421 | 161x |
cov.x = TRUE, |
| 422 | 161x |
mean.x = FALSE, |
| 423 | 161x |
gw = FALSE, |
| 424 | 161x |
psi = TRUE |
| 425 |
) |
|
| 426 | ||
| 427 |
# which mm's do we need? (always include lambda, theta and psi) |
|
| 428 |
# new: 0.6 this block only!! |
|
| 429 | 161x |
IDX <- which(target$block == g) |
| 430 | 161x |
if ("wmat" %in% tmp.mat[IDX]) {
|
| 431 | ! |
mmNames <- c("lambda", "wmat", "theta", "psi")
|
| 432 |
} else {
|
|
| 433 | 161x |
mmNames <- c("lambda", "theta", "psi")
|
| 434 |
} |
|
| 435 | ||
| 436 | 161x |
if ("beta" %in% tmp.mat[IDX]) {
|
| 437 | 48x |
mmNames <- c(mmNames, "beta") |
| 438 |
} |
|
| 439 | 161x |
if (meanstructure) {
|
| 440 | 110x |
mmNames <- c(mmNames, "nu", "alpha") |
| 441 |
} |
|
| 442 | 161x |
if ("tau" %in% tmp.mat[IDX]) {
|
| 443 | 4x |
mmNames <- c(mmNames, "tau") |
| 444 |
} |
|
| 445 | 161x |
if ("delta" %in% tmp.mat[IDX]) {
|
| 446 | 4x |
mmNames <- c(mmNames, "delta") |
| 447 |
} |
|
| 448 | 161x |
if ("gamma" %in% tmp.mat[IDX]) {
|
| 449 | 4x |
mmNames <- c(mmNames, "gamma") |
| 450 |
} |
|
| 451 | 161x |
if ("gw" %in% tmp.mat[IDX]) {
|
| 452 | ! |
mmNames <- c(mmNames, "gw") |
| 453 |
} |
|
| 454 | 161x |
if ("cov.x" %in% tmp.mat[IDX]) {
|
| 455 | 4x |
mmNames <- c(mmNames, "cov.x") |
| 456 |
} |
|
| 457 | 161x |
if ("mean.x" %in% tmp.mat[IDX]) {
|
| 458 | 4x |
mmNames <- c(mmNames, "mean.x") |
| 459 |
} |
|
| 460 | ||
| 461 | 161x |
REP.mmNames[[g]] <- mmNames |
| 462 | 161x |
REP.mmNumber[[g]] <- length(mmNames) |
| 463 | 161x |
REP.mmRows[[g]] <- unlist(mmRows[mmNames]) |
| 464 | 161x |
REP.mmCols[[g]] <- unlist(mmCols[mmNames]) |
| 465 | 161x |
REP.mmDimNames[[g]] <- mmDimNames[mmNames] |
| 466 | 161x |
REP.mmSymmetric[[g]] <- unlist(mmSymmetric[mmNames]) |
| 467 |
} # extra |
|
| 468 |
} # nblocks |
|
| 469 | ||
| 470 | 144x |
REP <- list( |
| 471 | 144x |
mat = tmp.mat, |
| 472 | 144x |
row = tmp.row, |
| 473 | 144x |
col = tmp.col |
| 474 |
) |
|
| 475 | ||
| 476 |
# remove non-existing (NAs)? |
|
| 477 |
# here we remove `non-existing' parameters; this depends on the matrix |
|
| 478 |
# representation (eg in LISREL rep, there is no ~~ between lv and ov) |
|
| 479 |
# if(remove.nonexisting) {
|
|
| 480 |
# idx <- which( nchar(REP$mat) > 0L & |
|
| 481 |
# !is.na(REP$row) & REP$row > 0L & |
|
| 482 |
# !is.na(REP$col) & REP$col > 0L ) |
|
| 483 |
# # but keep ==, :=, etc. |
|
| 484 |
# idx <- c(idx, which(lavpartable$op %in% c("==", ":=", "<", ">")))
|
|
| 485 |
# REP$mat <- REP$mat[idx] |
|
| 486 |
# REP$row <- REP$row[idx] |
|
| 487 |
# REP$col <- REP$col[idx] |
|
| 488 |
# |
|
| 489 | ||
| 490 |
# always add 'ov.dummy.*.names' attributes |
|
| 491 | 144x |
attr(REP, "ov.dummy.names.nox") <- ov.dummy.names.nox |
| 492 | 144x |
attr(REP, "ov.dummy.names.x") <- ov.dummy.names.x |
| 493 | ||
| 494 | 144x |
if (extra) {
|
| 495 | 144x |
attr(REP, "mmNames") <- REP.mmNames |
| 496 | 144x |
attr(REP, "mmNumber") <- REP.mmNumber |
| 497 | 144x |
attr(REP, "mmRows") <- REP.mmRows |
| 498 | 144x |
attr(REP, "mmCols") <- REP.mmCols |
| 499 | 144x |
attr(REP, "mmDimNames") <- REP.mmDimNames |
| 500 | 144x |
attr(REP, "mmSymmetric") <- REP.mmSymmetric |
| 501 |
} |
|
| 502 | ||
| 503 | 144x |
REP |
| 504 |
} |
|
| 505 | ||
| 506 | ||
| 507 |
# ETA: |
|
| 508 |
# 1) EETA |
|
| 509 |
# 2) EETAx |
|
| 510 |
# 3) VETA |
|
| 511 |
# 4) VETAx |
|
| 512 | ||
| 513 |
# 1) EETA |
|
| 514 |
# compute E(ETA): expected value of latent variables (marginal over x) |
|
| 515 |
# - if no eXo (and GAMMA): |
|
| 516 |
# E(ETA) = (I-B)^-1 ALPHA |
|
| 517 |
# - if eXo and GAMMA: |
|
| 518 |
# E(ETA) = (I-B)^-1 ALPHA + (I-B)^-1 GAMMA mean.x |
|
| 519 |
lav_lisrel_eeta <- function(MLIST = NULL, mean.x = NULL, |
|
| 520 |
sample.mean = NULL, |
|
| 521 |
ov.y.dummy.ov.idx = NULL, |
|
| 522 |
ov.x.dummy.ov.idx = NULL, |
|
| 523 |
ov.y.dummy.lv.idx = NULL, |
|
| 524 |
ov.x.dummy.lv.idx = NULL) {
|
|
| 525 | 128x |
BETA <- MLIST$beta |
| 526 | 128x |
GAMMA <- MLIST$gamma |
| 527 | ||
| 528 |
# ALPHA? (reconstruct, but no 'fix') |
|
| 529 | 128x |
ALPHA <- lav_lisrel_alpha0( |
| 530 | 128x |
MLIST = MLIST, sample.mean = sample.mean, |
| 531 | 128x |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 532 | 128x |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 533 | 128x |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 534 | 128x |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 535 |
) |
|
| 536 | ||
| 537 |
# BETA? |
|
| 538 | 128x |
if (!is.null(BETA)) {
|
| 539 | 34x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 540 |
# GAMMA? |
|
| 541 | 34x |
if (!is.null(GAMMA)) {
|
| 542 | 1x |
eeta <- as.vector(IB.inv %*% ALPHA + IB.inv %*% GAMMA %*% mean.x) |
| 543 |
} else {
|
|
| 544 | 33x |
eeta <- as.vector(IB.inv %*% ALPHA) |
| 545 |
} |
|
| 546 |
} else {
|
|
| 547 |
# GAMMA? |
|
| 548 | 94x |
if (!is.null(GAMMA)) {
|
| 549 | ! |
eeta <- as.vector(ALPHA + GAMMA %*% mean.x) |
| 550 |
} else {
|
|
| 551 | 94x |
eeta <- as.vector(ALPHA) |
| 552 |
} |
|
| 553 |
} |
|
| 554 | ||
| 555 | 128x |
eeta |
| 556 |
} |
|
| 557 | ||
| 558 |
# 2) EETAx |
|
| 559 |
# compute E(ETA|x_i): conditional expected value of latent variable, |
|
| 560 |
# given specific value of x_i |
|
| 561 |
# - if no eXo (and GAMMA): |
|
| 562 |
# E(ETA) = (I-B)^-1 ALPHA |
|
| 563 |
# we return a matrix of size [nobs x nfac] replicating E(ETA) |
|
| 564 |
# - if eXo and GAMMA: |
|
| 565 |
# E(ETA|x_i) = (I-B)^-1 ALPHA + (I-B)^-1 GAMMA x_i |
|
| 566 |
# we return a matrix of size [nobs x nfac] |
|
| 567 |
# |
|
| 568 |
lav_lisrel_eetax <- function(MLIST = NULL, eXo = NULL, N = nrow(eXo), |
|
| 569 |
sample.mean = NULL, |
|
| 570 |
ov.y.dummy.ov.idx = NULL, |
|
| 571 |
ov.x.dummy.ov.idx = NULL, |
|
| 572 |
ov.y.dummy.lv.idx = NULL, |
|
| 573 |
ov.x.dummy.lv.idx = NULL) {
|
|
| 574 | ! |
LAMBDA <- MLIST$lambda |
| 575 | ! |
BETA <- MLIST$beta |
| 576 | ! |
GAMMA <- MLIST$gamma |
| 577 | ! |
nfac <- ncol(LAMBDA) |
| 578 |
# if eXo, N must be nrow(eXo) |
|
| 579 | ! |
if (!is.null(eXo)) {
|
| 580 | ! |
N <- nrow(eXo) |
| 581 |
} |
|
| 582 | ||
| 583 |
# ALPHA? |
|
| 584 | ! |
ALPHA <- lav_lisrel_alpha0( |
| 585 | ! |
MLIST = MLIST, sample.mean = sample.mean, |
| 586 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 587 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 588 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 589 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 590 |
) |
|
| 591 | ||
| 592 |
# construct [nobs x nfac] matrix (repeating ALPHA) |
|
| 593 | ! |
EETA <- matrix(ALPHA, N, nfac, byrow = TRUE) |
| 594 | ||
| 595 |
# put back eXo values if dummy |
|
| 596 | ! |
if (length(ov.x.dummy.lv.idx) > 0L) {
|
| 597 | ! |
EETA[, ov.x.dummy.lv.idx] <- eXo |
| 598 |
} |
|
| 599 | ||
| 600 |
# BETA? |
|
| 601 | ! |
if (!is.null(BETA)) {
|
| 602 | ! |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 603 | ! |
EETA <- EETA %*% t(IB.inv) |
| 604 |
} |
|
| 605 | ||
| 606 |
# GAMMA? |
|
| 607 | ! |
if (!is.null(GAMMA)) {
|
| 608 | ! |
if (!is.null(BETA)) {
|
| 609 | ! |
EETA <- EETA + eXo %*% t(IB.inv %*% GAMMA) |
| 610 |
} else {
|
|
| 611 | ! |
EETA <- EETA + eXo %*% t(GAMMA) |
| 612 |
} |
|
| 613 |
} |
|
| 614 | ||
| 615 | ! |
EETA |
| 616 |
} |
|
| 617 | ||
| 618 |
# 3) VETA |
|
| 619 |
# compute V(ETA): variances/covariances of latent variables |
|
| 620 |
# - if no eXo (and GAMMA) |
|
| 621 |
# V(ETA) = (I-B)^-1 PSI (I-B)^-T |
|
| 622 |
# - if eXo and GAMMA: (cfr lisrel submodel 3a with ksi=x) |
|
| 623 |
# V(ETA) = (I-B)^-1 [ GAMMA cov.x t(GAMMA) + PSI] (I-B)^-T |
|
| 624 |
lav_lisrel_veta <- function(MLIST = NULL) {
|
|
| 625 | 4579x |
LAMBDA <- MLIST$lambda |
| 626 | 4579x |
nvar <- nrow(LAMBDA) |
| 627 | 4579x |
PSI <- MLIST$psi |
| 628 | 4579x |
THETA <- MLIST$theta |
| 629 | 4579x |
BETA <- MLIST$beta |
| 630 | 4579x |
GAMMA <- MLIST$gamma |
| 631 | ||
| 632 | 4579x |
if (!is.null(GAMMA)) {
|
| 633 | 222x |
COV.X <- MLIST$cov.x |
| 634 |
# we treat 'x' as 'ksi' in the LISREL model; cov.x is PHI |
|
| 635 | 222x |
PSI <- tcrossprod(GAMMA %*% COV.X, GAMMA) + PSI |
| 636 |
} |
|
| 637 | ||
| 638 |
# beta? |
|
| 639 | 4579x |
if (is.null(BETA)) {
|
| 640 | 2817x |
VETA <- PSI |
| 641 |
} else {
|
|
| 642 | 1762x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 643 | 1762x |
VETA <- tcrossprod(IB.inv %*% PSI, IB.inv) |
| 644 |
} |
|
| 645 | ||
| 646 | 4579x |
VETA |
| 647 |
} |
|
| 648 | ||
| 649 |
# 4) VETAx |
|
| 650 |
# compute V(ETA|x_i): variances/covariances of latent variables |
|
| 651 |
# V(ETA) = (I-B)^-1 PSI (I-B)^-T + remove dummies |
|
| 652 |
lav_lisrel_vetax <- function(MLIST = NULL, lv.dummy.idx = NULL) {
|
|
| 653 | ! |
PSI <- MLIST$psi |
| 654 | ! |
BETA <- MLIST$beta |
| 655 | ||
| 656 |
# beta? |
|
| 657 | ! |
if (is.null(BETA)) {
|
| 658 | ! |
VETA <- PSI |
| 659 |
} else {
|
|
| 660 | ! |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 661 | ! |
VETA <- tcrossprod(IB.inv %*% PSI, IB.inv) |
| 662 |
} |
|
| 663 | ||
| 664 |
# remove dummy lv? |
|
| 665 | ! |
if (!is.null(lv.dummy.idx)) {
|
| 666 | ! |
VETA <- VETA[-lv.dummy.idx, -lv.dummy.idx, drop = FALSE] |
| 667 |
} |
|
| 668 | ||
| 669 | ! |
VETA |
| 670 |
} |
|
| 671 | ||
| 672 | ||
| 673 | ||
| 674 |
# Y |
|
| 675 |
# 1) EY |
|
| 676 |
# 2) EYx |
|
| 677 |
# 3) EYetax |
|
| 678 |
# 4) VY |
|
| 679 |
# 5) VYx |
|
| 680 |
# 6) VYetax |
|
| 681 | ||
| 682 |
# 1) EY |
|
| 683 |
# compute E(Y): expected value of observed |
|
| 684 |
# E(Y) = NU + LAMBDA %*% E(eta) |
|
| 685 |
# = NU + LAMBDA %*% (IB.inv %*% ALPHA) # no exo, no GAMMA |
|
| 686 |
# = NU + LAMBDA %*% (IB.inv %*% ALPHA + IB.inv %*% GAMMA %*% mean.x) # eXo |
|
| 687 |
# if DELTA -> E(Y) = delta * E(Y) |
|
| 688 |
# |
|
| 689 |
# this is similar to lav_model_mu but: |
|
| 690 |
# - we ALWAYS compute NU+ALPHA, even if meanstructure=FALSE |
|
| 691 |
# - never used if GAMMA, since we then have categorical variables, and the |
|
| 692 |
# 'part 1' structure contains the (thresholds +) intercepts, not |
|
| 693 |
# the means |
|
| 694 |
lav_lisrel_ey <- function(MLIST = NULL, mean.x = NULL, sample.mean = NULL, |
|
| 695 |
ov.y.dummy.ov.idx = NULL, |
|
| 696 |
ov.x.dummy.ov.idx = NULL, |
|
| 697 |
ov.y.dummy.lv.idx = NULL, |
|
| 698 |
ov.x.dummy.lv.idx = NULL, delta = TRUE) {
|
|
| 699 | 52x |
LAMBDA <- MLIST$lambda |
| 700 | ||
| 701 |
# get NU, but do not 'fix' |
|
| 702 | 52x |
NU <- lav_lisrel_nu0( |
| 703 | 52x |
MLIST = MLIST, sample.mean = sample.mean, |
| 704 | 52x |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 705 | 52x |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 706 | 52x |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 707 | 52x |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 708 |
) |
|
| 709 | ||
| 710 |
# compute E(ETA) |
|
| 711 | 52x |
EETA <- lav_lisrel_eeta( |
| 712 | 52x |
MLIST = MLIST, sample.mean = sample.mean, |
| 713 | 52x |
mean.x = mean.x, |
| 714 | 52x |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 715 | 52x |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 716 | 52x |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 717 | 52x |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 718 |
) |
|
| 719 | ||
| 720 |
# EY |
|
| 721 | 52x |
EY <- as.vector(NU) + as.vector(LAMBDA %*% EETA) |
| 722 | ||
| 723 |
# if delta, scale |
|
| 724 | 52x |
if (delta && !is.null(MLIST$delta)) {
|
| 725 | ! |
EY <- EY * as.vector(MLIST$delta) |
| 726 |
} |
|
| 727 | ||
| 728 | 52x |
EY |
| 729 |
} |
|
| 730 | ||
| 731 |
# 2) EYx |
|
| 732 |
# compute E(Y|x_i): expected value of observed, conditional on x_i |
|
| 733 |
# E(Y|x_i) = NU + LAMBDA %*% E(eta|x_i) |
|
| 734 | ||
| 735 |
# - if no eXo (and GAMMA): |
|
| 736 |
# E(ETA|x_i) = (I-B)^-1 ALPHA |
|
| 737 |
# we return a matrix of size [nobs x nfac] replicating E(ETA) |
|
| 738 |
# - if eXo and GAMMA: |
|
| 739 |
# E(ETA|x_i) = (I-B)^-1 ALPHA + (I-B)^-1 GAMMA x_i |
|
| 740 |
# we return a matrix of size [nobs x nfac] |
|
| 741 |
# |
|
| 742 |
# - we ALWAYS compute NU+ALPHA, even if meanstructure=FALSE |
|
| 743 |
# - never used if GAMMA, since we then have categorical variables, and the |
|
| 744 |
# 'part 1' structure contains the (thresholds +) intercepts, not |
|
| 745 |
# the means |
|
| 746 |
lav_lisrel_eyx <- function(MLIST = NULL, |
|
| 747 |
eXo = NULL, |
|
| 748 |
N = nrow(eXo), |
|
| 749 |
sample.mean = NULL, |
|
| 750 |
ov.y.dummy.ov.idx = NULL, |
|
| 751 |
ov.x.dummy.ov.idx = NULL, |
|
| 752 |
ov.y.dummy.lv.idx = NULL, |
|
| 753 |
ov.x.dummy.lv.idx = NULL, |
|
| 754 |
delta = TRUE) {
|
|
| 755 | ! |
LAMBDA <- MLIST$lambda |
| 756 | ||
| 757 |
# get NU, but do not 'fix' |
|
| 758 | ! |
NU <- lav_lisrel_nu0( |
| 759 | ! |
MLIST = MLIST, |
| 760 | ! |
sample.mean = sample.mean, |
| 761 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 762 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 763 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 764 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 765 |
) |
|
| 766 | ||
| 767 |
# compute E(ETA|x_i) |
|
| 768 | ! |
EETAx <- lav_lisrel_eetax( |
| 769 | ! |
MLIST = MLIST, |
| 770 | ! |
eXo = eXo, |
| 771 | ! |
N = N, |
| 772 | ! |
sample.mean = sample.mean, |
| 773 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 774 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 775 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 776 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 777 |
) |
|
| 778 | ||
| 779 |
# EYx |
|
| 780 | ! |
EYx <- sweep(tcrossprod(EETAx, LAMBDA), 2L, STATS = NU, FUN = "+") |
| 781 | ||
| 782 |
# if delta, scale |
|
| 783 | ! |
if (delta && !is.null(MLIST$delta)) {
|
| 784 | ! |
EYx <- sweep(EYx, 2L, STATS = MLIST$delta, FUN = "*") |
| 785 |
} |
|
| 786 | ||
| 787 | ! |
EYx |
| 788 |
} |
|
| 789 | ||
| 790 |
# 3) EYetax |
|
| 791 |
# compute E(Y|eta_i,x_i): conditional expected value of observed variable |
|
| 792 |
# given specific value of eta_i AND x_i |
|
| 793 |
# |
|
| 794 |
# E(y*_i|eta_i, x_i) = NU + LAMBDA eta_i + KAPPA x_i |
|
| 795 |
# |
|
| 796 |
# where eta_i = predict(fit) = factor scores OR specific values for eta_i |
|
| 797 |
# (as in GH integration) |
|
| 798 |
# |
|
| 799 |
# if nexo = 0, and eta_i is single row, YHAT is the same for each observation |
|
| 800 |
# in this case, we return a single row, unless Nobs > 1L, in which case |
|
| 801 |
# we return Nobs identical rows |
|
| 802 |
# |
|
| 803 |
# NOTE: we assume that any effect of x_i on eta_i has already been taken |
|
| 804 |
# care off |
|
| 805 | ||
| 806 |
# categorical version |
|
| 807 |
lav_lisrel_eyetax <- function(MLIST = NULL, |
|
| 808 |
eXo = NULL, |
|
| 809 |
ETA = NULL, |
|
| 810 |
N = nrow(eXo), |
|
| 811 |
sample.mean = NULL, |
|
| 812 |
ov.y.dummy.ov.idx = NULL, |
|
| 813 |
ov.x.dummy.ov.idx = NULL, |
|
| 814 |
ov.y.dummy.lv.idx = NULL, |
|
| 815 |
ov.x.dummy.lv.idx = NULL, |
|
| 816 |
delta = TRUE) {
|
|
| 817 | ! |
LAMBDA <- MLIST$lambda |
| 818 | ! |
BETA <- MLIST$beta |
| 819 | ! |
if (!is.null(eXo)) {
|
| 820 | ! |
N <- nrow(eXo) |
| 821 | ! |
} else if (!is.null(N)) {
|
| 822 |
# nothing to do |
|
| 823 |
} else {
|
|
| 824 | ! |
N <- 1L |
| 825 |
} |
|
| 826 | ||
| 827 |
# create ETA matrix |
|
| 828 | ! |
if (nrow(ETA) == 1L) {
|
| 829 | ! |
ETA <- matrix(ETA, N, ncol(ETA), byrow = TRUE) |
| 830 |
} |
|
| 831 | ||
| 832 |
# always augment ETA with 'dummy values' (0 for ov.y, eXo for ov.x) |
|
| 833 |
# ndummy <- length(c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx)) |
|
| 834 |
# if(ndummy > 0L) {
|
|
| 835 |
# ETA2 <- cbind(ETA, matrix(0, N, ndummy)) |
|
| 836 |
# } else {
|
|
| 837 | ! |
ETA2 <- ETA |
| 838 |
# } |
|
| 839 | ||
| 840 |
# only if we have dummy ov.y, we need to compute the 'yhat' values |
|
| 841 |
# beforehand |
|
| 842 | ! |
if (length(ov.y.dummy.lv.idx) > 0L) {
|
| 843 |
# insert eXo values |
|
| 844 | ! |
if (length(ov.x.dummy.lv.idx) > 0L) {
|
| 845 | ! |
ETA2[, ov.x.dummy.lv.idx] <- eXo |
| 846 |
} |
|
| 847 |
# zero ov.y values |
|
| 848 | ! |
if (length(ov.y.dummy.lv.idx) > 0L) {
|
| 849 | ! |
ETA2[, ov.y.dummy.lv.idx] <- 0 |
| 850 |
} |
|
| 851 | ||
| 852 |
# ALPHA? (reconstruct, but no 'fix') |
|
| 853 | ! |
ALPHA <- lav_lisrel_alpha0( |
| 854 | ! |
MLIST = MLIST, sample.mean = sample.mean, |
| 855 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 856 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 857 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 858 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 859 |
) |
|
| 860 |
# BETA? |
|
| 861 | ! |
if (!is.null(BETA)) {
|
| 862 | ! |
ETA2 <- sweep(tcrossprod(ETA2, BETA), 2L, STATS = ALPHA, FUN = "+") |
| 863 |
} else {
|
|
| 864 | ! |
ETA2 <- sweep(ETA2, 2L, STATS = ALPHA, FUN = "+") |
| 865 |
} |
|
| 866 | ||
| 867 |
# put back eXo values |
|
| 868 | ! |
if (length(ov.x.dummy.lv.idx) > 0L) {
|
| 869 | ! |
ETA2[, ov.x.dummy.lv.idx] <- eXo |
| 870 |
} |
|
| 871 | ||
| 872 |
# put back ETA values for the 'real' latent variables |
|
| 873 | ! |
dummy.idx <- c(ov.x.dummy.lv.idx, ov.y.dummy.lv.idx) |
| 874 | ! |
if (length(dummy.idx) > 0L) {
|
| 875 | ! |
lv.regular.idx <- seq_len(min(dummy.idx) - 1L) |
| 876 | ! |
ETA2[, lv.regular.idx] <- ETA[, lv.regular.idx, drop = FALSE] |
| 877 |
} |
|
| 878 |
} |
|
| 879 | ||
| 880 |
# get NU, but do not 'fix' |
|
| 881 | ! |
NU <- lav_lisrel_nu0( |
| 882 | ! |
MLIST = MLIST, |
| 883 | ! |
sample.mean = sample.mean, |
| 884 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 885 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 886 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 887 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 888 |
) |
|
| 889 | ||
| 890 |
# EYetax |
|
| 891 | ! |
EYetax <- sweep(tcrossprod(ETA2, LAMBDA), 2L, STATS = NU, FUN = "+") |
| 892 | ||
| 893 |
# if delta, scale |
|
| 894 | ! |
if (delta && !is.null(MLIST$delta)) {
|
| 895 | ! |
EYetax <- sweep(EYetax, 2L, STATS = MLIST$delta, FUN = "*") |
| 896 |
} |
|
| 897 | ||
| 898 | ! |
EYetax |
| 899 |
} |
|
| 900 | ||
| 901 |
# unconditional version |
|
| 902 |
lav_lisrel_eyetax2 <- function(MLIST = NULL, |
|
| 903 |
ETA = NULL, |
|
| 904 |
sample.mean = NULL, |
|
| 905 |
ov.y.dummy.ov.idx = NULL, |
|
| 906 |
ov.x.dummy.ov.idx = NULL, |
|
| 907 |
ov.y.dummy.lv.idx = NULL, |
|
| 908 |
ov.x.dummy.lv.idx = NULL, |
|
| 909 |
delta = TRUE) {
|
|
| 910 | ! |
LAMBDA <- MLIST$lambda |
| 911 | ! |
BETA <- MLIST$beta |
| 912 | ||
| 913 | ||
| 914 |
# only if we have dummy ov.y, we need to compute the 'yhat' values |
|
| 915 |
# beforehand, and impute them in ETA[,ov.y] |
|
| 916 | ! |
if (length(ov.y.dummy.lv.idx) > 0L) {
|
| 917 |
# ALPHA? (reconstruct, but no 'fix') |
|
| 918 | ! |
ALPHA <- lav_lisrel_alpha0( |
| 919 | ! |
MLIST = MLIST, sample.mean = sample.mean, |
| 920 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 921 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 922 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 923 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 924 |
) |
|
| 925 | ||
| 926 |
# keep all, but ov.y values |
|
| 927 | ! |
OV.NOY <- ETA[, -ov.y.dummy.lv.idx, drop = FALSE] |
| 928 |
# ov.y rows, non-ov.y cols |
|
| 929 | ! |
BETAY <- BETA[ov.y.dummy.lv.idx, -ov.y.dummy.lv.idx, drop = FALSE] |
| 930 |
# ov.y intercepts |
|
| 931 | ! |
ALPHAY <- ALPHA[ov.y.dummy.lv.idx, , drop = FALSE] |
| 932 | ||
| 933 |
# impute ov.y values in ETA |
|
| 934 | ! |
ETA[, ov.y.dummy.lv.idx] <- |
| 935 | ! |
sweep(tcrossprod(OV.NOY, BETAY), 2L, STATS = ALPHAY, FUN = "+") |
| 936 |
} |
|
| 937 | ||
| 938 |
# get NU, but do not 'fix' |
|
| 939 | ! |
NU <- lav_lisrel_nu0( |
| 940 | ! |
MLIST = MLIST, |
| 941 | ! |
sample.mean = sample.mean, |
| 942 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 943 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 944 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 945 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 946 |
) |
|
| 947 | ||
| 948 |
# EYetax |
|
| 949 | ! |
EYetax <- sweep(tcrossprod(ETA, LAMBDA), 2L, STATS = NU, FUN = "+") |
| 950 | ||
| 951 |
# if delta, scale |
|
| 952 | ! |
if (delta && !is.null(MLIST$delta)) {
|
| 953 | ! |
EYetax <- sweep(EYetax, 2L, STATS = MLIST$delta, FUN = "*") |
| 954 |
} |
|
| 955 | ||
| 956 | ! |
EYetax |
| 957 |
} |
|
| 958 | ||
| 959 |
# unconditional version |
|
| 960 |
lav_lisrel_eyetax3 <- function(MLIST = NULL, |
|
| 961 |
ETA = NULL, |
|
| 962 |
sample.mean = NULL, |
|
| 963 |
mean.x = NULL, |
|
| 964 |
ov.y.dummy.ov.idx = NULL, |
|
| 965 |
ov.x.dummy.ov.idx = NULL, |
|
| 966 |
ov.y.dummy.lv.idx = NULL, |
|
| 967 |
ov.x.dummy.lv.idx = NULL, |
|
| 968 |
delta = TRUE) {
|
|
| 969 | 4x |
LAMBDA <- MLIST$lambda |
| 970 | ||
| 971 |
# special case: empty lambda |
|
| 972 | 4x |
if (ncol(LAMBDA) == 0L) {
|
| 973 | ! |
return(matrix(sample.mean, |
| 974 | ! |
nrow(ETA), length(sample.mean), |
| 975 | ! |
byrow = TRUE |
| 976 |
)) |
|
| 977 |
} |
|
| 978 | ||
| 979 |
# lv idx |
|
| 980 | 4x |
dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 981 | 4x |
if (length(dummy.idx) > 0L) {
|
| 982 | ! |
nondummy.idx <- seq_len(min(dummy.idx) - 1L) |
| 983 |
} else {
|
|
| 984 | 4x |
nondummy.idx <- seq_len(ncol(MLIST$lambda)) |
| 985 |
} |
|
| 986 | ||
| 987 |
# beta? |
|
| 988 | 4x |
if (is.null(MLIST$beta) || length(ov.y.dummy.lv.idx) == 0L || |
| 989 | 4x |
length(nondummy.idx) == 0L) {
|
| 990 | 4x |
LAMBDA..IB.inv <- LAMBDA |
| 991 |
} else {
|
|
| 992 |
# only keep those columns of BETA that correspond to the |
|
| 993 |
# the `regular' latent variables |
|
| 994 |
# (ie. ignore the structural part altogether) |
|
| 995 | ! |
MLIST2 <- MLIST |
| 996 | ! |
MLIST2$beta[, dummy.idx] <- 0 |
| 997 | ! |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST2) |
| 998 | ! |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 999 |
} |
|
| 1000 | ||
| 1001 |
# compute model-implied means |
|
| 1002 | 4x |
EY <- lav_lisrel_ey( |
| 1003 | 4x |
MLIST = MLIST, mean.x = mean.x, |
| 1004 | 4x |
sample.mean = sample.mean, |
| 1005 | 4x |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1006 | 4x |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1007 | 4x |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1008 | 4x |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 1009 |
) |
|
| 1010 | ||
| 1011 | 4x |
EETA <- lav_lisrel_eeta( |
| 1012 | 4x |
MLIST = MLIST, sample.mean = sample.mean, |
| 1013 | 4x |
mean.x = mean.x, |
| 1014 | 4x |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1015 | 4x |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1016 | 4x |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1017 | 4x |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 1018 |
) |
|
| 1019 | ||
| 1020 |
# center regular lv only |
|
| 1021 | 4x |
ETA[, nondummy.idx] <- sweep(ETA[, nondummy.idx, drop = FALSE], 2L, |
| 1022 | 4x |
STATS = EETA[nondummy.idx], FUN = "-" |
| 1023 |
) |
|
| 1024 | ||
| 1025 |
# project from lv to ov, if we have any lv |
|
| 1026 | 4x |
if (length(nondummy.idx) > 0) {
|
| 1027 | 4x |
EYetax <- sweep( |
| 1028 | 4x |
tcrossprod( |
| 1029 | 4x |
ETA[, nondummy.idx, drop = FALSE], |
| 1030 | 4x |
LAMBDA..IB.inv[, nondummy.idx, drop = FALSE] |
| 1031 |
), |
|
| 1032 | 4x |
2L, |
| 1033 | 4x |
STATS = EY, FUN = "+" |
| 1034 |
) |
|
| 1035 |
} else {
|
|
| 1036 | ! |
EYetax <- ETA |
| 1037 |
} |
|
| 1038 | ||
| 1039 |
# put back eXo variables |
|
| 1040 | 4x |
if (length(ov.x.dummy.lv.idx) > 0L) {
|
| 1041 | ! |
EYetax[, ov.x.dummy.ov.idx] <- ETA[, ov.x.dummy.lv.idx, drop = FALSE] |
| 1042 |
} |
|
| 1043 | ||
| 1044 |
# if delta, scale |
|
| 1045 | 4x |
if (delta && !is.null(MLIST$delta)) {
|
| 1046 | ! |
EYetax <- sweep(EYetax, 2L, STATS = MLIST$delta, FUN = "*") |
| 1047 |
} |
|
| 1048 | ||
| 1049 | 4x |
EYetax |
| 1050 |
} |
|
| 1051 | ||
| 1052 |
# 4) VY |
|
| 1053 |
# compute the *un*conditional variance/covariance of y: V(Y) or V(Y*) |
|
| 1054 |
# 'unconditional' model-implied (co)variances |
|
| 1055 |
# - same as Sigma.hat if all Y are continuous |
|
| 1056 |
# - diagonal is 1.0 (or delta^2) if categorical |
|
| 1057 |
# - if also Gamma, cov.x is used (only if conditional.x) |
|
| 1058 |
# only in THIS case, VY is different from diag(VYx) |
|
| 1059 |
# |
|
| 1060 |
# V(Y) = LAMBDA V(ETA) t(LAMBDA) + THETA |
|
| 1061 |
lav_lisrel_vy <- function(MLIST = NULL) {
|
|
| 1062 | 2201x |
LAMBDA <- MLIST$lambda |
| 1063 | 2201x |
THETA <- MLIST$theta |
| 1064 | ||
| 1065 | 2201x |
VETA <- lav_lisrel_veta(MLIST = MLIST) |
| 1066 | 2201x |
VY <- tcrossprod(LAMBDA %*% VETA, LAMBDA) + THETA |
| 1067 | 2201x |
VY |
| 1068 |
} |
|
| 1069 | ||
| 1070 |
# 5) VYx |
|
| 1071 |
# compute V(Y*|x_i) == model-implied covariance matrix |
|
| 1072 |
# this equals V(Y*) if no (explicit) eXo no GAMMA |
|
| 1073 |
# |
|
| 1074 |
# in >0.6-20: special treatment for composites |
|
| 1075 |
# |
|
| 1076 |
lav_lisrel_sigma <- function(MLIST = NULL, delta = TRUE) {
|
|
| 1077 | 24450x |
LAMBDA <- MLIST$lambda |
| 1078 | 24450x |
nvar <- nrow(LAMBDA) |
| 1079 | 24450x |
PSI <- MLIST$psi |
| 1080 | 24450x |
THETA <- MLIST$theta |
| 1081 | 24450x |
BETA <- MLIST$beta |
| 1082 | 24450x |
WMAT <- MLIST$wmat |
| 1083 | ||
| 1084 |
# standard: no composites |
|
| 1085 | 24450x |
if (is.null(WMAT)) {
|
| 1086 |
# beta? |
|
| 1087 | 24450x |
if (is.null(BETA)) {
|
| 1088 | 7238x |
LAMBDA..IB.inv <- LAMBDA |
| 1089 |
} else {
|
|
| 1090 | 17212x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 1091 | 17212x |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 1092 |
} |
|
| 1093 |
# compute V(Y*|x_i) |
|
| 1094 | 24450x |
VYx <- tcrossprod(LAMBDA..IB.inv %*% PSI, LAMBDA..IB.inv) + THETA |
| 1095 | ||
| 1096 |
# composites, or mix of composites and latent variables |
|
| 1097 |
} else {
|
|
| 1098 |
# - first join LAMBDA and WMAT |
|
| 1099 |
# - create 'T' matrix: - identity for regular lv's, |
|
| 1100 |
# - THETA block-diagonal for composites |
|
| 1101 |
# - create C_0: VETA, but zero diagonal elements for composites |
|
| 1102 | ! |
cov.idx <- which(apply(LAMBDA, 1L, |
| 1103 | ! |
function(x) sum(x == 0) == ncol(LAMBDA))) |
| 1104 | ! |
clv.idx <- which(apply(LAMBDA, 2L, |
| 1105 | ! |
function(x) sum(x == 0) == nrow(LAMBDA))) |
| 1106 |
# regular latent variables |
|
| 1107 | ! |
rlv.idx <- seq_len(ncol(LAMBDA))[-clv.idx] |
| 1108 | ||
| 1109 |
# combine LAMBDA and WMAT |
|
| 1110 | ! |
LW <- LAMBDA + WMAT |
| 1111 | ||
| 1112 | ! |
Tmat <- diag(nrow(LAMBDA)) |
| 1113 | ! |
Tmat[cov.idx, cov.idx] <- THETA[cov.idx, cov.idx] |
| 1114 | ! |
wtw <- t(LW[,clv.idx, drop = FALSE]) %*% Tmat %*% LW[,clv.idx, drop = FALSE] |
| 1115 | ! |
wtw.inv <- solve(wtw) |
| 1116 | ! |
WTW.inv <- diag(ncol(LAMBDA)) |
| 1117 | ! |
WTW.inv[clv.idx, clv.idx] <- wtw.inv |
| 1118 | ||
| 1119 | ! |
if (is.null(BETA)) {
|
| 1120 | ! |
IB.inv <- diag(nrow(PSI)) |
| 1121 |
} else {
|
|
| 1122 | ! |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 1123 |
} |
|
| 1124 | ! |
VETA <- IB.inv %*% PSI %*% t(IB.inv) |
| 1125 | ! |
C0 <- VETA; diag(C0)[clv.idx] <- 0 |
| 1126 | ||
| 1127 | ! |
VYx <- Tmat %*% LW %*% WTW.inv %*% C0 %*% t(WTW.inv) %*% t(LW) %*% Tmat + THETA |
| 1128 |
} |
|
| 1129 | ||
| 1130 |
# if delta, scale |
|
| 1131 | 24450x |
if (delta && !is.null(MLIST$delta)) {
|
| 1132 | 5819x |
DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar) |
| 1133 | 5819x |
VYx <- DELTA %*% VYx %*% DELTA |
| 1134 |
} |
|
| 1135 | ||
| 1136 | 24450x |
VYx |
| 1137 |
} |
|
| 1138 | ||
| 1139 |
# 6) VYetax |
|
| 1140 |
# V(Y | eta_i, x_i) = THETA |
|
| 1141 |
lav_lisrel_vyetax <- function(MLIST = NULL, delta = TRUE) {
|
|
| 1142 | ! |
VYetax <- MLIST$theta |
| 1143 | ! |
nvar <- nrow(MLIST$theta) |
| 1144 | ||
| 1145 |
# if delta, scale |
|
| 1146 | ! |
if (delta && !is.null(MLIST$delta)) {
|
| 1147 | ! |
DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar) |
| 1148 | ! |
VYetax <- DELTA %*% VYetax %*% DELTA |
| 1149 |
} |
|
| 1150 | ||
| 1151 | ! |
VYetax |
| 1152 |
} |
|
| 1153 | ||
| 1154 | ||
| 1155 |
### compute model-implied sample statistics |
|
| 1156 |
# |
|
| 1157 |
# 1) MuHat (similar to EY, but continuous only) |
|
| 1158 |
# 2) TH |
|
| 1159 |
# 3) PI |
|
| 1160 |
# 4) SigmaHat == VYx |
|
| 1161 | ||
| 1162 |
# compute MuHat for a single block/group; only for the continuous case (no eXo) |
|
| 1163 |
# |
|
| 1164 |
# this is a special case of E(Y) where |
|
| 1165 |
# - we have no (explicit) eXogenous variables |
|
| 1166 |
# - only continuous |
|
| 1167 |
lav_lisrel_mu<- function(MLIST = NULL) {
|
|
| 1168 | 15072x |
NU <- MLIST$nu |
| 1169 | 15072x |
ALPHA <- MLIST$alpha |
| 1170 | 15072x |
LAMBDA <- MLIST$lambda |
| 1171 | 15072x |
BETA <- MLIST$beta |
| 1172 | ||
| 1173 |
# shortcut |
|
| 1174 | 15072x |
if (is.null(ALPHA) || is.null(NU)) {
|
| 1175 | ! |
return(matrix(0, nrow(LAMBDA), 1L)) |
| 1176 |
} |
|
| 1177 | ||
| 1178 |
# beta? |
|
| 1179 | 15072x |
if (is.null(BETA)) {
|
| 1180 | 6214x |
LAMBDA..IB.inv <- LAMBDA |
| 1181 |
} else {
|
|
| 1182 | 8858x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 1183 | 8858x |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 1184 |
} |
|
| 1185 | ||
| 1186 |
# compute Mu Hat |
|
| 1187 | 15072x |
Mu.hat <- NU + LAMBDA..IB.inv %*% ALPHA |
| 1188 | ||
| 1189 | 15072x |
Mu.hat |
| 1190 |
} |
|
| 1191 | ||
| 1192 |
# compute TH for a single block/group |
|
| 1193 |
lav_lisrel_th <- function(MLIST = NULL, th.idx = NULL, delta = TRUE) {
|
|
| 1194 | 5819x |
LAMBDA <- MLIST$lambda |
| 1195 | 5819x |
nvar <- nrow(LAMBDA) |
| 1196 | 5819x |
nfac <- ncol(LAMBDA) |
| 1197 | 5819x |
BETA <- MLIST$beta |
| 1198 | 5819x |
TAU <- MLIST$tau |
| 1199 | 5819x |
nth <- nrow(TAU) |
| 1200 | ||
| 1201 |
# missing alpha |
|
| 1202 | 5819x |
if (is.null(MLIST$alpha)) {
|
| 1203 | ! |
ALPHA <- matrix(0, nfac, 1L) |
| 1204 |
} else {
|
|
| 1205 | 5819x |
ALPHA <- MLIST$alpha |
| 1206 |
} |
|
| 1207 | ||
| 1208 |
# missing nu |
|
| 1209 | 5819x |
if (is.null(MLIST$nu)) {
|
| 1210 | ! |
NU <- matrix(0, nvar, 1L) |
| 1211 |
} else {
|
|
| 1212 | 5819x |
NU <- MLIST$nu |
| 1213 |
} |
|
| 1214 | ||
| 1215 | 5819x |
if (is.null(th.idx)) {
|
| 1216 | ! |
th.idx <- seq_len(nth) |
| 1217 | ! |
nlev <- rep(1L, nvar) |
| 1218 | ! |
K_nu <- diag(nvar) |
| 1219 |
} else {
|
|
| 1220 | 5819x |
nlev <- tabulate(th.idx, nbins = nvar) |
| 1221 | 5819x |
nlev[nlev == 0L] <- 1L |
| 1222 | 5819x |
K_nu <- matrix(0, sum(nlev), nvar) |
| 1223 | 5819x |
K_nu[cbind(seq_len(sum(nlev)), rep(seq_len(nvar), times = nlev))] <- 1.0 |
| 1224 |
} |
|
| 1225 | ||
| 1226 |
# shortcut |
|
| 1227 | 5819x |
if (is.null(TAU)) {
|
| 1228 | ! |
return(matrix(0, length(th.idx), 1L)) |
| 1229 |
} |
|
| 1230 | ||
| 1231 |
# beta? |
|
| 1232 | 5819x |
if (is.null(BETA)) {
|
| 1233 | 18x |
LAMBDA..IB.inv <- LAMBDA |
| 1234 |
} else {
|
|
| 1235 | 5801x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 1236 | 5801x |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 1237 |
} |
|
| 1238 | ||
| 1239 |
# compute pi0 |
|
| 1240 | 5819x |
pi0 <- NU + LAMBDA..IB.inv %*% ALPHA |
| 1241 | ||
| 1242 |
# interleave th's with zeros where we have numeric variables |
|
| 1243 | 5819x |
th <- numeric(length(th.idx)) |
| 1244 | 5819x |
th[th.idx > 0L] <- TAU[, 1L] |
| 1245 | ||
| 1246 |
# compute TH |
|
| 1247 | 5819x |
TH <- th - (K_nu %*% pi0) |
| 1248 | ||
| 1249 |
# if delta, scale |
|
| 1250 | 5819x |
if (delta && !is.null(MLIST$delta)) {
|
| 1251 | 5819x |
DELTA.diag <- MLIST$delta[, 1L] |
| 1252 | 5819x |
DELTA.star.diag <- rep(DELTA.diag, times = nlev) |
| 1253 | 5819x |
TH <- TH * DELTA.star.diag |
| 1254 |
} |
|
| 1255 | ||
| 1256 | 5819x |
as.vector(TH) |
| 1257 |
} |
|
| 1258 | ||
| 1259 |
# compute PI for a single block/group |
|
| 1260 |
lav_lisrel_pi <- function(MLIST = NULL, delta = TRUE) {
|
|
| 1261 | 5819x |
LAMBDA <- MLIST$lambda |
| 1262 | 5819x |
BETA <- MLIST$beta |
| 1263 | 5819x |
GAMMA <- MLIST$gamma |
| 1264 | ||
| 1265 |
# shortcut |
|
| 1266 | 5819x |
if (is.null(GAMMA)) {
|
| 1267 | ! |
return(matrix(0, nrow(LAMBDA), 0L)) |
| 1268 |
} |
|
| 1269 | ||
| 1270 |
# beta? |
|
| 1271 | 5819x |
if (is.null(BETA)) {
|
| 1272 | 18x |
LAMBDA..IB.inv <- LAMBDA |
| 1273 |
} else {
|
|
| 1274 | 5801x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 1275 | 5801x |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 1276 |
} |
|
| 1277 | ||
| 1278 |
# compute PI |
|
| 1279 | 5819x |
PI <- LAMBDA..IB.inv %*% GAMMA |
| 1280 | ||
| 1281 |
# if delta, scale |
|
| 1282 | 5819x |
if (delta && !is.null(MLIST$delta)) {
|
| 1283 | 5819x |
DELTA.diag <- MLIST$delta[, 1L] |
| 1284 | 5819x |
PI <- PI * DELTA.diag |
| 1285 |
} |
|
| 1286 | ||
| 1287 | 5819x |
PI |
| 1288 |
} |
|
| 1289 | ||
| 1290 |
lav_lisrel_lambda <- function(MLIST = NULL, |
|
| 1291 |
ov.y.dummy.ov.idx = NULL, |
|
| 1292 |
ov.x.dummy.ov.idx = NULL, |
|
| 1293 |
ov.y.dummy.lv.idx = NULL, |
|
| 1294 |
ov.x.dummy.lv.idx = NULL, |
|
| 1295 |
remove.dummy.lv = FALSE) {
|
|
| 1296 | 1480x |
lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 1297 | ||
| 1298 |
# fix LAMBDA |
|
| 1299 | 1480x |
LAMBDA <- MLIST$lambda |
| 1300 | 1480x |
if (length(ov.y.dummy.ov.idx) > 0L && !is.null(MLIST$beta)) {
|
| 1301 | ! |
LAMBDA[ov.y.dummy.ov.idx, ] <- MLIST$beta[ov.y.dummy.lv.idx, ] |
| 1302 |
} |
|
| 1303 | ||
| 1304 |
# remove dummy lv? |
|
| 1305 | 1480x |
if (remove.dummy.lv && length(lv.dummy.idx) > 0L) {
|
| 1306 | ! |
LAMBDA <- LAMBDA[, -lv.dummy.idx, drop = FALSE] |
| 1307 |
} |
|
| 1308 | ||
| 1309 | 1480x |
LAMBDA |
| 1310 |
} |
|
| 1311 | ||
| 1312 |
lav_lisrel_theta <- function(MLIST = NULL, |
|
| 1313 |
ov.y.dummy.ov.idx = NULL, |
|
| 1314 |
ov.x.dummy.ov.idx = NULL, |
|
| 1315 |
ov.y.dummy.lv.idx = NULL, |
|
| 1316 |
ov.x.dummy.lv.idx = NULL) {
|
|
| 1317 | 1533x |
ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx) |
| 1318 | 1533x |
lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 1319 | ||
| 1320 |
# fix THETA |
|
| 1321 | 1533x |
THETA <- MLIST$theta |
| 1322 | 1533x |
if (length(ov.dummy.idx) > 0L) {
|
| 1323 | 40x |
THETA[ov.dummy.idx, ov.dummy.idx] <- |
| 1324 | 40x |
MLIST$psi[lv.dummy.idx, lv.dummy.idx] |
| 1325 |
} |
|
| 1326 | ||
| 1327 | 1533x |
THETA |
| 1328 |
} |
|
| 1329 | ||
| 1330 |
lav_lisrel_nu <- function(MLIST = NULL, |
|
| 1331 |
sample.mean = sample.mean, |
|
| 1332 |
ov.y.dummy.ov.idx = NULL, |
|
| 1333 |
ov.x.dummy.ov.idx = NULL, |
|
| 1334 |
ov.y.dummy.lv.idx = NULL, |
|
| 1335 |
ov.x.dummy.lv.idx = NULL) {
|
|
| 1336 |
# get NU, but do not 'fix' |
|
| 1337 | ! |
NU <- lav_lisrel_nu0( |
| 1338 | ! |
MLIST = MLIST, sample.mean = sample.mean, |
| 1339 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1340 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1341 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1342 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 1343 |
) |
|
| 1344 | ||
| 1345 |
# ALPHA? (reconstruct, but no 'fix') |
|
| 1346 | ! |
ALPHA <- lav_lisrel_alpha0( |
| 1347 | ! |
MLIST = MLIST, sample.mean = sample.mean, |
| 1348 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1349 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1350 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1351 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 1352 |
) |
|
| 1353 | ||
| 1354 | ! |
ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx) |
| 1355 | ! |
lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 1356 | ||
| 1357 |
# fix NU |
|
| 1358 | ! |
if (length(ov.dummy.idx) > 0L) {
|
| 1359 | ! |
NU[ov.dummy.idx, 1] <- ALPHA[lv.dummy.idx, 1] |
| 1360 |
} |
|
| 1361 | ||
| 1362 | ! |
NU |
| 1363 |
} |
|
| 1364 | ||
| 1365 |
# compute IB.inv |
|
| 1366 |
lav_lisrel_ibinv <- function(MLIST = NULL) {
|
|
| 1367 | 85907x |
BETA <- MLIST$beta |
| 1368 | 85907x |
nr <- nrow(MLIST$psi) |
| 1369 | ||
| 1370 | 85907x |
if (!is.null(BETA)) {
|
| 1371 | 74864x |
tmp <- -BETA |
| 1372 | 74864x |
tmp[lav_matrix_diag_idx(nr)] <- 1 |
| 1373 | 74864x |
IB.inv <- solve(tmp) |
| 1374 |
} else {
|
|
| 1375 | 11043x |
IB.inv <- diag(nr) |
| 1376 |
} |
|
| 1377 | ||
| 1378 | 85907x |
IB.inv |
| 1379 |
} |
|
| 1380 | ||
| 1381 |
# only if ALPHA=NULL but we need it anyway |
|
| 1382 |
# we 'reconstruct' ALPHA here (including dummy entries), no fixing |
|
| 1383 |
# |
|
| 1384 |
# without any dummy variables, this is just the zero vector |
|
| 1385 |
# but if we have dummy variables, we need to fill in their values |
|
| 1386 |
# |
|
| 1387 |
# |
|
| 1388 |
lav_lisrel_alpha0 <- function(MLIST = NULL, sample.mean = NULL, |
|
| 1389 |
ov.y.dummy.ov.idx = NULL, |
|
| 1390 |
ov.x.dummy.ov.idx = NULL, |
|
| 1391 |
ov.y.dummy.lv.idx = NULL, |
|
| 1392 |
ov.x.dummy.lv.idx = NULL) {
|
|
| 1393 | 128x |
if (!is.null(MLIST$alpha)) {
|
| 1394 | 119x |
return(MLIST$alpha) |
| 1395 |
} |
|
| 1396 | ||
| 1397 | 9x |
LAMBDA <- MLIST$lambda |
| 1398 | 9x |
nfac <- ncol(LAMBDA) |
| 1399 | ||
| 1400 | 9x |
ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx) |
| 1401 | 9x |
lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 1402 | ||
| 1403 | 9x |
if (length(ov.dummy.idx) > 0L) {
|
| 1404 | 5x |
ALPHA <- matrix(0, nfac, 1L) |
| 1405 |
# Note: instead of sample.mean, we need 'intercepts' |
|
| 1406 |
# sample.mean = NU + LAMBDA..IB.inv %*% ALPHA |
|
| 1407 |
# so, |
|
| 1408 |
# solve(LAMBDA..IB.inv) %*% (sample.mean - NU) = ALPHA |
|
| 1409 |
# where |
|
| 1410 |
# - LAMBDA..IB.inv only contains 'dummy' variables, and is square |
|
| 1411 |
# - NU elements are not needed (since not in ov.dummy.idx) |
|
| 1412 | 5x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 1413 | 5x |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 1414 | 5x |
LAMBDA..IB.inv.dummy <- LAMBDA..IB.inv[ov.dummy.idx, lv.dummy.idx] |
| 1415 | 5x |
ALPHA[lv.dummy.idx] <- |
| 1416 | 5x |
solve(LAMBDA..IB.inv.dummy, sample.mean[ov.dummy.idx]) |
| 1417 |
} else {
|
|
| 1418 | 4x |
ALPHA <- matrix(0, nfac, 1L) |
| 1419 |
} |
|
| 1420 | ||
| 1421 | 9x |
ALPHA |
| 1422 |
} |
|
| 1423 | ||
| 1424 |
# only if NU=NULL but we need it anyway |
|
| 1425 |
# |
|
| 1426 |
# since we have no meanstructure, we can assume NU is unrestricted |
|
| 1427 |
# and contains either: |
|
| 1428 |
# 1) the sample means (if not eXo) |
|
| 1429 |
# 2) the intercepts, if we have exogenous covariates |
|
| 1430 |
# since sample.mean = NU + LAMBDA %*% E(eta) |
|
| 1431 |
# we have NU = sample.mean - LAMBDA %*% E(eta) |
|
| 1432 |
lav_lisrel_nu0 <- function(MLIST = NULL, sample.mean = NULL, |
|
| 1433 |
ov.y.dummy.ov.idx = NULL, |
|
| 1434 |
ov.x.dummy.ov.idx = NULL, |
|
| 1435 |
ov.y.dummy.lv.idx = NULL, |
|
| 1436 |
ov.x.dummy.lv.idx = NULL) {
|
|
| 1437 | 52x |
if (!is.null(MLIST$nu)) {
|
| 1438 | 52x |
return(MLIST$nu) |
| 1439 |
} |
|
| 1440 | ||
| 1441 |
# if nexo > 0, substract lambda %*% EETA |
|
| 1442 | ! |
if (length(ov.x.dummy.ov.idx) > 0L) {
|
| 1443 | ! |
EETA <- lav_lisrel_eeta(MLIST, |
| 1444 | ! |
mean.x = NULL, |
| 1445 | ! |
sample.mean = sample.mean, |
| 1446 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1447 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1448 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1449 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 1450 |
) |
|
| 1451 | ||
| 1452 |
# 'regress' NU on X |
|
| 1453 | ! |
NU <- sample.mean - MLIST$lambda %*% EETA |
| 1454 | ||
| 1455 |
# just to make sure we have exact zeroes for all dummies |
|
| 1456 | ! |
NU[c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx)] <- 0 |
| 1457 |
} else {
|
|
| 1458 |
# unrestricted mean |
|
| 1459 | ! |
NU <- sample.mean |
| 1460 |
} |
|
| 1461 | ||
| 1462 | ! |
NU |
| 1463 |
} |
|
| 1464 | ||
| 1465 |
lav_lisrel_kappa <- function(MLIST = NULL, |
|
| 1466 |
ov.y.dummy.ov.idx = NULL, |
|
| 1467 |
ov.x.dummy.ov.idx = NULL, |
|
| 1468 |
ov.y.dummy.lv.idx = NULL, |
|
| 1469 |
ov.x.dummy.lv.idx = NULL, |
|
| 1470 |
nexo = NULL) {
|
|
| 1471 | ! |
nvar <- nrow(MLIST$lambda) |
| 1472 | ! |
if (!is.null(MLIST$gamma)) {
|
| 1473 | ! |
this.nexo <- ncol(MLIST$gamma) |
| 1474 | ! |
} else if (!is.null(nexo)) {
|
| 1475 | ! |
this.nexo <- nexo |
| 1476 |
} else {
|
|
| 1477 | ! |
lav_msg_stop(gettext("nexo not known"))
|
| 1478 |
} |
|
| 1479 | ||
| 1480 |
# create KAPPA |
|
| 1481 | ! |
KAPPA <- matrix(0, nvar, this.nexo) |
| 1482 | ! |
if (!is.null(MLIST$gamma)) {
|
| 1483 | ! |
KAPPA[ov.y.dummy.ov.idx, ] <- |
| 1484 | ! |
MLIST$gamma[ov.y.dummy.lv.idx, , drop = FALSE] |
| 1485 | ! |
} else if (length(ov.x.dummy.ov.idx) > 0L) {
|
| 1486 | ! |
KAPPA[ov.y.dummy.ov.idx, ] <- |
| 1487 | ! |
MLIST$beta[ov.y.dummy.lv.idx, |
| 1488 | ! |
ov.x.dummy.lv.idx, |
| 1489 | ! |
drop = FALSE |
| 1490 |
] |
|
| 1491 |
} |
|
| 1492 | ||
| 1493 | ! |
KAPPA |
| 1494 |
} |
|
| 1495 | ||
| 1496 | ||
| 1497 |
# old version of computeEYetax (using 'fixing') |
|
| 1498 |
lav_lisrel_eyetax_old <- function(MLIST = NULL, eXo = NULL, ETA = NULL, |
|
| 1499 |
sample.mean = NULL, |
|
| 1500 |
ov.y.dummy.ov.idx = NULL, |
|
| 1501 |
ov.x.dummy.ov.idx = NULL, |
|
| 1502 |
ov.y.dummy.lv.idx = NULL, |
|
| 1503 |
ov.x.dummy.lv.idx = NULL, |
|
| 1504 |
Nobs = 1L) {
|
|
| 1505 | ! |
LAMBDA <- MLIST$lambda |
| 1506 | ! |
nvar <- nrow(LAMBDA) |
| 1507 | ! |
nfac <- ncol(LAMBDA) |
| 1508 | ! |
lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 1509 | ! |
ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx) |
| 1510 | ||
| 1511 |
# exogenous variables? |
|
| 1512 | ! |
if (is.null(eXo)) {
|
| 1513 | ! |
nexo <- 0L |
| 1514 |
} else {
|
|
| 1515 | ! |
nexo <- ncol(eXo) |
| 1516 |
# check ETA rows |
|
| 1517 | ! |
if (!(nrow(ETA) == 1L || nrow(ETA) == nrow(eXo))) {
|
| 1518 | ! |
lav_msg_stop(gettext("!(nrow(ETA) == 1L || nrow(ETA) == nrow(eXo))"))
|
| 1519 |
} |
|
| 1520 |
} |
|
| 1521 | ||
| 1522 |
# get NU |
|
| 1523 | ! |
NU <- lav_lisrel_nu0( |
| 1524 | ! |
MLIST = MLIST, sample.mean = sample.mean, |
| 1525 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1526 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1527 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1528 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 1529 |
) |
|
| 1530 | ||
| 1531 |
# ALPHA? (reconstruct, but no 'fix') |
|
| 1532 | ! |
ALPHA <- lav_lisrel_alpha0( |
| 1533 | ! |
MLIST = MLIST, sample.mean = sample.mean, |
| 1534 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1535 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1536 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1537 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 1538 |
) |
|
| 1539 | ||
| 1540 |
# fix NU |
|
| 1541 | ! |
if (length(lv.dummy.idx) > 0L) {
|
| 1542 | ! |
NU[ov.dummy.idx, 1L] <- ALPHA[lv.dummy.idx, 1L] |
| 1543 |
} |
|
| 1544 | ||
| 1545 |
# fix LAMBDA (remove dummies) ## FIXME -- needed? |
|
| 1546 | ! |
LAMBDA <- MLIST$lambda |
| 1547 | ! |
if (length(lv.dummy.idx) > 0L) {
|
| 1548 | ! |
LAMBDA <- LAMBDA[, -lv.dummy.idx, drop = FALSE] |
| 1549 | ! |
nfac <- ncol(LAMBDA) |
| 1550 | ! |
LAMBDA[ov.y.dummy.ov.idx, ] <- |
| 1551 | ! |
MLIST$beta[ov.y.dummy.lv.idx, seq_len(nfac), drop = FALSE] |
| 1552 |
} |
|
| 1553 | ||
| 1554 |
# compute YHAT |
|
| 1555 | ! |
YHAT <- sweep(ETA %*% t(LAMBDA), MARGIN = 2, NU, "+") |
| 1556 | ||
| 1557 |
# Kappa + eXo? |
|
| 1558 |
# note: Kappa elements are either in Gamma or in Beta |
|
| 1559 | ! |
if (nexo > 0L) {
|
| 1560 |
# create KAPPA |
|
| 1561 | ! |
KAPPA <- lav_lisrel_kappa( |
| 1562 | ! |
MLIST = MLIST, |
| 1563 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 1564 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 1565 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 1566 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx, |
| 1567 | ! |
nexo = nexo |
| 1568 |
) |
|
| 1569 | ||
| 1570 |
# expand YHAT if ETA only has 1 row |
|
| 1571 | ! |
if (nrow(YHAT) == 1L) {
|
| 1572 | ! |
YHAT <- sweep(eXo %*% t(KAPPA), MARGIN = 2, STATS = YHAT, FUN = "+") |
| 1573 |
} else {
|
|
| 1574 |
# add fixed part |
|
| 1575 | ! |
YHAT <- YHAT + (eXo %*% t(KAPPA)) |
| 1576 |
} |
|
| 1577 | ||
| 1578 |
# put back eXo |
|
| 1579 | ! |
if (length(ov.x.dummy.ov.idx) > 0L) {
|
| 1580 | ! |
YHAT[, ov.x.dummy.ov.idx] <- eXo |
| 1581 |
} |
|
| 1582 |
} else {
|
|
| 1583 |
# duplicate? |
|
| 1584 | ! |
if (is.numeric(Nobs) && Nobs > 1L && nrow(YHAT) == 1L) {
|
| 1585 | ! |
YHAT <- matrix(YHAT, Nobs, nvar, byrow = TRUE) |
| 1586 |
# YHAT <- YHAT[ rep(1L, Nobs), ] |
|
| 1587 |
} |
|
| 1588 |
} |
|
| 1589 | ||
| 1590 |
# delta? |
|
| 1591 |
# FIXME: not used here? |
|
| 1592 |
# if(!is.null(DELTA)) {
|
|
| 1593 |
# YHAT <- sweep(YHAT, MARGIN=2, DELTA, "*") |
|
| 1594 |
# } |
|
| 1595 | ||
| 1596 | ! |
YHAT |
| 1597 |
} |
|
| 1598 | ||
| 1599 | ||
| 1600 |
# deal with 'dummy' OV.X latent variables |
|
| 1601 |
# create additional matrices (eg GAMMA), and resize |
|
| 1602 |
# remove all ov.x related entries |
|
| 1603 |
lav_lisrel_lisrelx <- function(MLIST = NULL, |
|
| 1604 |
ov.x.dummy.ov.idx = NULL, |
|
| 1605 |
ov.x.dummy.lv.idx = NULL) {
|
|
| 1606 | ! |
lv.idx <- ov.x.dummy.lv.idx |
| 1607 | ! |
ov.idx <- ov.x.dummy.ov.idx |
| 1608 | ! |
if (length(lv.idx) == 0L) {
|
| 1609 | ! |
return(MLIST) |
| 1610 |
} |
|
| 1611 | ! |
if (!is.null(MLIST$gamma)) {
|
| 1612 | ! |
nexo <- ncol(MLIST$gamma) |
| 1613 |
} else {
|
|
| 1614 | ! |
nexo <- length(ov.x.dummy.ov.idx) |
| 1615 |
} |
|
| 1616 | ! |
nvar <- nrow(MLIST$lambda) |
| 1617 | ! |
nfac <- ncol(MLIST$lambda) - length(lv.idx) |
| 1618 | ||
| 1619 |
# copy |
|
| 1620 | ! |
MLISTX <- MLIST |
| 1621 | ||
| 1622 |
# fix LAMBDA: |
|
| 1623 |
# - remove all ov.x related columns/rows |
|
| 1624 | ! |
MLISTX$lambda <- MLIST$lambda[-ov.idx, -lv.idx, drop = FALSE] |
| 1625 | ||
| 1626 |
# fix THETA: |
|
| 1627 |
# - remove ov.x related columns/rows |
|
| 1628 | ! |
MLISTX$theta <- MLIST$theta[-ov.idx, -ov.idx, drop = FALSE] |
| 1629 | ||
| 1630 |
# fix PSI: |
|
| 1631 |
# - remove ov.x related columns/rows |
|
| 1632 | ! |
MLISTX$psi <- MLIST$psi[-lv.idx, -lv.idx, drop = FALSE] |
| 1633 | ||
| 1634 |
# create GAMMA |
|
| 1635 | ! |
if (length(ov.x.dummy.lv.idx) > 0L) {
|
| 1636 | ! |
MLISTX$gamma <- MLIST$beta[-lv.idx, lv.idx, drop = FALSE] |
| 1637 |
} |
|
| 1638 | ||
| 1639 |
# fix BETA (remove if empty) |
|
| 1640 | ! |
if (!is.null(MLIST$beta)) {
|
| 1641 | ! |
MLISTX$beta <- MLIST$beta[-lv.idx, -lv.idx, drop = FALSE] |
| 1642 | ! |
if (ncol(MLISTX$beta) == 0L) MLISTX$beta <- NULL |
| 1643 |
} |
|
| 1644 | ||
| 1645 |
# fix NU |
|
| 1646 | ! |
if (!is.null(MLIST$nu)) {
|
| 1647 | ! |
MLISTX$nu <- MLIST$nu[-ov.idx, 1L, drop = FALSE] |
| 1648 |
} |
|
| 1649 | ||
| 1650 |
# fix ALPHA |
|
| 1651 | ! |
if (!is.null(MLIST$alpha)) {
|
| 1652 | ! |
MLISTX$alpha <- MLIST$alpha[-lv.idx, 1L, drop = FALSE] |
| 1653 |
} |
|
| 1654 | ||
| 1655 | ! |
MLISTX |
| 1656 |
} |
|
| 1657 | ||
| 1658 | ||
| 1659 |
# create MLIST from MLISTX |
|
| 1660 |
lav_lisrelx_lisrel <- function(MLISTX = NULL, |
|
| 1661 |
ov.x.dummy.ov.idx = NULL, |
|
| 1662 |
ov.x.dummy.lv.idx = NULL, |
|
| 1663 |
mean.x = NULL, |
|
| 1664 |
cov.x = NULL) {
|
|
| 1665 | ! |
lv.idx <- ov.x.dummy.lv.idx |
| 1666 | ! |
ndum <- length(lv.idx) |
| 1667 | ! |
ov.idx <- ov.x.dummy.ov.idx |
| 1668 | ! |
if (length(lv.idx) == 0L) {
|
| 1669 | ! |
return(MLISTX) |
| 1670 |
} |
|
| 1671 | ! |
stopifnot(!is.null(cov.x), !is.null(mean.x)) |
| 1672 | ! |
nvar <- nrow(MLISTX$lambda) |
| 1673 | ! |
nfac <- ncol(MLISTX$lambda) |
| 1674 | ||
| 1675 |
# copy |
|
| 1676 | ! |
MLIST <- MLISTX |
| 1677 | ||
| 1678 |
# resize matrices |
|
| 1679 | ! |
MLIST$lambda <- rbind( |
| 1680 | ! |
cbind(MLISTX$lambda, matrix(0, nvar, ndum)), |
| 1681 | ! |
matrix(0, ndum, nfac + ndum) |
| 1682 |
) |
|
| 1683 | ! |
MLIST$psi <- rbind( |
| 1684 | ! |
cbind(MLISTX$psi, matrix(0, nfac, ndum)), |
| 1685 | ! |
matrix(0, ndum, nfac + ndum) |
| 1686 |
) |
|
| 1687 | ! |
MLIST$theta <- rbind( |
| 1688 | ! |
cbind(MLISTX$theta, matrix(0, nvar, ndum)), |
| 1689 | ! |
matrix(0, ndum, nvar + ndum) |
| 1690 |
) |
|
| 1691 | ! |
if (!is.null(MLISTX$beta)) {
|
| 1692 | ! |
MLIST$beta <- rbind( |
| 1693 | ! |
cbind(MLISTX$beta, matrix(0, nfac, ndum)), |
| 1694 | ! |
matrix(0, ndum, nfac + ndum) |
| 1695 |
) |
|
| 1696 |
} |
|
| 1697 | ! |
if (!is.null(MLISTX$alpha)) {
|
| 1698 | ! |
MLIST$alpha <- rbind(MLISTX$alpha, matrix(0, ndum, 1)) |
| 1699 |
} |
|
| 1700 | ! |
if (!is.null(MLISTX$nu)) {
|
| 1701 | ! |
MLIST$nu <- rbind(MLISTX$nu, matrix(0, ndum, 1)) |
| 1702 |
} |
|
| 1703 | ||
| 1704 |
# fix LAMBDA: |
|
| 1705 |
# - add columns for all dummy latent variables |
|
| 1706 | ! |
MLIST$lambda[cbind(ov.idx, lv.idx)] <- 1 |
| 1707 | ||
| 1708 |
# fix PSI |
|
| 1709 |
# - move cov.x elements to PSI |
|
| 1710 | ! |
MLIST$psi[lv.idx, lv.idx] <- cov.x |
| 1711 | ||
| 1712 |
# move (ov.x.dummy elements of) GAMMA to BETA |
|
| 1713 | ! |
MLIST$beta[seq_len(nfac), ov.x.dummy.lv.idx] <- MLISTX$gamma |
| 1714 | ! |
MLIST$gamma <- NULL |
| 1715 | ||
| 1716 |
# fix ALPHA |
|
| 1717 | ! |
if (!is.null(MLIST$alpha)) {
|
| 1718 | ! |
MLIST$alpha[lv.idx] <- mean.x |
| 1719 |
} |
|
| 1720 | ||
| 1721 | ! |
MLIST |
| 1722 |
} |
|
| 1723 | ||
| 1724 |
# set (total/residual) variances of composites |
|
| 1725 |
# and while we at it, also set intercepts of composites |
|
| 1726 |
lav_lisrel_composites_variances<- function(MLIST = NULL, |
|
| 1727 |
tol = .Machine$double.eps, |
|
| 1728 |
debug = FALSE) {
|
|
| 1729 | ! |
LAMBDA <- MLIST$lambda |
| 1730 | ! |
BETA <- MLIST$beta |
| 1731 | ! |
PSI <- MLIST$psi |
| 1732 | ! |
WMAT <- MLIST$wmat |
| 1733 | ! |
THETA <- MLIST$theta |
| 1734 | ||
| 1735 |
# std.lv or not? |
|
| 1736 | ! |
marker.idx <- lav_utils_get_marker(MLIST$wmat) |
| 1737 | ! |
std.lv <- FALSE |
| 1738 | ! |
if (all(is.na(marker.idx))) {
|
| 1739 | ! |
std.lv <- TRUE |
| 1740 |
} |
|
| 1741 | ||
| 1742 |
# housekeeping |
|
| 1743 | ! |
ovc.idx <- which(apply(LAMBDA, 1L, |
| 1744 | ! |
function(x) sum(x == 0) == ncol(LAMBDA))) |
| 1745 | ! |
lvc.idx <- which(apply(LAMBDA, 2L, |
| 1746 | ! |
function(x) sum(x == 0) == nrow(LAMBDA))) |
| 1747 | ! |
lvc.flag <- logical(nrow(PSI)) |
| 1748 | ! |
lvc.flag[lvc.idx] <- TRUE |
| 1749 | ! |
Tmat <- diag(nrow(LAMBDA)) |
| 1750 | ! |
Tmat[ovc.idx, ovc.idx] <- MLIST$theta[ovc.idx, ovc.idx] |
| 1751 | ||
| 1752 | ! |
if (std.lv) {
|
| 1753 | ! |
target.psi <- rep(1, ncol(WMAT)) |
| 1754 |
} else {
|
|
| 1755 |
# total variances composites |
|
| 1756 | ! |
target.psi <- diag(t(WMAT) %*% Tmat %*% WMAT) |
| 1757 |
} |
|
| 1758 |
# fill in PSI element for non-composites |
|
| 1759 | ! |
target.psi[!lvc.flag] <- diag(PSI)[!lvc.flag] |
| 1760 | ||
| 1761 |
# initial values (including exogenous variances) |
|
| 1762 | ! |
diag(PSI) <- target.psi |
| 1763 | ||
| 1764 |
# no regressions |
|
| 1765 | ! |
if (is.null(BETA)) {
|
| 1766 |
# store PSI |
|
| 1767 | ! |
MLIST$psi <- PSI |
| 1768 | ||
| 1769 | ! |
return(MLIST) |
| 1770 |
} |
|
| 1771 | ||
| 1772 |
# set (residual) variances in psi |
|
| 1773 | ! |
abs.beta <- abs(MLIST$beta) |
| 1774 | ! |
x.idx <- which(apply(abs.beta, 1L, sum) == 0 & lvc.flag) |
| 1775 | ! |
y.idx <- which(apply(abs.beta, 1L, sum) != 0 & lvc.flag) |
| 1776 | ||
| 1777 | ! |
nr <- nrow(BETA) |
| 1778 | ! |
IB <- -BETA |
| 1779 | ! |
IB[lav_matrix_diag_idx(nr)] <- 1 |
| 1780 | ! |
IB.inv <- solve(IB) |
| 1781 | ||
| 1782 | ||
| 1783 |
# check if IB is acyclic |
|
| 1784 | ! |
if (det(IB) != 1) {
|
| 1785 |
# damn, we have an cyclic model; use nlminb() |
|
| 1786 | ! |
PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI, |
| 1787 | ! |
target.psi = target.psi, y.idx = y.idx) |
| 1788 |
} else {
|
|
| 1789 |
# for an acyclic model, we should be able to find the |
|
| 1790 |
# residual analytically; simply by computing the model-based |
|
| 1791 |
# total variances of the RHS of each regression, and set the |
|
| 1792 |
# residual of the y variable so that it is exactly equal to unity |
|
| 1793 |
# (yes, this will result in negative resdidual variances if needed) |
|
| 1794 | ||
| 1795 |
# ideally, we first sort the variables 'in topological order'; then |
|
| 1796 |
# we need only one run; but here we are somewhat lazy, and we |
|
| 1797 |
# use a few runs, each time setting more variables right |
|
| 1798 | ||
| 1799 |
# get ancestors list for each node/variable |
|
| 1800 | ! |
ancestors <- lav_graph_get_ancestors(BETA) |
| 1801 | ||
| 1802 |
# for each y variable, compute IB.inv %*% psi %*% t(IB.inv), without y |
|
| 1803 | ! |
ny <- length(y.idx) |
| 1804 | ! |
max_rep <- ny * 4 |
| 1805 | ! |
for(rep in seq_len(max_rep)) {
|
| 1806 | ! |
if (debug) {
|
| 1807 | ! |
cat("rep = ", rep, "\n")
|
| 1808 |
} |
|
| 1809 |
# check current diagonal |
|
| 1810 | ! |
current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv)) |
| 1811 | ! |
if (debug) {
|
| 1812 | ! |
cat("target.psi = ", target.psi[y.idx], "\n")
|
| 1813 | ! |
cat("current.diag = ", current.diag[y.idx], "\n")
|
| 1814 |
} |
|
| 1815 | ! |
if (all(abs(current.diag[y.idx] - target.psi[y.idx]) < tol)) {
|
| 1816 |
# we are done, bail out |
|
| 1817 | ! |
break |
| 1818 |
} |
|
| 1819 | ! |
for (i in seq_len(ny)) {
|
| 1820 | ! |
this.y.idx <- y.idx[i] |
| 1821 | ! |
this.x.idx <- ancestors[[this.y.idx]] |
| 1822 | ! |
IB.inv.y <- IB.inv[this.y.idx, this.x.idx, drop = FALSE] |
| 1823 | ! |
PSI.x <- PSI[this.x.idx, this.x.idx, drop = FALSE] |
| 1824 | ! |
var.y <- drop(IB.inv.y %*% PSI.x %*% t(IB.inv.y)) |
| 1825 | ! |
PSI[this.y.idx, this.y.idx] <- target.psi[this.y.idx] - var.y |
| 1826 |
} |
|
| 1827 |
} |
|
| 1828 | ||
| 1829 |
# final check? |
|
| 1830 | ! |
current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv)) |
| 1831 | ! |
if (debug) {
|
| 1832 | ! |
cat("final current.diag = ", current.diag[y.idx], "\n")
|
| 1833 |
} |
|
| 1834 |
# don't be too strict here |
|
| 1835 | ! |
if (any(abs(current.diag[y.idx] - target.psi[y.idx]) > sqrt(tol))) {
|
| 1836 |
# as a last resort, use optimization |
|
| 1837 | ! |
PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI, |
| 1838 | ! |
target.psi = target.psi, y.idx = y.idx) |
| 1839 |
} |
|
| 1840 | ||
| 1841 |
} # acyclic |
|
| 1842 | ||
| 1843 |
# store PSI |
|
| 1844 | ! |
MLIST$psi <- PSI |
| 1845 | ||
| 1846 |
# fix composite mean (if needed) |
|
| 1847 | ! |
if (!is.null(MLIST$alpha)) {
|
| 1848 | ! |
tmp <- t(WMAT) %*% MLIST$nu |
| 1849 | ! |
MLIST$alpha[lvc.idx, 1L] <- tmp[lvc.idx, 1L] |
| 1850 |
} |
|
| 1851 | ||
| 1852 | ! |
MLIST |
| 1853 |
} |
|
| 1854 | ||
| 1855 |
# if DELTA parameterization, compute residual elements (in theta, or psi) |
|
| 1856 |
# - typically for (endogenous) observed *categorical* variables only |
|
| 1857 |
# - but could also be all (endogenous) observed variables, if correlation = TRUE |
|
| 1858 |
# - or all (endogenous) latent and observed variables, if ov.only = FALSE |
|
| 1859 |
# |
|
| 1860 |
# new version YR 29 Oct 2024: try harder for psi elements (but this only works |
|
| 1861 |
# for acyclic models) |
|
| 1862 |
# YR 01 Noc 2024: for non-acyclic models: use optimization |
|
| 1863 |
lav_lisrel_residual_variances <- function(MLIST = NULL, |
|
| 1864 |
num.idx = NULL, |
|
| 1865 |
ov.y.dummy.ov.idx = NULL, |
|
| 1866 |
ov.y.dummy.lv.idx = NULL, |
|
| 1867 |
ov.only = TRUE, |
|
| 1868 |
tol = .Machine$double.eps, |
|
| 1869 |
debug = FALSE) {
|
|
| 1870 | 5924x |
BETA <- MLIST$beta |
| 1871 | 5924x |
PSI <- MLIST$psi |
| 1872 | 5924x |
if (is.null(MLIST$delta)) {
|
| 1873 | ! |
delta <- rep(1, nrow(MLIST$lambda)) |
| 1874 |
} else {
|
|
| 1875 | 5924x |
delta <- MLIST$delta |
| 1876 |
} |
|
| 1877 | ||
| 1878 |
# remove num.idx from ov.y.dummy.* |
|
| 1879 | 5924x |
if (length(num.idx) > 0L && length(ov.y.dummy.ov.idx) > 0L) {
|
| 1880 | 20x |
n.idx <- which(ov.y.dummy.ov.idx %in% num.idx) |
| 1881 | 20x |
if (length(n.idx) > 0L) {
|
| 1882 | 20x |
ov.y.dummy.ov.idx <- ov.y.dummy.ov.idx[-n.idx] |
| 1883 | 20x |
ov.y.dummy.lv.idx <- ov.y.dummy.lv.idx[-n.idx] |
| 1884 |
} |
|
| 1885 |
} |
|
| 1886 | ||
| 1887 |
# if delta, the target may not be unity, but DELTA^(-2) |
|
| 1888 | 5924x |
target.all <- 1/(delta * delta) # often the unit vector |
| 1889 | 5924x |
target.psi <- rep(1, nrow(PSI)) |
| 1890 | 5924x |
if (length(ov.y.dummy.ov.idx) > 0L) {
|
| 1891 | 20x |
target.psi[ov.y.dummy.lv.idx] <- target.all[ov.y.dummy.ov.idx] |
| 1892 |
} |
|
| 1893 | ||
| 1894 |
# phase 1: set (residual) variances in psi |
|
| 1895 | 5924x |
if (!is.null(BETA) && length(ov.y.dummy.ov.idx) > 0L) {
|
| 1896 | ! |
abs.beta <- abs(MLIST$beta) |
| 1897 | ! |
x.idx <- which(apply(abs.beta, 1L, sum) == 0) |
| 1898 | ! |
if (ov.only) {
|
| 1899 | ! |
y.idx <- ov.y.dummy.lv.idx |
| 1900 |
# remove x.idx elements (fixed.x = FALSE) |
|
| 1901 | ! |
if (any(y.idx %in% x.idx)) {
|
| 1902 | ! |
y.idx <- y.idx[-which(y.idx %in% x.idx)] |
| 1903 |
} |
|
| 1904 |
} else {
|
|
| 1905 | ! |
y.idx <- which(apply(abs.beta, 1L, sum) != 0) |
| 1906 |
} |
|
| 1907 | ||
| 1908 | ! |
nr <- nrow(BETA) |
| 1909 | ! |
IB <- -BETA |
| 1910 | ! |
IB[lav_matrix_diag_idx(nr)] <- 1 |
| 1911 | ! |
IB.inv <- solve(IB) |
| 1912 | ||
| 1913 | ||
| 1914 |
# check if IB is acyclic |
|
| 1915 | ! |
if (det(IB) != 1) {
|
| 1916 |
# damn, we have an cyclic model; use nlminb() |
|
| 1917 | ! |
PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI, |
| 1918 | ! |
target.psi = target.psi, y.idx = y.idx) |
| 1919 |
} else {
|
|
| 1920 |
# for an acyclic model, we should be able to find the |
|
| 1921 |
# residual analytically; simply by computing the model-based |
|
| 1922 |
# total variances of the RHS of each regression, and set the |
|
| 1923 |
# residual of the y variable so that it is exactly equal to unity |
|
| 1924 |
# (yes, this will result in negative resdidual variances if needed) |
|
| 1925 | ||
| 1926 |
# ideally, we first sort the variables 'in topological order'; then |
|
| 1927 |
# we need only one run; but here we are somewhat lazy, and we |
|
| 1928 |
# use a few runs, each time setting more variables right |
|
| 1929 | ||
| 1930 |
# get ancestors list for each node/variable |
|
| 1931 | ! |
ancestors <- lav_graph_get_ancestors(BETA) |
| 1932 | ||
| 1933 |
# for each y variable, compute IB.inv %*% psi %*% t(IB.inv), without y |
|
| 1934 | ! |
ny <- length(y.idx) |
| 1935 | ! |
max_rep <- ny * 4 |
| 1936 | ! |
for(rep in seq_len(max_rep)) {
|
| 1937 | ! |
if (debug) {
|
| 1938 | ! |
cat("rep = ", rep, "\n")
|
| 1939 |
} |
|
| 1940 |
# check current diagonal |
|
| 1941 | ! |
current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv)) |
| 1942 | ! |
if (debug) {
|
| 1943 | ! |
cat("target.psi = ", target.psi[y.idx], "\n")
|
| 1944 | ! |
cat("current.diag = ", current.diag[y.idx], "\n")
|
| 1945 |
} |
|
| 1946 | ! |
if (all(abs(current.diag[y.idx] - target.psi[y.idx]) < tol)) {
|
| 1947 |
# we are done, bail out |
|
| 1948 | ! |
break |
| 1949 |
} |
|
| 1950 | ! |
for (i in seq_len(ny)) {
|
| 1951 | ! |
this.y.idx <- y.idx[i] |
| 1952 | ! |
this.x.idx <- ancestors[[this.y.idx]] |
| 1953 | ! |
IB.inv.y <- IB.inv[this.y.idx, this.x.idx, drop = FALSE] |
| 1954 | ! |
PSI.x <- PSI[this.x.idx, this.x.idx, drop = FALSE] |
| 1955 | ! |
var.y <- drop(IB.inv.y %*% PSI.x %*% t(IB.inv.y)) |
| 1956 | ! |
PSI[this.y.idx, this.y.idx] <- target.psi[this.y.idx] - var.y |
| 1957 |
} |
|
| 1958 |
} |
|
| 1959 | ||
| 1960 |
# final check? |
|
| 1961 | ! |
current.diag <- diag(IB.inv %*% PSI %*% t(IB.inv)) |
| 1962 | ! |
if (debug) {
|
| 1963 | ! |
cat("final current.diag = ", current.diag[y.idx], "\n")
|
| 1964 |
} |
|
| 1965 |
# don't be too strict here |
|
| 1966 | ! |
if (any(abs(current.diag[y.idx] - target.psi[y.idx]) > sqrt(tol))) {
|
| 1967 |
# as a last resort, use optimization |
|
| 1968 | ! |
PSI <- lav_mlist_target_psi(IB.inv = IB.inv, PSI = PSI, |
| 1969 | ! |
target.psi = target.psi, y.idx = y.idx) |
| 1970 |
} |
|
| 1971 | ||
| 1972 |
} # acyclic |
|
| 1973 |
} # phase 1 |
|
| 1974 | ||
| 1975 |
# store PSI |
|
| 1976 | 5924x |
MLIST$psi <- PSI |
| 1977 | ||
| 1978 |
# phase 2: set residual variances in theta |
|
| 1979 | ||
| 1980 |
# force non-numeric theta elements to be zero |
|
| 1981 | 5924x |
if (length(num.idx) > 0L) {
|
| 1982 | 5924x |
diag(MLIST$theta)[-num.idx] <- 0.0 |
| 1983 |
} else {
|
|
| 1984 | ! |
diag(MLIST$theta) <- 0.0 |
| 1985 |
} |
|
| 1986 | ||
| 1987 | 5924x |
Sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE) |
| 1988 | 5924x |
diag.Sigma <- diag(Sigma.hat) |
| 1989 |
# theta = DELTA^(-2) - diag( LAMBDA (I-B)^-1 PSI (I-B)^-T t(LAMBDA) ) |
|
| 1990 | 5924x |
theta.diag <- target.all - diag.Sigma |
| 1991 | 5924x |
not.idx <- unique(c(num.idx, ov.y.dummy.ov.idx)) |
| 1992 | 5924x |
if (length(not.idx) > 0L) {
|
| 1993 | 5924x |
diag(MLIST$theta)[-not.idx] <- theta.diag[-not.idx] |
| 1994 |
} else {
|
|
| 1995 | ! |
diag(MLIST$theta) <- theta.diag |
| 1996 |
} |
|
| 1997 | ||
| 1998 | 5924x |
MLIST |
| 1999 |
} |
|
| 2000 | ||
| 2001 |
# if THETA parameterization, compute delta elements |
|
| 2002 |
# of observed categorical variables, as a function of other model parameters |
|
| 2003 |
lav_lisrel_delta <- function(MLIST = NULL, num.idx = NULL) {
|
|
| 2004 | ! |
Sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE) |
| 2005 | ! |
diag.Sigma <- diag(Sigma.hat) |
| 2006 | ||
| 2007 |
# (1/delta^2) = diag( LAMBDA (I-B)^-1 PSI (I-B)^-T t(LAMBDA) ) + THETA |
|
| 2008 |
# tmp <- diag.Sigma + THETA |
|
| 2009 | ! |
tmp <- diag.Sigma |
| 2010 | ! |
tmp[tmp < 0] <- as.numeric(NA) |
| 2011 | ! |
MLIST$delta[, 1L] <- sqrt(1 / tmp) |
| 2012 | ||
| 2013 |
# numeric delta's stay 1.0 |
|
| 2014 | ! |
if (length(num.idx) > 0L) {
|
| 2015 | ! |
MLIST$delta[num.idx] <- 1.0 |
| 2016 |
} |
|
| 2017 | ||
| 2018 | ! |
MLIST |
| 2019 |
} |
|
| 2020 | ||
| 2021 |
# compute Sigma/ETA: variances/covariances of BOTH observed and latent variables |
|
| 2022 |
lav_lisrel_cov_both <- function(MLIST = NULL, delta = TRUE) {
|
|
| 2023 | ! |
LAMBDA <- MLIST$lambda |
| 2024 | ! |
nvar <- nrow(LAMBDA) |
| 2025 | ! |
PSI <- MLIST$psi |
| 2026 | ! |
nlat <- nrow(PSI) |
| 2027 | ! |
THETA <- MLIST$theta |
| 2028 | ! |
BETA <- MLIST$beta |
| 2029 | ||
| 2030 |
# 'extend' matrices |
|
| 2031 | ! |
LAMBDA2 <- rbind(LAMBDA, diag(nlat)) |
| 2032 | ! |
THETA2 <- lav_matrix_bdiag(THETA, matrix(0, nlat, nlat)) |
| 2033 | ||
| 2034 | ||
| 2035 |
# beta? |
|
| 2036 | ! |
if (is.null(BETA)) {
|
| 2037 | ! |
LAMBDA..IB.inv <- LAMBDA2 |
| 2038 |
} else {
|
|
| 2039 | ! |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 2040 | ! |
LAMBDA..IB.inv <- LAMBDA2 %*% IB.inv |
| 2041 |
} |
|
| 2042 | ||
| 2043 |
# compute augment COV matrix |
|
| 2044 | ! |
COV <- tcrossprod(LAMBDA..IB.inv %*% PSI, LAMBDA..IB.inv) + THETA2 |
| 2045 | ||
| 2046 |
# if delta, scale |
|
| 2047 | ! |
if (delta && !is.null(MLIST$delta)) {
|
| 2048 | ! |
DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar) |
| 2049 | ! |
COV[seq_len(nvar), seq_len(nvar)] <- |
| 2050 | ! |
DELTA %*% COV[seq_len(nvar), seq_len(nvar)] %*% DELTA |
| 2051 |
} |
|
| 2052 | ||
| 2053 | ||
| 2054 |
# if GAMMA, also x part |
|
| 2055 | ! |
GAMMA <- MLIST$gamma |
| 2056 | ! |
if (!is.null(GAMMA)) {
|
| 2057 | ! |
COV.X <- MLIST$cov.x |
| 2058 | ! |
if (is.null(BETA)) {
|
| 2059 | ! |
SX <- tcrossprod(GAMMA %*% COV.X, GAMMA) |
| 2060 |
} else {
|
|
| 2061 | ! |
IB.inv..GAMMA <- IB.inv %*% GAMMA |
| 2062 | ! |
SX <- tcrossprod(IB.inv..GAMMA %*% COV.X, IB.inv..GAMMA) |
| 2063 |
} |
|
| 2064 | ! |
COV[(nvar + 1):(nvar + nlat), (nvar + 1):(nvar + nlat)] <- |
| 2065 | ! |
COV[(nvar + 1):(nvar + nlat), (nvar + 1):(nvar + nlat)] + SX |
| 2066 |
} |
|
| 2067 | ||
| 2068 | ! |
COV |
| 2069 |
} |
|
| 2070 | ||
| 2071 | ||
| 2072 |
# derivative of the objective function |
|
| 2073 |
lav_lisrel_df_dmlist <- function(MLIST = NULL, Omega = NULL, Omega.mu = NULL) {
|
|
| 2074 | 4264x |
LAMBDA <- MLIST$lambda |
| 2075 | 4264x |
PSI <- MLIST$psi |
| 2076 | 4264x |
BETA <- MLIST$beta |
| 2077 | 4264x |
ALPHA <- MLIST$alpha |
| 2078 | 4264x |
WMAT <- MLIST$wmat |
| 2079 | ||
| 2080 | 4264x |
LAMBDA.deriv <- NULL |
| 2081 | 4264x |
BETA.deriv <- NULL |
| 2082 | 4264x |
THETA.deriv <- NULL |
| 2083 | 4264x |
PSI.deriv <- NULL |
| 2084 | 4264x |
NU.deriv <- NULL |
| 2085 | 4264x |
ALPHA.deriv <- NULL |
| 2086 | 4264x |
GROUP.W.deriv <- NULL |
| 2087 | 4264x |
WMAT.deriv <- NULL |
| 2088 | ||
| 2089 |
# beta? |
|
| 2090 | 4264x |
if (is.null(BETA)) {
|
| 2091 | 1496x |
LAMBDA..IB.inv <- LAMBDA |
| 2092 |
} else {
|
|
| 2093 | 2768x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 2094 | 2768x |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 2095 |
} |
|
| 2096 | ||
| 2097 |
# meanstructure? |
|
| 2098 | 4264x |
meanstructure <- FALSE |
| 2099 | 3371x |
if (!is.null(Omega.mu)) meanstructure <- TRUE |
| 2100 | ||
| 2101 |
# group weight? |
|
| 2102 | 4264x |
group.w.free <- FALSE |
| 2103 | ! |
if (!is.null(MLIST$gw)) group.w.free <- TRUE |
| 2104 | ||
| 2105 |
# pre-compute some values |
|
| 2106 | 4264x |
tLAMBDA..IB.inv <- t(LAMBDA..IB.inv) |
| 2107 | 4264x |
if (!is.null(BETA)) {
|
| 2108 | 2768x |
Omega..LAMBDA..IB.inv..PSI..tIB.inv <- |
| 2109 | 2768x |
(Omega %*% LAMBDA..IB.inv %*% PSI %*% t(IB.inv)) |
| 2110 |
} else {
|
|
| 2111 | 1496x |
Omega..LAMBDA <- Omega %*% LAMBDA |
| 2112 |
} |
|
| 2113 | ||
| 2114 |
# 1. LAMBDA |
|
| 2115 | 4264x |
if (!is.null(BETA)) {
|
| 2116 | 2768x |
if (meanstructure) {
|
| 2117 | 2095x |
LAMBDA.deriv <- -1.0 * (Omega.mu %*% t(ALPHA) %*% t(IB.inv) + |
| 2118 | 2095x |
Omega..LAMBDA..IB.inv..PSI..tIB.inv) |
| 2119 |
} else {
|
|
| 2120 | 673x |
LAMBDA.deriv <- -1.0 * Omega..LAMBDA..IB.inv..PSI..tIB.inv |
| 2121 |
} |
|
| 2122 |
} else {
|
|
| 2123 |
# no BETA |
|
| 2124 | 1496x |
if (meanstructure) {
|
| 2125 | 1276x |
LAMBDA.deriv <- -1.0 * (Omega.mu %*% t(ALPHA) + |
| 2126 | 1276x |
Omega..LAMBDA %*% PSI) |
| 2127 |
} else {
|
|
| 2128 | 220x |
LAMBDA.deriv <- -1.0 * (Omega..LAMBDA %*% PSI) |
| 2129 |
} |
|
| 2130 |
} |
|
| 2131 | ||
| 2132 |
# 2. BETA |
|
| 2133 | 4264x |
if (!is.null(BETA)) {
|
| 2134 | 2768x |
if (meanstructure) {
|
| 2135 | 2095x |
BETA.deriv <- -1.0 * ((t(IB.inv) %*% |
| 2136 | 2095x |
(t(LAMBDA) %*% Omega.mu %*% t(ALPHA)) %*% |
| 2137 | 2095x |
t(IB.inv)) + |
| 2138 | 2095x |
(tLAMBDA..IB.inv %*% |
| 2139 | 2095x |
Omega..LAMBDA..IB.inv..PSI..tIB.inv)) |
| 2140 |
} else {
|
|
| 2141 | 673x |
BETA.deriv <- -1.0 * (tLAMBDA..IB.inv %*% |
| 2142 | 673x |
Omega..LAMBDA..IB.inv..PSI..tIB.inv) |
| 2143 |
} |
|
| 2144 |
} |
|
| 2145 | ||
| 2146 |
# 3. PSI |
|
| 2147 | 4264x |
PSI.deriv <- -1.0 * (tLAMBDA..IB.inv %*% Omega %*% LAMBDA..IB.inv) |
| 2148 | 4264x |
diag(PSI.deriv) <- 0.5 * diag(PSI.deriv) |
| 2149 | ||
| 2150 |
# 4. THETA |
|
| 2151 | 4264x |
THETA.deriv <- -1.0 * Omega |
| 2152 | 4264x |
diag(THETA.deriv) <- 0.5 * diag(THETA.deriv) |
| 2153 | ||
| 2154 | 4264x |
if (meanstructure) {
|
| 2155 |
# 5. NU |
|
| 2156 | 3371x |
NU.deriv <- -1.0 * Omega.mu |
| 2157 | ||
| 2158 |
# 6. ALPHA |
|
| 2159 | 3371x |
ALPHA.deriv <- -1.0 * t(t(Omega.mu) %*% LAMBDA..IB.inv) |
| 2160 |
} |
|
| 2161 | ||
| 2162 | 4264x |
if (group.w.free) {
|
| 2163 | ! |
GROUP.W.deriv <- 0.0 |
| 2164 |
} |
|
| 2165 | ||
| 2166 | 4264x |
list( |
| 2167 | 4264x |
lambda = LAMBDA.deriv, |
| 2168 | 4264x |
wmat = WMAT.deriv, |
| 2169 | 4264x |
beta = BETA.deriv, |
| 2170 | 4264x |
theta = THETA.deriv, |
| 2171 | 4264x |
psi = PSI.deriv, |
| 2172 | 4264x |
nu = NU.deriv, |
| 2173 | 4264x |
alpha = ALPHA.deriv, |
| 2174 | 4264x |
gw = GROUP.W.deriv |
| 2175 |
) |
|
| 2176 |
} |
|
| 2177 | ||
| 2178 |
# dSigma/dx -- per model matrix |
|
| 2179 |
# note: |
|
| 2180 |
# we avoid using the duplication and elimination matrices |
|
| 2181 |
# for now (perhaps until we'll use the Matrix package) |
|
| 2182 |
lav_lisrel_dsigma_dx_old <- function(MLIST = NULL, |
|
| 2183 |
m = "lambda", |
|
| 2184 |
# all model matrix elements, or only a few? |
|
| 2185 |
# NOTE: for symmetric matrices, |
|
| 2186 |
# we assume that the have full size |
|
| 2187 |
# (nvar*nvar) (but already correct for |
|
| 2188 |
# symmetry) |
|
| 2189 |
idx = seq_len(length(MLIST[[m]])), |
|
| 2190 |
delta = TRUE) {
|
|
| 2191 | ! |
LAMBDA <- MLIST$lambda |
| 2192 | ! |
nvar <- nrow(LAMBDA) |
| 2193 | ! |
nfac <- ncol(LAMBDA) |
| 2194 | ! |
PSI <- MLIST$psi |
| 2195 | ||
| 2196 |
# only lower.tri part of sigma (not same order as elimination matrix?) |
|
| 2197 | ! |
v.idx <- lav_matrix_vech_idx(nvar) |
| 2198 | ! |
pstar <- nvar * (nvar + 1) / 2 |
| 2199 | ||
| 2200 |
# shortcut for gamma, nu, alpha and tau: empty matrix |
|
| 2201 | ! |
if (m == "nu" || m == "alpha" || m == "tau" || m == "gamma" || m == "gw" || |
| 2202 | ! |
m == "cov.x" || m == "mean.x") {
|
| 2203 | ! |
return(matrix(0.0, nrow = pstar, ncol = length(idx))) |
| 2204 |
} |
|
| 2205 | ||
| 2206 |
# Delta? |
|
| 2207 | ! |
delta.flag <- FALSE |
| 2208 | ! |
if (delta && !is.null(MLIST$delta)) {
|
| 2209 | ! |
DELTA <- MLIST$delta |
| 2210 | ! |
delta.flag <- TRUE |
| 2211 | ! |
} else if (m == "delta") { # modindices?
|
| 2212 | ! |
return(matrix(0.0, nrow = pstar, ncol = length(idx))) |
| 2213 |
} |
|
| 2214 | ||
| 2215 |
# beta? |
|
| 2216 | ! |
if (!is.null(MLIST$ibeta.inv)) {
|
| 2217 | ! |
IB.inv <- MLIST$ibeta.inv |
| 2218 |
} else {
|
|
| 2219 | ! |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 2220 |
} |
|
| 2221 | ||
| 2222 |
# pre |
|
| 2223 | ! |
if (m == "lambda" || m == "beta") {
|
| 2224 | ! |
IK <- diag(nvar * nvar) + lav_matrix_commutation(nvar, nvar) |
| 2225 |
} |
|
| 2226 | ! |
if (m == "lambda" || m == "beta") {
|
| 2227 | ! |
IB.inv..PSI..tIB.inv..tLAMBDA <- |
| 2228 | ! |
IB.inv %*% PSI %*% t(IB.inv) %*% t(LAMBDA) |
| 2229 |
} |
|
| 2230 | ! |
if (m == "beta" || m == "psi") {
|
| 2231 | ! |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 2232 |
} |
|
| 2233 | ||
| 2234 |
# here we go: |
|
| 2235 | ! |
if (m == "lambda") {
|
| 2236 | ! |
DX <- IK %*% t(IB.inv..PSI..tIB.inv..tLAMBDA %x% diag(nvar)) |
| 2237 | ! |
if (delta.flag) {
|
| 2238 | ! |
DX <- DX * as.vector(DELTA %x% DELTA) |
| 2239 |
} |
|
| 2240 | ! |
} else if (m == "beta") {
|
| 2241 | ! |
DX <- IK %*% (t(IB.inv..PSI..tIB.inv..tLAMBDA) %x% LAMBDA..IB.inv) |
| 2242 |
# this is not really needed (because we select idx=m.el.idx) |
|
| 2243 |
# but just in case we need all elements of beta... |
|
| 2244 | ! |
DX[, lav_matrix_diag_idx(nfac)] <- 0.0 |
| 2245 | ! |
if (delta.flag) {
|
| 2246 | ! |
DX <- DX * as.vector(DELTA %x% DELTA) |
| 2247 |
} |
|
| 2248 | ! |
} else if (m == "psi") {
|
| 2249 | ! |
DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv) |
| 2250 |
# symmetry correction, but keeping all duplicated elements |
|
| 2251 |
# since we depend on idx=m.el.idx |
|
| 2252 |
# otherwise, we could simply postmultiply with the duplicationMatrix |
|
| 2253 | ||
| 2254 |
# we sum up lower.tri + upper.tri (but not the diagonal elements!) |
|
| 2255 |
# imatrix <- matrix(1:nfac^2,nfac,nfac) |
|
| 2256 |
# lower.idx <- imatrix[lower.tri(imatrix, diag=FALSE)] |
|
| 2257 |
# upper.idx <- imatrix[upper.tri(imatrix, diag=FALSE)] |
|
| 2258 | ! |
lower.idx <- lav_matrix_vech_idx(nfac, diagonal = FALSE) |
| 2259 | ! |
upper.idx <- lav_matrix_vechru_idx(nfac, diagonal = FALSE) |
| 2260 |
# NOTE YR: upper.idx (see 3 lines up) is wrong in MH patch! |
|
| 2261 |
# fixed again 13/06/2012 after bug report of Mijke Rhemtulla. |
|
| 2262 | ||
| 2263 | ! |
offdiagSum <- DX[, lower.idx] + DX[, upper.idx] |
| 2264 | ! |
DX[, c(lower.idx, upper.idx)] <- cbind(offdiagSum, offdiagSum) |
| 2265 | ! |
if (delta.flag) {
|
| 2266 | ! |
DX <- DX * as.vector(DELTA %x% DELTA) |
| 2267 |
} |
|
| 2268 | ! |
} else if (m == "theta") {
|
| 2269 | ! |
DX <- diag(nvar * nvar) # very sparse... |
| 2270 |
# symmetry correction not needed, since all off-diagonal elements |
|
| 2271 |
# are zero? |
|
| 2272 | ! |
if (delta.flag) {
|
| 2273 | ! |
DX <- DX * as.vector(DELTA %x% DELTA) |
| 2274 |
} |
|
| 2275 | ! |
} else if (m == "delta") {
|
| 2276 | ! |
Omega <- lav_lisrel_sigma(MLIST, delta = FALSE) |
| 2277 | ! |
DD <- diag(DELTA[, 1], nvar, nvar) |
| 2278 | ! |
DD.Omega <- (DD %*% Omega) |
| 2279 | ! |
A <- DD.Omega %x% diag(nvar) |
| 2280 | ! |
B <- diag(nvar) %x% DD.Omega |
| 2281 | ! |
DX <- A[, lav_matrix_diag_idx(nvar), drop = FALSE] + |
| 2282 | ! |
B[, lav_matrix_diag_idx(nvar), drop = FALSE] |
| 2283 |
} else {
|
|
| 2284 | ! |
lav_msg_stop(gettext("wrong model matrix names:"), m)
|
| 2285 |
} |
|
| 2286 | ||
| 2287 | ! |
DX <- DX[v.idx, idx, drop = FALSE] |
| 2288 | ! |
DX |
| 2289 |
} |
|
| 2290 | ||
| 2291 |
# dSigma/dx -- per model matrix |
|
| 2292 |
lav_lisrel_dsigma_dx <- function(MLIST = NULL, |
|
| 2293 |
m = "lambda", |
|
| 2294 |
# all model matrix elements, or only a few? |
|
| 2295 |
# NOTE: for symmetric matrices, |
|
| 2296 |
# we assume that the have full size |
|
| 2297 |
# (nvar*nvar) (but already correct for |
|
| 2298 |
# symmetry) |
|
| 2299 |
idx = seq_len(length(MLIST[[m]])), |
|
| 2300 |
vech = TRUE, |
|
| 2301 |
delta = TRUE) {
|
|
| 2302 | 30702x |
LAMBDA <- MLIST$lambda |
| 2303 | 30702x |
nvar <- nrow(LAMBDA) |
| 2304 | 30702x |
nfac <- ncol(LAMBDA) |
| 2305 | 30702x |
PSI <- MLIST$psi |
| 2306 | 30702x |
WMAT <- MLIST$wmat |
| 2307 | ||
| 2308 |
# for composites (vec version) |
|
| 2309 | 30702x |
compute.sigma <- function(x, mm = "wmat", MLIST = NULL) {
|
| 2310 | ! |
mlist <- MLIST |
| 2311 | ! |
if (mm %in% c("psi", "theta")) {
|
| 2312 | ! |
mlist[[mm]] <- lav_matrix_vech_reverse(x) |
| 2313 |
} else {
|
|
| 2314 | ! |
mlist[[mm]][, ] <- x |
| 2315 |
} |
|
| 2316 | ! |
lav_matrix_vec(lav_lisrel_sigma(mlist)) |
| 2317 |
} |
|
| 2318 | ||
| 2319 | 30702x |
composites <- FALSE |
| 2320 | 30702x |
if (!is.null(WMAT)) {
|
| 2321 | ! |
composites <- TRUE |
| 2322 |
} |
|
| 2323 | ||
| 2324 |
# only lower.tri part of sigma (not same order as elimination matrix?) |
|
| 2325 | 30702x |
v.idx <- lav_matrix_vech_idx(nvar) |
| 2326 | 30702x |
pstar <- nvar * (nvar + 1) / 2 |
| 2327 | ||
| 2328 |
# shortcut for gamma, nu, alpha, tau,.... : empty matrix |
|
| 2329 | 30702x |
if (m == "nu" || m == "alpha" || m == "tau" || m == "gamma" || |
| 2330 | 30702x |
m == "gw" || m == "cov.x" || m == "mean.x") {
|
| 2331 | 9809x |
return(matrix(0.0, nrow = pstar, ncol = length(idx))) |
| 2332 |
} |
|
| 2333 | ||
| 2334 |
# Delta? |
|
| 2335 | 20893x |
delta.flag <- FALSE |
| 2336 | 20893x |
if (delta && !is.null(MLIST$delta)) {
|
| 2337 | 10852x |
DELTA <- MLIST$delta |
| 2338 | 10852x |
delta.flag <- TRUE |
| 2339 | 10041x |
} else if (m == "delta") { # modindices?
|
| 2340 | ! |
return(matrix(0.0, nrow = pstar, ncol = length(idx))) |
| 2341 |
} |
|
| 2342 | ||
| 2343 |
# beta? |
|
| 2344 | 20893x |
if (!is.null(MLIST$ibeta.inv)) {
|
| 2345 | ! |
IB.inv <- MLIST$ibeta.inv |
| 2346 |
} else {
|
|
| 2347 | 20893x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 2348 |
} |
|
| 2349 | ||
| 2350 |
# pre |
|
| 2351 |
# if(m == "lambda" || m == "beta") |
|
| 2352 |
# IK <- diag(nvar*nvar) + lav_matrix_commutation(nvar, nvar) |
|
| 2353 | 20893x |
if (m == "lambda" || m == "beta") {
|
| 2354 | 8861x |
L1 <- LAMBDA %*% IB.inv %*% PSI %*% t(IB.inv) |
| 2355 |
} |
|
| 2356 | 20893x |
if (m == "beta" || m == "psi") {
|
| 2357 | 8957x |
LAMBDA..IB.inv <- LAMBDA %*% IB.inv |
| 2358 |
} |
|
| 2359 | ||
| 2360 |
# here we go: |
|
| 2361 | 20893x |
if (m == "lambda") {
|
| 2362 | 5427x |
KOL.idx <- matrix(1:(nvar * nfac), nvar, nfac, byrow = TRUE)[idx] |
| 2363 | 5427x |
DX <- (L1 %x% diag(nvar))[, idx, drop = FALSE] + |
| 2364 | 5427x |
(diag(nvar) %x% L1)[, KOL.idx, drop = FALSE] |
| 2365 | 15466x |
} else if (m == "beta") {
|
| 2366 | 3434x |
if (composites) {
|
| 2367 | ! |
DX <- lav_func_jacobian_complex(func = compute.sigma, |
| 2368 | ! |
x = lav_matrix_vec(MLIST$beta), |
| 2369 | ! |
mm = "beta", MLIST = MLIST) |
| 2370 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2371 |
} else {
|
|
| 2372 | 3434x |
KOL.idx <- matrix(1:(nfac * nfac), nfac, nfac, byrow = TRUE)[idx] |
| 2373 | 3434x |
DX <- (L1 %x% LAMBDA..IB.inv)[, idx, drop = FALSE] + |
| 2374 | 3434x |
(LAMBDA..IB.inv %x% L1)[, KOL.idx, drop = FALSE] |
| 2375 |
# this is not really needed (because we select idx=m.el.idx) |
|
| 2376 |
# but just in case we need all elements of beta... |
|
| 2377 | 3434x |
DX[, which(idx %in% lav_matrix_diag_idx(nfac))] <- 0.0 |
| 2378 |
} |
|
| 2379 | 12032x |
} else if (m == "psi") {
|
| 2380 | 5523x |
if (composites) {
|
| 2381 | ! |
tmp <- lav_func_jacobian_complex(func = compute.sigma, |
| 2382 | ! |
x = lav_matrix_vech(MLIST$psi), |
| 2383 | ! |
mm = "psi", MLIST = MLIST) |
| 2384 | ! |
DX <- matrix(0, nrow = nrow(tmp), ncol = length(PSI)) |
| 2385 | ! |
DX[, lav_matrix_vech_idx(nrow(PSI))] <- tmp |
| 2386 | ! |
DX[, lav_matrix_vechu_idx(nrow(PSI), diagonal = FALSE)] <- |
| 2387 | ! |
DX[, lav_matrix_vech_idx(nrow(PSI), diagonal = FALSE), drop = FALSE] |
| 2388 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2389 |
} else {
|
|
| 2390 | 5523x |
DX <- (LAMBDA..IB.inv %x% LAMBDA..IB.inv) |
| 2391 |
# symmetry correction, but keeping all duplicated elements |
|
| 2392 |
# since we depend on idx=m.el.idx |
|
| 2393 | 5523x |
lower.idx <- lav_matrix_vech_idx(nfac, diagonal = FALSE) |
| 2394 | 5523x |
upper.idx <- lav_matrix_vechru_idx(nfac, diagonal = FALSE) |
| 2395 | 5523x |
offdiagSum <- DX[, lower.idx] + DX[, upper.idx] |
| 2396 | 5523x |
DX[, c(lower.idx, upper.idx)] <- cbind(offdiagSum, offdiagSum) |
| 2397 | 5523x |
DX <- DX[, idx, drop = FALSE] |
| 2398 |
} |
|
| 2399 | 6509x |
} else if (m == "theta") {
|
| 2400 |
# DX <- diag(nvar*nvar) # very sparse... |
|
| 2401 | 6509x |
DX <- matrix(0, nvar * nvar, length(idx)) |
| 2402 | 6509x |
DX[cbind(idx, seq_along(idx))] <- 1 |
| 2403 |
# symmetry correction not needed, since all off-diagonal elements |
|
| 2404 |
# are zero? |
|
| 2405 | ! |
} else if (m == "delta") {
|
| 2406 | ! |
Omega <- lav_lisrel_sigma(MLIST, delta = FALSE) |
| 2407 | ! |
DD <- diag(DELTA[, 1], nvar, nvar) |
| 2408 | ! |
DD.Omega <- (DD %*% Omega) |
| 2409 | ! |
A <- DD.Omega %x% diag(nvar) |
| 2410 | ! |
B <- diag(nvar) %x% DD.Omega |
| 2411 | ! |
DX <- A[, lav_matrix_diag_idx(nvar), drop = FALSE] + |
| 2412 | ! |
B[, lav_matrix_diag_idx(nvar), drop = FALSE] |
| 2413 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2414 | ! |
} else if (m == "wmat") {
|
| 2415 |
# just a dummy to get us going |
|
| 2416 | ! |
DX <- lav_func_jacobian_complex(func = compute.sigma, |
| 2417 | ! |
x = lav_matrix_vec(WMAT), |
| 2418 | ! |
mm = "wmat", MLIST = MLIST) |
| 2419 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2420 | ||
| 2421 |
# KOL.idx <- matrix(1:(nvar * nfac), nvar, nfac, byrow = TRUE)[idx] |
|
| 2422 |
# VETA <- IB.inv %*% PSI %*% t(IB.inv) |
|
| 2423 |
# C0 <- VETA; diag(C0) <- 0 |
|
| 2424 |
# cov.idx <- which(apply(LAMBDA, 1L, |
|
| 2425 |
# function(x) sum(x == 0) == ncol(LAMBDA))) |
|
| 2426 |
# clv.idx <- which(apply(LAMBDA, 2L, |
|
| 2427 |
# function(x) sum(x == 0) == nrow(LAMBDA))) |
|
| 2428 |
# Tmat <- diag(nrow(LAMBDA)) |
|
| 2429 |
# Tmat[cov.idx, cov.idx] <- MLIST$theta[cov.idx, cov.idx] |
|
| 2430 |
# L1 <- Tmat %*% WMAT %*% C0 |
|
| 2431 |
# DX <- (L1 %x% diag(nvar))[, idx, drop = FALSE] + |
|
| 2432 |
# (diag(nvar) %x% L1)[, KOL.idx, drop = FALSE] |
|
| 2433 |
# DX <- DX * nfac |
|
| 2434 |
} else {
|
|
| 2435 | ! |
lav_msg_stop(gettext("wrong model matrix name:"), m)
|
| 2436 |
} |
|
| 2437 | ||
| 2438 | 20893x |
if (delta.flag && !m == "delta") {
|
| 2439 | 10852x |
DX <- DX * as.vector(DELTA %x% DELTA) |
| 2440 |
} |
|
| 2441 | ||
| 2442 |
# vech? |
|
| 2443 | 20893x |
if (vech) {
|
| 2444 | 20893x |
DX <- DX[v.idx, , drop = FALSE] |
| 2445 |
} |
|
| 2446 | ||
| 2447 | 20893x |
DX |
| 2448 |
} |
|
| 2449 | ||
| 2450 |
# dMu/dx -- per model matrix |
|
| 2451 |
lav_lisrel_dmu_dx <- function(MLIST = NULL, |
|
| 2452 |
m = "alpha", |
|
| 2453 |
# all model matrix elements, or only a few? |
|
| 2454 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2455 | 8812x |
LAMBDA <- MLIST$lambda |
| 2456 | 8812x |
nvar <- nrow(LAMBDA) |
| 2457 | 8812x |
nfac <- ncol(LAMBDA) |
| 2458 | 8812x |
WMAT <- MLIST$wmat |
| 2459 | ||
| 2460 |
# shortcut for empty matrices |
|
| 2461 | 8812x |
if (m == "gamma" || m == "psi" || m == "theta" || m == "tau" || |
| 2462 | 8812x |
m == "delta" || m == "gw" || m == "cov.x" || m == "mean.x") {
|
| 2463 | 5040x |
return(matrix(0.0, nrow = nvar, ncol = length(idx))) |
| 2464 |
} |
|
| 2465 | ||
| 2466 |
# missing alpha |
|
| 2467 | 3772x |
if (is.null(MLIST$alpha)) {
|
| 2468 | ! |
ALPHA <- matrix(0, nfac, 1L) |
| 2469 |
} else {
|
|
| 2470 | 3772x |
ALPHA <- MLIST$alpha |
| 2471 |
} |
|
| 2472 | ||
| 2473 | ||
| 2474 |
# beta? |
|
| 2475 | 3772x |
if (!is.null(MLIST$ibeta.inv)) {
|
| 2476 | ! |
IB.inv <- MLIST$ibeta.inv |
| 2477 |
} else {
|
|
| 2478 | 3772x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 2479 |
} |
|
| 2480 | ||
| 2481 | 3772x |
if (m == "nu") {
|
| 2482 | 1612x |
DX <- diag(nvar) |
| 2483 | 2160x |
} else if (m == "lambda") {
|
| 2484 | 2080x |
DX <- t(IB.inv %*% ALPHA) %x% diag(nvar) |
| 2485 | 80x |
} else if (m == "wmat") {
|
| 2486 |
# dummy, just to get us going |
|
| 2487 | ! |
DX <- t(IB.inv %*% ALPHA) %x% diag(nvar) |
| 2488 | 80x |
} else if (m == "beta") {
|
| 2489 | 40x |
DX <- t(IB.inv %*% ALPHA) %x% (LAMBDA %*% IB.inv) |
| 2490 |
# this is not really needed (because we select idx=m.el.idx) |
|
| 2491 | 40x |
DX[, lav_matrix_diag_idx(nfac)] <- 0.0 |
| 2492 | 40x |
} else if (m == "alpha") {
|
| 2493 | 40x |
DX <- LAMBDA %*% IB.inv |
| 2494 |
} else {
|
|
| 2495 | ! |
lav_msg_stop(gettext("wrong model matrix names:"), m)
|
| 2496 |
} |
|
| 2497 | ||
| 2498 | 3772x |
DX <- DX[, idx, drop = FALSE] |
| 2499 | 3772x |
DX |
| 2500 |
} |
|
| 2501 | ||
| 2502 |
# dTh/dx -- per model matrix |
|
| 2503 |
lav_lisrel_dth_dx <- function(MLIST = NULL, |
|
| 2504 |
m = "tau", |
|
| 2505 |
# all model matrix elements, or only a few? |
|
| 2506 |
idx = seq_len(length(MLIST[[m]])), |
|
| 2507 |
th.idx = NULL, |
|
| 2508 |
delta = TRUE) {
|
|
| 2509 | 19009x |
LAMBDA <- MLIST$lambda |
| 2510 | 19009x |
nvar <- nrow(LAMBDA) |
| 2511 | 19009x |
nfac <- ncol(LAMBDA) |
| 2512 | 19009x |
TAU <- MLIST$tau |
| 2513 | 19009x |
nth <- nrow(TAU) |
| 2514 | ||
| 2515 |
# missing alpha |
|
| 2516 | 19009x |
if (is.null(MLIST$alpha)) {
|
| 2517 | ! |
ALPHA <- matrix(0, nfac, 1L) |
| 2518 |
} else {
|
|
| 2519 | 19009x |
ALPHA <- MLIST$alpha |
| 2520 |
} |
|
| 2521 | ||
| 2522 |
# missing nu |
|
| 2523 | 19009x |
if (is.null(MLIST$nu)) {
|
| 2524 | ! |
NU <- matrix(0, nvar, 1L) |
| 2525 |
} else {
|
|
| 2526 | 19009x |
NU <- MLIST$nu |
| 2527 |
} |
|
| 2528 | ||
| 2529 |
# Delta? |
|
| 2530 | 19009x |
delta.flag <- FALSE |
| 2531 | 19009x |
if (delta && !is.null(MLIST$delta)) {
|
| 2532 | 19009x |
DELTA <- MLIST$delta |
| 2533 | 19009x |
delta.flag <- TRUE |
| 2534 |
} |
|
| 2535 | ||
| 2536 | 19009x |
if (is.null(th.idx)) {
|
| 2537 | ! |
th.idx <- seq_len(nth) |
| 2538 | ! |
nlev <- rep(1L, nvar) |
| 2539 | ! |
K_nu <- diag(nvar) |
| 2540 |
} else {
|
|
| 2541 | 19009x |
nlev <- tabulate(th.idx, nbins = nvar) |
| 2542 | 19009x |
nlev[nlev == 0L] <- 1L |
| 2543 | 19009x |
K_nu <- matrix(0, sum(nlev), nvar) |
| 2544 | 19009x |
K_nu[cbind(seq_len(sum(nlev)), rep(seq_len(nvar), times = nlev))] <- 1.0 |
| 2545 |
} |
|
| 2546 | ||
| 2547 |
# shortcut for empty matrices |
|
| 2548 | 19009x |
if (m == "gamma" || m == "psi" || m == "theta" || m == "gw" || |
| 2549 | 19009x |
m == "cov.x" || m == "mean.x") {
|
| 2550 | 8149x |
return(matrix(0.0, nrow = length(th.idx), ncol = length(idx))) |
| 2551 |
} |
|
| 2552 | ||
| 2553 |
# beta? |
|
| 2554 | 10860x |
if (!is.null(MLIST$ibeta.inv)) {
|
| 2555 | ! |
IB.inv <- MLIST$ibeta.inv |
| 2556 |
} else {
|
|
| 2557 | 10860x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 2558 |
} |
|
| 2559 | ||
| 2560 | 10860x |
if (m == "tau") {
|
| 2561 | 2719x |
DX <- matrix(0, nrow = length(th.idx), ncol = nth) |
| 2562 | 2719x |
DX[th.idx > 0L, ] <- diag(nth) |
| 2563 | 2719x |
if (delta.flag) {
|
| 2564 | 2719x |
DX <- DX * as.vector(K_nu %*% DELTA) |
| 2565 |
} |
|
| 2566 | 8141x |
} else if (m == "nu") {
|
| 2567 | 2711x |
DX <- (-1) * K_nu |
| 2568 | 2711x |
if (delta.flag) {
|
| 2569 | 2711x |
DX <- DX * as.vector(K_nu %*% DELTA) |
| 2570 |
} |
|
| 2571 | 5430x |
} else if (m == "lambda") {
|
| 2572 | 2711x |
DX <- (-1) * t(IB.inv %*% ALPHA) %x% diag(nvar) |
| 2573 | 2711x |
DX <- K_nu %*% DX |
| 2574 | 2711x |
if (delta.flag) {
|
| 2575 | 2711x |
DX <- DX * as.vector(K_nu %*% DELTA) |
| 2576 |
} |
|
| 2577 | 2719x |
} else if (m == "beta") {
|
| 2578 | 2711x |
DX <- (-1) * t(IB.inv %*% ALPHA) %x% (LAMBDA %*% IB.inv) |
| 2579 |
# this is not really needed (because we select idx=m.el.idx) |
|
| 2580 | 2711x |
DX[, lav_matrix_diag_idx(nfac)] <- 0.0 |
| 2581 | 2711x |
DX <- K_nu %*% DX |
| 2582 | 2711x |
if (delta.flag) {
|
| 2583 | 2711x |
DX <- DX * as.vector(K_nu %*% DELTA) |
| 2584 |
} |
|
| 2585 | 8x |
} else if (m == "alpha") {
|
| 2586 | 8x |
DX <- (-1) * LAMBDA %*% IB.inv |
| 2587 | 8x |
DX <- K_nu %*% DX |
| 2588 | 8x |
if (delta.flag) {
|
| 2589 | 8x |
DX <- DX * as.vector(K_nu %*% DELTA) |
| 2590 |
} |
|
| 2591 | ! |
} else if (m == "delta") {
|
| 2592 | ! |
DX1 <- matrix(0, nrow = length(th.idx), ncol = 1) |
| 2593 | ! |
DX1[th.idx > 0L, ] <- TAU |
| 2594 | ! |
DX2 <- NU + LAMBDA %*% IB.inv %*% ALPHA |
| 2595 | ! |
DX2 <- K_nu %*% DX2 |
| 2596 | ! |
DX <- K_nu * as.vector(DX1 - DX2) |
| 2597 |
} else {
|
|
| 2598 | ! |
lav_msg_stop(gettext("wrong model matrix names:"), m)
|
| 2599 |
} |
|
| 2600 | ||
| 2601 | 10860x |
DX <- DX[, idx, drop = FALSE] |
| 2602 | 10860x |
DX |
| 2603 |
} |
|
| 2604 | ||
| 2605 |
# dPi/dx -- per model matrix |
|
| 2606 |
lav_lisrel_dpi_dx <- function(MLIST = NULL, |
|
| 2607 |
m = "lambda", |
|
| 2608 |
# all model matrix elements, or only a few? |
|
| 2609 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2610 | 19009x |
LAMBDA <- MLIST$lambda |
| 2611 | 19009x |
nvar <- nrow(LAMBDA) |
| 2612 | 19009x |
nfac <- ncol(LAMBDA) |
| 2613 | 19009x |
GAMMA <- MLIST$gamma |
| 2614 | 19009x |
nexo <- ncol(GAMMA) |
| 2615 | ||
| 2616 |
# Delta? |
|
| 2617 | 19009x |
delta.flag <- FALSE |
| 2618 | 19009x |
if (!is.null(MLIST$delta)) {
|
| 2619 | 19009x |
DELTA.diag <- MLIST$delta[, 1L] |
| 2620 | 19009x |
delta.flag <- TRUE |
| 2621 |
} |
|
| 2622 | ||
| 2623 |
# shortcut for empty matrices |
|
| 2624 | 19009x |
if (m == "tau" || m == "nu" || m == "alpha" || m == "psi" || |
| 2625 | 19009x |
m == "theta" || m == "gw" || m == "cov.x" || m == "mean.x") {
|
| 2626 | 10868x |
return(matrix(0.0, nrow = nvar * nexo, ncol = length(idx))) |
| 2627 |
} |
|
| 2628 | ||
| 2629 |
# beta? |
|
| 2630 | 8141x |
if (!is.null(MLIST$ibeta.inv)) {
|
| 2631 | ! |
IB.inv <- MLIST$ibeta.inv |
| 2632 |
} else {
|
|
| 2633 | 8141x |
IB.inv <- lav_lisrel_ibinv(MLIST = MLIST) |
| 2634 |
} |
|
| 2635 | ||
| 2636 | 8141x |
if (m == "lambda") {
|
| 2637 | 2711x |
DX <- t(IB.inv %*% GAMMA) %x% diag(nvar) |
| 2638 | 2711x |
if (delta.flag) {
|
| 2639 | 2711x |
DX <- DX * DELTA.diag |
| 2640 |
} |
|
| 2641 | 5430x |
} else if (m == "beta") {
|
| 2642 | 2711x |
DX <- t(IB.inv %*% GAMMA) %x% (LAMBDA %*% IB.inv) |
| 2643 |
# this is not really needed (because we select idx=m.el.idx) |
|
| 2644 | 2711x |
DX[, lav_matrix_diag_idx(nfac)] <- 0.0 |
| 2645 | 2711x |
if (delta.flag) {
|
| 2646 | 2711x |
DX <- DX * DELTA.diag |
| 2647 |
} |
|
| 2648 | 2719x |
} else if (m == "gamma") {
|
| 2649 | 2719x |
DX <- diag(nexo) %x% (LAMBDA %*% IB.inv) |
| 2650 | 2719x |
if (delta.flag) {
|
| 2651 | 2719x |
DX <- DX * DELTA.diag |
| 2652 |
} |
|
| 2653 | ! |
} else if (m == "delta") {
|
| 2654 | ! |
PRE <- rep(1, nexo) %x% diag(nvar) |
| 2655 | ! |
DX <- PRE * as.vector(LAMBDA %*% IB.inv %*% GAMMA) |
| 2656 |
} else {
|
|
| 2657 | ! |
lav_msg_stop(gettext("wrong model matrix names:"), m)
|
| 2658 |
} |
|
| 2659 | ||
| 2660 | 8141x |
DX <- DX[, idx, drop = FALSE] |
| 2661 | 8141x |
DX |
| 2662 |
} |
|
| 2663 | ||
| 2664 |
# dGW/dx -- per model matrix |
|
| 2665 |
lav_lisrel_dgw_dx <- function(MLIST = NULL, |
|
| 2666 |
m = "gw", |
|
| 2667 |
# all model matrix elements, or only a few? |
|
| 2668 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2669 |
# shortcut for empty matrices |
|
| 2670 | ! |
if (m != "gw") {
|
| 2671 | ! |
return(matrix(0.0, nrow = 1L, ncol = length(idx))) |
| 2672 |
} else {
|
|
| 2673 |
# m == "gw" |
|
| 2674 | ! |
DX <- matrix(1.0, 1, 1) |
| 2675 |
} |
|
| 2676 | ||
| 2677 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2678 | ! |
DX |
| 2679 |
} |
|
| 2680 | ||
| 2681 |
# dlambda/dx -- per model matrix |
|
| 2682 |
lav_lisrel_dlambda_dx <- function(MLIST = NULL, |
|
| 2683 |
m = "lambda", |
|
| 2684 |
# all model matrix elements, or only a few? |
|
| 2685 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2686 | ! |
LAMBDA <- MLIST$lambda |
| 2687 | ||
| 2688 |
# shortcut for empty matrices |
|
| 2689 | ! |
if (m != "lambda") {
|
| 2690 | ! |
return(matrix(0.0, nrow = length(LAMBDA), ncol = length(idx))) |
| 2691 |
} else {
|
|
| 2692 |
# m == "lambda" |
|
| 2693 | ! |
DX <- diag(1, nrow = length(LAMBDA), ncol = length(LAMBDA)) |
| 2694 |
} |
|
| 2695 | ||
| 2696 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2697 | ! |
DX |
| 2698 |
} |
|
| 2699 | ||
| 2700 |
# dpsi/dx -- per model matrix - FIXME!!!!! |
|
| 2701 |
lav_lisrel_dpsi_dx <- function(MLIST = NULL, |
|
| 2702 |
m = "psi", |
|
| 2703 |
# all model matrix elements, or only a few? |
|
| 2704 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2705 | ! |
PSI <- MLIST$psi |
| 2706 | ! |
nfac <- nrow(PSI) |
| 2707 | ! |
v.idx <- lav_matrix_vech_idx(nfac) |
| 2708 | ||
| 2709 |
# shortcut for empty matrices |
|
| 2710 | ! |
if (m != "psi") {
|
| 2711 | ! |
DX <- matrix(0.0, nrow = length(PSI), ncol = length(idx)) |
| 2712 | ! |
return(DX[v.idx, , drop = FALSE]) |
| 2713 |
} else {
|
|
| 2714 |
# m == "psi" |
|
| 2715 | ! |
DX <- diag(1, nrow = length(PSI), ncol = length(PSI)) |
| 2716 |
} |
|
| 2717 | ||
| 2718 | ! |
DX <- DX[v.idx, idx, drop = FALSE] |
| 2719 | ! |
DX |
| 2720 |
} |
|
| 2721 | ||
| 2722 |
# dtheta/dx -- per model matrix |
|
| 2723 |
lav_lisrel_dtheta_dx <- function(MLIST = NULL, |
|
| 2724 |
m = "theta", |
|
| 2725 |
# all model matrix elements, or only a few? |
|
| 2726 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2727 | ! |
THETA <- MLIST$theta |
| 2728 | ! |
nvar <- nrow(THETA) |
| 2729 | ! |
v.idx <- lav_matrix_vech_idx(nvar) |
| 2730 | ||
| 2731 |
# shortcut for empty matrices |
|
| 2732 | ! |
if (m != "theta") {
|
| 2733 | ! |
DX <- matrix(0.0, nrow = length(THETA), ncol = length(idx)) |
| 2734 | ! |
return(DX[v.idx, , drop = FALSE]) |
| 2735 |
} else {
|
|
| 2736 |
# m == "theta" |
|
| 2737 | ! |
DX <- diag(1, nrow = length(THETA), ncol = length(THETA)) |
| 2738 |
} |
|
| 2739 | ||
| 2740 | ! |
DX <- DX[v.idx, idx, drop = FALSE] |
| 2741 | ! |
DX |
| 2742 |
} |
|
| 2743 | ||
| 2744 | ||
| 2745 |
# dbeta/dx -- per model matrix |
|
| 2746 |
lav_lisrel_dbeta_dx <- function(MLIST = NULL, |
|
| 2747 |
m = "beta", |
|
| 2748 |
# all model matrix elements, or only a few? |
|
| 2749 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2750 | ! |
BETA <- MLIST$beta |
| 2751 | ||
| 2752 |
# shortcut for empty matrices |
|
| 2753 | ! |
if (m != "beta") {
|
| 2754 | ! |
return(matrix(0.0, nrow = length(BETA), ncol = length(idx))) |
| 2755 |
} else {
|
|
| 2756 |
# m == "beta" |
|
| 2757 | ! |
DX <- diag(1, nrow = length(BETA), ncol = length(BETA)) |
| 2758 |
} |
|
| 2759 | ||
| 2760 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2761 | ! |
DX |
| 2762 |
} |
|
| 2763 | ||
| 2764 |
# dgamma/dx -- per model matrix |
|
| 2765 |
lav_lisrel_dgamma_dx <- function(MLIST = NULL, |
|
| 2766 |
m = "gamma", |
|
| 2767 |
# all model matrix elements, or only a few? |
|
| 2768 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2769 | ! |
GAMMA <- MLIST$gamma |
| 2770 | ||
| 2771 |
# shortcut for empty matrices |
|
| 2772 | ! |
if (m != "gamma") {
|
| 2773 | ! |
return(matrix(0.0, nrow = length(GAMMA), ncol = length(idx))) |
| 2774 |
} else {
|
|
| 2775 |
# m == "gamma" |
|
| 2776 | ! |
DX <- diag(1, nrow = length(GAMMA), ncol = length(GAMMA)) |
| 2777 |
} |
|
| 2778 | ||
| 2779 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2780 | ! |
DX |
| 2781 |
} |
|
| 2782 | ||
| 2783 |
# dnu/dx -- per model matrix |
|
| 2784 |
lav_lisrel_dnu_dx <- function(MLIST = NULL, |
|
| 2785 |
m = "nu", |
|
| 2786 |
# all model matrix elements, or only a few? |
|
| 2787 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2788 | ! |
NU <- MLIST$nu |
| 2789 | ||
| 2790 |
# shortcut for empty matrices |
|
| 2791 | ! |
if (m != "nu") {
|
| 2792 | ! |
return(matrix(0.0, nrow = length(NU), ncol = length(idx))) |
| 2793 |
} else {
|
|
| 2794 |
# m == "nu" |
|
| 2795 | ! |
DX <- diag(1, nrow = length(NU), ncol = length(NU)) |
| 2796 |
} |
|
| 2797 | ||
| 2798 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2799 | ! |
DX |
| 2800 |
} |
|
| 2801 | ||
| 2802 |
# dtau/dx -- per model matrix |
|
| 2803 |
lav_lisrel_dtau_dx <- function(MLIST = NULL, |
|
| 2804 |
m = "tau", |
|
| 2805 |
# all model matrix elements, or only a few? |
|
| 2806 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2807 | ! |
TAU <- MLIST$tau |
| 2808 | ||
| 2809 |
# shortcut for empty matrices |
|
| 2810 | ! |
if (m != "tau") {
|
| 2811 | ! |
return(matrix(0.0, nrow = length(TAU), ncol = length(idx))) |
| 2812 |
} else {
|
|
| 2813 |
# m == "tau" |
|
| 2814 | ! |
DX <- diag(1, nrow = length(TAU), ncol = length(TAU)) |
| 2815 |
} |
|
| 2816 | ||
| 2817 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2818 | ! |
DX |
| 2819 |
} |
|
| 2820 | ||
| 2821 | ||
| 2822 | ||
| 2823 |
# dalpha/dx -- per model matrix |
|
| 2824 |
lav_lisrel_dalpha_dx <- function(MLIST = NULL, |
|
| 2825 |
m = "alpha", |
|
| 2826 |
# all model matrix elements, or only a few? |
|
| 2827 |
idx = seq_len(length(MLIST[[m]]))) {
|
|
| 2828 | ! |
ALPHA <- MLIST$alpha |
| 2829 | ||
| 2830 |
# shortcut for empty matrices |
|
| 2831 | ! |
if (m != "alpha") {
|
| 2832 | ! |
return(matrix(0.0, nrow = length(ALPHA), ncol = length(idx))) |
| 2833 |
} else {
|
|
| 2834 |
# m == "alpha" |
|
| 2835 | ! |
DX <- diag(1, nrow = length(ALPHA), ncol = length(ALPHA)) |
| 2836 |
} |
|
| 2837 | ||
| 2838 | ! |
DX <- DX[, idx, drop = FALSE] |
| 2839 | ! |
DX |
| 2840 |
} |
|
| 2841 | ||
| 2842 |
# MLIST = NULL; meanstructure=TRUE; th=TRUE; delta=TRUE; pi=TRUE; gw=FALSE |
|
| 2843 |
# lav_matrix_vech_idx <- lavaan:::lav_matrix_vech_idx; lav_matrix_vechru_idx <- lavaan:::lav_matrix_vechru_idx |
|
| 2844 |
# vec <- lavaan:::vec; lav_func_jacobian_complex <- lavaan:::lav_func_jacobian_complex |
|
| 2845 |
# lav_lisrel_sigma <- lavaan:::lav_lisrel_sigma |
|
| 2846 |
# lav_lisrel_delta <- lavaan:::lav_lisrel_delta |
|
| 2847 |
lav_lisrel_test_derivatives <- function(MLIST = NULL, |
|
| 2848 |
nvar = NULL, nfac = NULL, nexo = NULL, |
|
| 2849 |
th.idx = NULL, num.idx = NULL, |
|
| 2850 |
meanstructure = TRUE, |
|
| 2851 |
th = TRUE, delta = TRUE, pi = TRUE, |
|
| 2852 |
gw = FALSE, theta = FALSE) {
|
|
| 2853 | ! |
if (is.null(MLIST)) {
|
| 2854 |
# create artificial matrices, compare 'numerical' vs 'analytical' |
|
| 2855 |
# derivatives |
|
| 2856 |
# nvar <- 12; nfac <- 3; nexo <- 4 # this combination is special? |
|
| 2857 | ! |
if (is.null(nvar)) {
|
| 2858 | ! |
nvar <- 20 |
| 2859 |
} |
|
| 2860 | ! |
if (is.null(nfac)) {
|
| 2861 | ! |
nfac <- 6 |
| 2862 |
} |
|
| 2863 | ! |
if (is.null(nexo)) {
|
| 2864 | ! |
nexo <- 5 |
| 2865 |
} |
|
| 2866 | ! |
if (is.null(num.idx)) {
|
| 2867 | ! |
num.idx <- sort(sample(seq_len(nvar), ceiling(nvar / 2))) |
| 2868 |
} |
|
| 2869 | ! |
if (is.null(th.idx)) {
|
| 2870 | ! |
th.idx <- integer(0L) |
| 2871 | ! |
for (i in seq_len(nvar)) {
|
| 2872 | ! |
if (i %in% num.idx) {
|
| 2873 | ! |
th.idx <- c(th.idx, 0) |
| 2874 |
} else {
|
|
| 2875 | ! |
th.idx <- c(th.idx, rep(i, sample(c(1, 1, 2, 6), 1L))) |
| 2876 |
} |
|
| 2877 |
} |
|
| 2878 |
} |
|
| 2879 | ! |
nth <- sum(th.idx > 0L) |
| 2880 | ||
| 2881 | ! |
MLIST <- list() |
| 2882 | ! |
MLIST$lambda <- matrix(0, nvar, nfac) |
| 2883 | ! |
MLIST$beta <- matrix(0, nfac, nfac) |
| 2884 | ! |
MLIST$theta <- matrix(0, nvar, nvar) |
| 2885 | ! |
MLIST$psi <- matrix(0, nfac, nfac) |
| 2886 | ! |
if (meanstructure) {
|
| 2887 | ! |
MLIST$alpha <- matrix(0, nfac, 1L) |
| 2888 | ! |
MLIST$nu <- matrix(0, nvar, 1L) |
| 2889 |
} |
|
| 2890 | ! |
if (th) MLIST$tau <- matrix(0, nth, 1L) |
| 2891 | ! |
if (delta) MLIST$delta <- matrix(0, nvar, 1L) |
| 2892 | ! |
MLIST$gamma <- matrix(0, nfac, nexo) |
| 2893 | ! |
if (gw) MLIST$gw <- matrix(0, 1L, 1L) |
| 2894 | ||
| 2895 |
# feed random numbers |
|
| 2896 | ! |
MLIST <- lapply(MLIST, function(x) {
|
| 2897 | ! |
x[, ] <- rnorm(length(x)) |
| 2898 | ! |
x |
| 2899 |
}) |
|
| 2900 |
# fix |
|
| 2901 | ! |
diag(MLIST$beta) <- 0.0 |
| 2902 | ! |
diag(MLIST$theta) <- diag(MLIST$theta) * diag(MLIST$theta) * 10 |
| 2903 | ! |
diag(MLIST$psi) <- diag(MLIST$psi) * diag(MLIST$psi) * 10 |
| 2904 | ! |
MLIST$psi[lav_matrix_vechru_idx(nfac)] <- |
| 2905 | ! |
MLIST$psi[lav_matrix_vech_idx(nfac)] |
| 2906 | ! |
MLIST$theta[lav_matrix_vechru_idx(nvar)] <- |
| 2907 | ! |
MLIST$theta[lav_matrix_vech_idx(nvar)] |
| 2908 | ! |
if (delta) MLIST$delta[, ] <- abs(MLIST$delta) * 10 |
| 2909 |
} else {
|
|
| 2910 | ! |
nvar <- nrow(MLIST$lambda) |
| 2911 |
} |
|
| 2912 | ||
| 2913 | ! |
compute.sigma <- function(x, mm = "lambda", MLIST = NULL) {
|
| 2914 | ! |
mlist <- MLIST |
| 2915 | ! |
if (mm %in% c("psi", "theta")) {
|
| 2916 | ! |
mlist[[mm]] <- lav_matrix_vech_reverse(x) |
| 2917 |
} else {
|
|
| 2918 | ! |
mlist[[mm]][, ] <- x |
| 2919 |
} |
|
| 2920 | ! |
if (theta) {
|
| 2921 | ! |
mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx) |
| 2922 |
} |
|
| 2923 | ! |
lav_matrix_vech(lav_lisrel_sigma(mlist)) |
| 2924 |
} |
|
| 2925 | ||
| 2926 | ! |
compute.mu <- function(x, mm = "lambda", MLIST = NULL) {
|
| 2927 | ! |
mlist <- MLIST |
| 2928 | ! |
if (mm %in% c("psi", "theta")) {
|
| 2929 | ! |
mlist[[mm]] <- lav_matrix_vech_reverse(x) |
| 2930 |
} else {
|
|
| 2931 | ! |
mlist[[mm]][, ] <- x |
| 2932 |
} |
|
| 2933 | ! |
if (theta) {
|
| 2934 | ! |
mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx) |
| 2935 |
} |
|
| 2936 | ! |
lav_lisrel_mu(mlist) |
| 2937 |
} |
|
| 2938 | ||
| 2939 | ! |
compute.th2 <- function(x, mm = "tau", MLIST = NULL, th.idx) {
|
| 2940 | ! |
mlist <- MLIST |
| 2941 | ! |
if (mm %in% c("psi", "theta")) {
|
| 2942 | ! |
mlist[[mm]] <- lav_matrix_vech_reverse(x) |
| 2943 |
} else {
|
|
| 2944 | ! |
mlist[[mm]][, ] <- x |
| 2945 |
} |
|
| 2946 | ! |
if (theta) {
|
| 2947 | ! |
mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx) |
| 2948 |
} |
|
| 2949 | ! |
lav_lisrel_th(mlist, th.idx = th.idx) |
| 2950 |
} |
|
| 2951 | ||
| 2952 | ! |
compute.pi <- function(x, mm = "lambda", MLIST = NULL) {
|
| 2953 | ! |
mlist <- MLIST |
| 2954 | ! |
if (mm %in% c("psi", "theta")) {
|
| 2955 | ! |
mlist[[mm]] <- lav_matrix_vech_reverse(x) |
| 2956 |
} else {
|
|
| 2957 | ! |
mlist[[mm]][, ] <- x |
| 2958 |
} |
|
| 2959 | ! |
if (theta) {
|
| 2960 | ! |
mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx) |
| 2961 |
} |
|
| 2962 | ! |
lav_lisrel_pi(mlist) |
| 2963 |
} |
|
| 2964 | ||
| 2965 | ! |
compute.gw <- function(x, mm = "gw", MLIST = NULL) {
|
| 2966 | ! |
mlist <- MLIST |
| 2967 | ! |
if (mm %in% c("psi", "theta")) {
|
| 2968 | ! |
mlist[[mm]] <- lav_matrix_vech_reverse(x) |
| 2969 |
} else {
|
|
| 2970 | ! |
mlist[[mm]][, ] <- x |
| 2971 |
} |
|
| 2972 | ! |
if (theta) {
|
| 2973 | ! |
mlist <- lav_lisrel_delta(MLIST = mlist, num.idx = num.idx) |
| 2974 |
} |
|
| 2975 | ! |
mlist$gw[1, 1] |
| 2976 |
} |
|
| 2977 | ||
| 2978 |
# if theta, set MLIST$delta |
|
| 2979 | ! |
if (theta) {
|
| 2980 | ! |
MLIST <- lav_lisrel_delta(MLIST = MLIST, num.idx = num.idx) |
| 2981 |
} |
|
| 2982 | ||
| 2983 | ! |
for (mm in names(MLIST)) {
|
| 2984 | ! |
if (mm %in% c("psi", "theta")) {
|
| 2985 | ! |
x <- lav_matrix_vech(MLIST[[mm]]) |
| 2986 |
} else {
|
|
| 2987 | ! |
x <- lav_matrix_vec(MLIST[[mm]]) |
| 2988 |
} |
|
| 2989 | ! |
if (mm == "delta" && theta) next |
| 2990 | ! |
if (lav_debug()) {
|
| 2991 | ! |
cat("### mm = ", mm, "\n")
|
| 2992 |
} |
|
| 2993 | ||
| 2994 |
# 1. sigma |
|
| 2995 | ! |
DX1 <- lav_func_jacobian_complex(func = compute.sigma, x = x, mm = mm, MLIST = MLIST) |
| 2996 | ! |
DX2 <- lav_lisrel_dsigma_dx( |
| 2997 | ! |
MLIST = MLIST, m = mm, idx = seq_len(length(MLIST[[mm]])), |
| 2998 | ! |
delta = !theta |
| 2999 |
) |
|
| 3000 | ! |
if (mm %in% c("psi", "theta")) {
|
| 3001 |
# remove duplicated columns of symmetric matrices |
|
| 3002 | ! |
idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) |
| 3003 | ! |
if (length(idx) > 0L) DX2 <- DX2[, -idx] |
| 3004 |
} |
|
| 3005 | ! |
if (theta) {
|
| 3006 | ! |
sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE) |
| 3007 | ! |
R <- lav_deriv_cov2cor(sigma.hat, num.idx = num.idx) |
| 3008 | ||
| 3009 | ! |
DX3 <- DX2 |
| 3010 | ! |
DX2 <- R %*% DX2 |
| 3011 |
} |
|
| 3012 | ! |
if (lav_debug()) {
|
| 3013 | ! |
cat("[SIGMA] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
|
| 3014 | ! |
print(zapsmall(DX1)) |
| 3015 | ! |
cat("\n")
|
| 3016 | ! |
cat("[SIGMA] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
|
| 3017 | ! |
print(DX2) |
| 3018 | ! |
cat("\n")
|
| 3019 | ! |
if (theta) {
|
| 3020 | ! |
cat("[SIGMA] mm = ", sprintf("%-8s:", mm), "DX3 (analytical):\n")
|
| 3021 | ! |
print(DX3) |
| 3022 | ! |
cat("\n")
|
| 3023 |
} |
|
| 3024 |
} |
|
| 3025 | ! |
cat( |
| 3026 | ! |
"[SIGMA] mm = ", sprintf("%-8s:", mm), "sum delta = ",
|
| 3027 | ! |
sprintf("%12.9f", sum(DX1 - DX2)), " max delta = ",
|
| 3028 | ! |
sprintf("%12.9f", max(DX1 - DX2)), "\n"
|
| 3029 |
) |
|
| 3030 | ||
| 3031 |
# 2. mu |
|
| 3032 | ! |
DX1 <- lav_func_jacobian_complex(func = compute.mu, x = x, mm = mm, MLIST = MLIST) |
| 3033 | ! |
DX2 <- lav_lisrel_dmu_dx( |
| 3034 | ! |
MLIST = MLIST, |
| 3035 | ! |
m = mm, idx = seq_len(length(MLIST[[mm]])) |
| 3036 |
) |
|
| 3037 | ! |
if (mm %in% c("psi", "theta")) {
|
| 3038 |
# remove duplicated columns of symmetric matrices |
|
| 3039 | ! |
idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) |
| 3040 | ! |
if (length(idx) > 0L) DX2 <- DX2[, -idx] |
| 3041 |
} |
|
| 3042 | ! |
cat( |
| 3043 | ! |
"[MU ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
|
| 3044 | ! |
sprintf("%12.9f", sum(DX1 - DX2)), " max delta = ",
|
| 3045 | ! |
sprintf("%12.9f", max(DX1 - DX2)), "\n"
|
| 3046 |
) |
|
| 3047 | ! |
if (lav_debug()) {
|
| 3048 | ! |
cat("[MU ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
|
| 3049 | ! |
print(zapsmall(DX1)) |
| 3050 | ! |
cat("\n")
|
| 3051 | ! |
cat("[MU ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
|
| 3052 | ! |
print(DX2) |
| 3053 | ! |
cat("\n")
|
| 3054 |
} |
|
| 3055 | ||
| 3056 |
# 3. th |
|
| 3057 | ! |
if (th) {
|
| 3058 | ! |
DX1 <- lav_func_jacobian_complex( |
| 3059 | ! |
func = compute.th2, x = x, mm = mm, MLIST = MLIST, |
| 3060 | ! |
th.idx = th.idx |
| 3061 |
) |
|
| 3062 | ! |
DX2 <- lav_lisrel_dth_dx( |
| 3063 | ! |
MLIST = MLIST, m = mm, idx = seq_len(length(MLIST[[mm]])), |
| 3064 | ! |
th.idx = th.idx, |
| 3065 | ! |
delta = TRUE |
| 3066 |
) |
|
| 3067 | ! |
if (theta) {
|
| 3068 |
# 1. compute dDelta.dx |
|
| 3069 | ! |
dxSigma <- |
| 3070 | ! |
lav_lisrel_dsigma_dx( |
| 3071 | ! |
m = mm, idx = seq_len(length(MLIST[[mm]])), |
| 3072 | ! |
MLIST = MLIST, delta = !theta |
| 3073 |
) |
|
| 3074 | ! |
var.idx <- which(!lav_matrix_vech_idx(nvar) %in% |
| 3075 | ! |
lav_matrix_vech_idx(nvar, diagonal = FALSE)) |
| 3076 | ! |
sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE) |
| 3077 | ! |
dsigma <- diag(sigma.hat) |
| 3078 |
# dy/ddsigma = -0.5/(ddsigma*sqrt(ddsigma)) |
|
| 3079 | ! |
dDelta.dx <- dxSigma[var.idx, ] * -0.5 / (dsigma * sqrt(dsigma)) |
| 3080 | ||
| 3081 |
# 2. compute dth.dDelta |
|
| 3082 | ! |
dth.dDelta <- |
| 3083 | ! |
lav_lisrel_dth_dx( |
| 3084 | ! |
MLIST = MLIST, |
| 3085 | ! |
m = "delta", |
| 3086 | ! |
idx = seq_len(length(MLIST[["delta"]])), |
| 3087 | ! |
th.idx = th.idx |
| 3088 |
) |
|
| 3089 | ||
| 3090 |
# 3. add dth.dDelta %*% dDelta.dx |
|
| 3091 | ! |
no.num.idx <- which(th.idx > 0) |
| 3092 | ! |
DX2[no.num.idx, ] <- DX2[no.num.idx, , drop = FALSE] + |
| 3093 | ! |
(dth.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE] |
| 3094 |
# DX2 <- DX2 + dth.dDelta %*% dDelta.dx |
|
| 3095 |
} |
|
| 3096 | ! |
if (mm %in% c("psi", "theta")) {
|
| 3097 |
# remove duplicated columns of symmetric matrices |
|
| 3098 | ! |
idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) |
| 3099 | ! |
if (length(idx) > 0L) DX2 <- DX2[, -idx] |
| 3100 |
} |
|
| 3101 | ! |
cat( |
| 3102 | ! |
"[TH ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
|
| 3103 | ! |
sprintf("%12.9f", sum(DX1 - DX2)), " max delta = ",
|
| 3104 | ! |
sprintf("%12.9f", max(DX1 - DX2)), "\n"
|
| 3105 |
) |
|
| 3106 | ! |
if (lav_debug()) {
|
| 3107 | ! |
cat("[TH ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
|
| 3108 | ! |
print(zapsmall(DX1)) |
| 3109 | ! |
cat("\n")
|
| 3110 | ! |
cat("[TH ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
|
| 3111 | ! |
print(DX2) |
| 3112 | ! |
cat("\n")
|
| 3113 |
} |
|
| 3114 |
} |
|
| 3115 | ||
| 3116 |
# 4. pi |
|
| 3117 | ! |
if (pi) {
|
| 3118 | ! |
DX1 <- lav_func_jacobian_complex(func = compute.pi, x = x, mm = mm, MLIST = MLIST) |
| 3119 | ! |
DX2 <- lav_lisrel_dpi_dx( |
| 3120 | ! |
MLIST = MLIST, |
| 3121 | ! |
m = mm, idx = seq_len(length(MLIST[[mm]])) |
| 3122 |
) |
|
| 3123 | ! |
if (mm %in% c("psi", "theta")) {
|
| 3124 |
# remove duplicated columns of symmetric matrices |
|
| 3125 | ! |
idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) |
| 3126 | ! |
if (length(idx) > 0L) DX2 <- DX2[, -idx] |
| 3127 |
} |
|
| 3128 | ! |
if (theta) {
|
| 3129 |
# 1. compute dDelta.dx |
|
| 3130 | ! |
dxSigma <- |
| 3131 | ! |
lav_lisrel_dsigma_dx( |
| 3132 | ! |
MLIST = MLIST, m = mm, idx = seq_len(length(MLIST[[mm]])), |
| 3133 | ! |
delta = !theta |
| 3134 |
) |
|
| 3135 | ! |
if (mm %in% c("psi", "theta")) {
|
| 3136 |
# remove duplicated columns of symmetric matrices |
|
| 3137 | ! |
idx <- lav_matrix_vechru_idx(sqrt(ncol(dxSigma)), diagonal = FALSE) |
| 3138 | ! |
if (length(idx) > 0L) dxSigma <- dxSigma[, -idx] |
| 3139 |
} |
|
| 3140 | ! |
var.idx <- which(!lav_matrix_vech_idx(nvar) %in% |
| 3141 | ! |
lav_matrix_vech_idx(nvar, diagonal = FALSE)) |
| 3142 | ! |
sigma.hat <- lav_lisrel_sigma(MLIST = MLIST, delta = FALSE) |
| 3143 | ! |
dsigma <- diag(sigma.hat) |
| 3144 |
# dy/ddsigma = -0.5/(ddsigma*sqrt(ddsigma)) |
|
| 3145 | ! |
dDelta.dx <- dxSigma[var.idx, ] * -0.5 / (dsigma * sqrt(dsigma)) |
| 3146 | ||
| 3147 |
# 2. compute dpi.dDelta |
|
| 3148 | ! |
dpi.dDelta <- |
| 3149 | ! |
lav_lisrel_dpi_dx( |
| 3150 | ! |
MLIST = MLIST, |
| 3151 | ! |
m = "delta", |
| 3152 | ! |
idx = seq_len(length(MLIST[["delta"]])) |
| 3153 |
) |
|
| 3154 | ||
| 3155 |
# 3. add dpi.dDelta %*% dDelta.dx |
|
| 3156 | ! |
no.num.idx <- which(!seq.int(1L, nvar) %in% num.idx) |
| 3157 | ! |
no.num.idx <- rep(seq.int(0, nexo - 1) * nvar, |
| 3158 | ! |
each = length(no.num.idx) |
| 3159 | ! |
) + no.num.idx |
| 3160 | ! |
DX2[no.num.idx, ] <- DX2[no.num.idx, , drop = FALSE] + |
| 3161 | ! |
(dpi.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE] |
| 3162 |
} |
|
| 3163 | ! |
cat( |
| 3164 | ! |
"[PI ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
|
| 3165 | ! |
sprintf("%12.9f", sum(DX1 - DX2)), " max delta = ",
|
| 3166 | ! |
sprintf("%12.9f", max(DX1 - DX2)), "\n"
|
| 3167 |
) |
|
| 3168 | ! |
if (lav_debug()) {
|
| 3169 | ! |
cat("[PI ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
|
| 3170 | ! |
print(zapsmall(DX1)) |
| 3171 | ! |
cat("\n")
|
| 3172 | ! |
cat("[PI ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
|
| 3173 | ! |
print(DX2) |
| 3174 | ! |
cat("\n")
|
| 3175 |
} |
|
| 3176 |
} |
|
| 3177 | ||
| 3178 |
# 5. gw |
|
| 3179 | ! |
if (gw) {
|
| 3180 | ! |
DX1 <- lav_func_jacobian_complex(func = compute.gw, x = x, mm = mm, MLIST = MLIST) |
| 3181 | ! |
DX2 <- lav_lisrel_dgw_dx( |
| 3182 | ! |
MLIST = MLIST, |
| 3183 | ! |
m = mm, idx = seq_len(length(MLIST[[mm]])) |
| 3184 |
) |
|
| 3185 | ! |
if (mm %in% c("psi", "theta")) {
|
| 3186 |
# remove duplicated columns of symmetric matrices |
|
| 3187 | ! |
idx <- lav_matrix_vechru_idx(sqrt(ncol(DX2)), diagonal = FALSE) |
| 3188 | ! |
if (length(idx) > 0L) DX2 <- DX2[, -idx] |
| 3189 |
} |
|
| 3190 | ! |
cat( |
| 3191 | ! |
"[GW ] mm = ", sprintf("%-8s:", mm), "sum delta = ",
|
| 3192 | ! |
sprintf("%12.9f", sum(DX1 - DX2)), " max delta = ",
|
| 3193 | ! |
sprintf("%12.9f", max(DX1 - DX2)), "\n"
|
| 3194 |
) |
|
| 3195 | ! |
if (lav_debug()) {
|
| 3196 | ! |
cat("[GW ] mm = ", sprintf("%-8s:", mm), "DX1 (numerical):\n")
|
| 3197 | ! |
print(DX1) |
| 3198 | ! |
cat("\n\n")
|
| 3199 | ! |
cat("[GW ] mm = ", sprintf("%-8s:", mm), "DX2 (analytical):\n")
|
| 3200 | ! |
print(DX2) |
| 3201 | ! |
cat("\n\n")
|
| 3202 |
} |
|
| 3203 |
} |
|
| 3204 |
} |
|
| 3205 | ||
| 3206 | ! |
MLIST$th.idx <- th.idx |
| 3207 | ! |
MLIST$num.idx <- num.idx |
| 3208 | ||
| 3209 | ! |
MLIST |
| 3210 |
} |
|
| 3211 | ||
| 3212 |
# check for marker indicators: |
|
| 3213 |
# - if std.lv = FALSE: a single '1' per factor, everything else zero |
|
| 3214 |
# - if std.lv = TRUE: a single non-zero value per factor, everything else zero |
|
| 3215 |
lav_utils_get_marker <- function(LAMBDA = NULL, std.lv = FALSE) {
|
|
| 3216 | ! |
LAMBDA <- as.matrix(LAMBDA) |
| 3217 | ! |
nvar <- nrow(LAMBDA) |
| 3218 | ! |
nfac <- ncol(LAMBDA) |
| 3219 | ||
| 3220 |
# round values |
|
| 3221 | ! |
LAMBDA <- round(LAMBDA, 3L) |
| 3222 | ||
| 3223 | ! |
marker.idx <- numeric(nfac) |
| 3224 | ! |
for (f in seq_len(nfac)) {
|
| 3225 | ! |
if (std.lv) {
|
| 3226 | ! |
marker.idx[f] <- which(rowSums(cbind( |
| 3227 | ! |
LAMBDA[, f] != 0, |
| 3228 | ! |
LAMBDA[, -f] == 0 |
| 3229 | ! |
)) == nfac)[1] |
| 3230 |
} else {
|
|
| 3231 | ! |
marker.idx[f] <- which(rowSums(cbind( |
| 3232 | ! |
LAMBDA[, f] == 1, |
| 3233 | ! |
LAMBDA[, -f] == 0 |
| 3234 | ! |
)) == nfac)[1] |
| 3235 |
} |
|
| 3236 |
} |
|
| 3237 | ||
| 3238 | ! |
marker.idx |
| 3239 |
} |
|
| 3240 | ||
| 3241 |
# find the residual variances (diagonal element of PSI) in such a way |
|
| 3242 |
# so that the diagonal elements of IB.inv %*% PSI %*% t(IB.inv) are |
|
| 3243 |
# equal to the elements of target.psi (usually the 1 vector) |
|
| 3244 |
# |
|
| 3245 |
# YR 01 Nov 2024: initial version; no bounds for now... (so we may end up |
|
| 3246 |
# with negative variances) |
|
| 3247 |
lav_mlist_target_psi <- function(BETA = NULL, IB.inv = NULL, PSI = NULL, |
|
| 3248 |
target.psi = NULL, y.idx = NULL) {
|
|
| 3249 | ||
| 3250 | ! |
nr <- nrow(PSI) |
| 3251 | ||
| 3252 |
# IB.inv (if not given) |
|
| 3253 | ! |
if (is.null(IB.inv)) {
|
| 3254 | ! |
IB <- -BETA |
| 3255 | ! |
IB[lav_matrix_diag_idx(nr)] <- 1 |
| 3256 | ! |
IB.inv <- solve(IB) |
| 3257 |
} |
|
| 3258 | ||
| 3259 |
# target.psi |
|
| 3260 | ! |
if (is.null(target.psi)) {
|
| 3261 | ! |
target.psi <- rep(1, nr) |
| 3262 |
} |
|
| 3263 | ||
| 3264 |
# y.idx |
|
| 3265 | ! |
if (is.null(y.idx)) {
|
| 3266 | ! |
y.idx <- seq_len(nr) |
| 3267 |
} |
|
| 3268 | ||
| 3269 |
# cast the problem as a nonlinear optimization problem |
|
| 3270 | ! |
obj <- function(x) {
|
| 3271 |
#cat("x = ", x, "\n")
|
|
| 3272 |
# x are the diagonal elements of PSI |
|
| 3273 | ! |
this.PSI <- PSI |
| 3274 | ! |
diag(this.PSI)[y.idx] <- x |
| 3275 | ! |
VETA <- IB.inv %*% this.PSI %*% t(IB.inv) |
| 3276 | ! |
current.diag <- diag(VETA) |
| 3277 |
# ratio or difference? |
|
| 3278 | ! |
diff <- target.psi[y.idx] - current.diag[y.idx] |
| 3279 | ! |
out <- sum(diff * diff) # least squares |
| 3280 | ! |
out |
| 3281 |
} |
|
| 3282 | ||
| 3283 | ! |
VETA <- IB.inv %*% PSI %*% t(IB.inv) |
| 3284 | ! |
x.start <- diag(VETA)[y.idx] |
| 3285 | ! |
out <- nlminb(start = x.start, objective = obj) |
| 3286 | ||
| 3287 |
# return updated PSI matrix |
|
| 3288 | ! |
diag(PSI)[y.idx] <- out$par |
| 3289 | ! |
PSI |
| 3290 |
} |
|
| 3291 | ||
| 3292 |
# get 'test' |
|
| 3293 |
# make sure we return a single element |
|
| 3294 |
lav_utils_get_test <- function(lavobject) {
|
|
| 3295 | ! |
test <- lavobject@Options$test |
| 3296 |
# 0.6.5: for now, we make sure that 'test' is a single element |
|
| 3297 | ! |
if (length(test) > 1L) {
|
| 3298 | ! |
standard.idx <- which(test == "standard") |
| 3299 | ! |
if (length(standard.idx) > 0L) {
|
| 3300 | ! |
test <- test[-standard.idx] |
| 3301 |
} |
|
| 3302 | ! |
if (length(test) > 1L) {
|
| 3303 |
# only retain the first one |
|
| 3304 | ! |
test <- test[1] |
| 3305 |
} |
|
| 3306 |
} |
|
| 3307 | ||
| 3308 | ! |
test |
| 3309 |
} |
|
| 3310 |
| 1 |
# inspect a fitted lavaan object |
|
| 2 | ||
| 3 |
# backward compatibility -- wrapper around lavInspect |
|
| 4 |
lav_lavaan_inspect <- function(object, what = "free", ...) {
|
|
| 5 | ! |
dotdotdot <- list(...) |
| 6 | ! |
if (length(dotdotdot) > 0L) {
|
| 7 | ! |
for (j in seq_along(dotdotdot)) {
|
| 8 | ! |
lav_msg_warn(gettextf( |
| 9 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 10 | ! |
sQuote("inspect"))
|
| 11 |
) |
|
| 12 |
} |
|
| 13 |
} |
|
| 14 | ! |
lav_lavaan_lavinspect(object = object, |
| 15 | ! |
what = what, |
| 16 | ! |
add.labels = TRUE, |
| 17 | ! |
add.class = TRUE, |
| 18 | ! |
drop.list.single.group = TRUE) |
| 19 |
} |
|
| 20 | ||
| 21 |
# the `tech' version: no labels, full matrices, ... for further processing |
|
| 22 |
lav_lavaan_lavtech <- function(object, |
|
| 23 |
what = "free", |
|
| 24 |
add.labels = FALSE, |
|
| 25 |
add.class = FALSE, |
|
| 26 |
list.by.group = FALSE, |
|
| 27 |
drop.list.single.group = FALSE) {
|
|
| 28 | ||
| 29 | 212x |
lav_lavaan_lavinspect(object, what = what, |
| 30 | 212x |
add.labels = add.labels, add.class = add.class, |
| 31 | 212x |
list.by.group = list.by.group, |
| 32 | 212x |
drop.list.single.group = drop.list.single.group) |
| 33 |
} |
|
| 34 | ||
| 35 |
# the `user' version: with defaults for display only |
|
| 36 |
lav_lavaan_lavinspect <- function(object, # nolint |
|
| 37 |
what = "free", |
|
| 38 |
add.labels = TRUE, |
|
| 39 |
add.class = TRUE, |
|
| 40 |
list.by.group = TRUE, |
|
| 41 |
drop.list.single.group = TRUE) {
|
|
| 42 |
# object must inherit from class lavaan |
|
| 43 | 917x |
stopifnot(inherits(object, "lavaan")) |
| 44 | ||
| 45 |
# check object |
|
| 46 | 917x |
object <- lav_object_check_version(object) |
| 47 | ||
| 48 |
# store partable with pta in object to use cache in called functions |
|
| 49 | 917x |
object@ParTable <- lav_partable_set_cache(object@ParTable, object@pta) |
| 50 | ||
| 51 |
# only a single argument |
|
| 52 | 917x |
if (length(what) > 1) {
|
| 53 | ! |
lav_msg_stop(gettextf("argument %s cannot have more than one element",
|
| 54 | ! |
"what")) |
| 55 |
} |
|
| 56 | ||
| 57 |
# be case insensitive |
|
| 58 | 917x |
what <- tolower(what) |
| 59 | ||
| 60 |
#### model matrices, with different contents #### |
|
| 61 | 917x |
if (what == "free") {
|
| 62 | 20x |
lav_object_inspect_modelmatrices(object, what = "free", |
| 63 | 20x |
type = "free", add.labels = add.labels, add.class = add.class, |
| 64 | 20x |
list.by.group = list.by.group, |
| 65 | 20x |
drop.list.single.group = drop.list.single.group) |
| 66 | 897x |
} else if (what == "impute" || |
| 67 | 897x |
what == "imputed") { # just to ease the transition for semTools!
|
| 68 | ! |
object@imputed |
| 69 | 897x |
} else if (what == "partable" || what == "user") {
|
| 70 | 20x |
lav_object_inspect_modelmatrices(object, what = "free", |
| 71 | 20x |
type = "partable", add.labels = add.labels, add.class = add.class, |
| 72 | 20x |
list.by.group = list.by.group, |
| 73 | 20x |
drop.list.single.group = drop.list.single.group) |
| 74 | 877x |
} else if (what == "se" || |
| 75 | 877x |
what == "std.err" || |
| 76 | 877x |
what == "standard.errors") {
|
| 77 | 20x |
lav_object_inspect_modelmatrices(object, what = "se", |
| 78 | 20x |
add.labels = add.labels, add.class = add.class, |
| 79 | 20x |
list.by.group = list.by.group, |
| 80 | 20x |
drop.list.single.group = drop.list.single.group) |
| 81 | 857x |
} else if (what == "se.std" || |
| 82 | 857x |
what == "std.se") {
|
| 83 | 4x |
lav_object_inspect_modelmatrices(object, what = "std.se", |
| 84 | 4x |
add.labels = add.labels, add.class = add.class, |
| 85 | 4x |
list.by.group = list.by.group, |
| 86 | 4x |
drop.list.single.group = drop.list.single.group) |
| 87 | 853x |
} else if (what == "start" || what == "starting.values") {
|
| 88 | 20x |
lav_object_inspect_modelmatrices(object, what = "start", |
| 89 | 20x |
add.labels = add.labels, add.class = add.class, |
| 90 | 20x |
list.by.group = list.by.group, |
| 91 | 20x |
drop.list.single.group = drop.list.single.group) |
| 92 | 833x |
} else if (what == "est" || what == "estimates" || |
| 93 | 833x |
what == "x") {
|
| 94 | 20x |
lav_object_inspect_modelmatrices(object, what = "est", |
| 95 | 20x |
add.labels = add.labels, add.class = add.class, |
| 96 | 20x |
list.by.group = list.by.group, |
| 97 | 20x |
drop.list.single.group = drop.list.single.group) |
| 98 | 813x |
} else if (what == "est.unrotated") {
|
| 99 | ! |
lav_object_inspect_modelmatrices(object, what = "est.unrotated", |
| 100 | ! |
add.labels = add.labels, add.class = add.class, |
| 101 | ! |
list.by.group = list.by.group, |
| 102 | ! |
drop.list.single.group = drop.list.single.group) |
| 103 | 813x |
} else if (what == "dx.free") {
|
| 104 | 20x |
lav_object_inspect_modelmatrices(object, what = "dx.free", |
| 105 | 20x |
add.labels = add.labels, add.class = add.class, |
| 106 | 20x |
list.by.group = list.by.group, |
| 107 | 20x |
drop.list.single.group = drop.list.single.group) |
| 108 | 793x |
} else if (what == "dx.all") {
|
| 109 | ! |
lav_object_inspect_modelmatrices(object, what = "dx.all", |
| 110 | ! |
add.labels = add.labels, add.class = add.class, |
| 111 | ! |
list.by.group = list.by.group, |
| 112 | ! |
drop.list.single.group = drop.list.single.group) |
| 113 | 793x |
} else if (what == "std" || what == "std.all" || |
| 114 | 793x |
what == "est.std" || what == "std.est" || |
| 115 | 793x |
what == "standardized") {
|
| 116 | 28x |
lav_object_inspect_modelmatrices(object, what = "std.all", |
| 117 | 28x |
add.labels = add.labels, add.class = add.class, |
| 118 | 28x |
list.by.group = list.by.group, |
| 119 | 28x |
drop.list.single.group = drop.list.single.group) |
| 120 | 765x |
} else if (what == "std.lv") {
|
| 121 | 20x |
lav_object_inspect_modelmatrices(object, what = "std.lv", |
| 122 | 20x |
add.labels = add.labels, add.class = add.class, |
| 123 | 20x |
list.by.group = list.by.group, |
| 124 | 20x |
drop.list.single.group = drop.list.single.group) |
| 125 | 745x |
} else if (what == "std.nox") {
|
| 126 | 20x |
lav_object_inspect_modelmatrices(object, what = "std.nox", |
| 127 | 20x |
add.labels = add.labels, add.class = add.class, |
| 128 | 20x |
list.by.group = list.by.group, |
| 129 | 20x |
drop.list.single.group = drop.list.single.group) |
| 130 | ||
| 131 | ||
| 132 |
#### parameter table #### |
|
| 133 | 725x |
} else if (what == "list") {
|
| 134 | 29x |
parTable(object) |
| 135 | ||
| 136 |
#### bootstrap coef #### |
|
| 137 | 696x |
} else if (what %in% c("boot", "bootstrap", "boot.coef", "coef.boot")) {
|
| 138 | ! |
lav_object_inspect_boot(object, add.labels = add.labels, |
| 139 | ! |
add.class = add.class) |
| 140 | ||
| 141 |
#### fit indices #### |
|
| 142 | 696x |
} else if (what == "fit" || |
| 143 | 696x |
what == "fitmeasures" || |
| 144 | 696x |
what == "fit.measures" || |
| 145 | 696x |
what == "fit.indices") {
|
| 146 | ! |
fitMeasures(object) |
| 147 | ||
| 148 |
#### baseline model #### |
|
| 149 | 696x |
} else if (what == "baseline.partable") {
|
| 150 | ! |
out <- as.data.frame(object@baseline$partable, stringsAsFactors = FALSE) |
| 151 | ! |
if (add.class) {
|
| 152 | ! |
class(out) <- c("lavaan.data.frame", "data.frame")
|
| 153 |
} |
|
| 154 | ! |
return(out) |
| 155 | 696x |
} else if (what == "baseline.test") {
|
| 156 | ! |
object@baseline$test |
| 157 | ||
| 158 |
#### modification indices #### |
|
| 159 | 696x |
} else if (what == "mi" || |
| 160 | 696x |
what == "modindices" || |
| 161 | 696x |
what == "modification.indices") {
|
| 162 | ! |
modificationIndices(object) |
| 163 | ||
| 164 | ||
| 165 |
#### sample statistics ##### |
|
| 166 | 696x |
} else if (what == "obs" || |
| 167 | 696x |
what == "observed" || |
| 168 | 696x |
what == "sampstat" || |
| 169 | 696x |
what == "sampstats" || |
| 170 | 696x |
what == "samplestats" || |
| 171 | 696x |
what == "samp" || |
| 172 | 696x |
what == "sample" || |
| 173 | 696x |
what == "samplestatistics") {
|
| 174 |
# new in 0.6-3: always use h1 = TRUE!!! |
|
| 175 | 40x |
lav_object_inspect_sampstat(object, h1 = TRUE, std = FALSE, |
| 176 | 40x |
add.labels = add.labels, add.class = add.class, |
| 177 | 40x |
drop.list.single.group = drop.list.single.group) |
| 178 | 656x |
} else if (what == "obs.std" || |
| 179 | 656x |
what == "observed.std" || |
| 180 | 656x |
what == "sampstat.std" || |
| 181 | 656x |
what == "sampstats.std" || |
| 182 | 656x |
what == "samplestats.std" || |
| 183 | 656x |
what == "samp.std" || |
| 184 | 656x |
what == "sample.std" || |
| 185 | 656x |
what == "samplestatistics.std") {
|
| 186 | ! |
lav_object_inspect_sampstat(object, h1 = TRUE, std = TRUE, |
| 187 | ! |
add.labels = add.labels, add.class = add.class, |
| 188 | ! |
drop.list.single.group = drop.list.single.group) |
| 189 | 656x |
} else if (what == "h1" || what == "missing.h1" || what == "sampstat.h1") {
|
| 190 | 16x |
lav_object_inspect_sampstat(object, h1 = TRUE, |
| 191 | 16x |
add.labels = add.labels, add.class = add.class, |
| 192 | 16x |
drop.list.single.group = drop.list.single.group) |
| 193 | ||
| 194 |
#### wls.est - wls.obs - wls.v #### |
|
| 195 | 640x |
} else if (what == "wls.est") {
|
| 196 | 20x |
lav_object_inspect_wls_est(object, |
| 197 | 20x |
add.labels = add.labels, add.class = add.class, |
| 198 | 20x |
drop.list.single.group = drop.list.single.group) |
| 199 | 620x |
} else if (what == "wls.obs") {
|
| 200 | 20x |
lav_object_inspect_wls_obs(object, |
| 201 | 20x |
add.labels = add.labels, add.class = add.class, |
| 202 | 20x |
drop.list.single.group = drop.list.single.group) |
| 203 | 600x |
} else if (what == "wls.v") {
|
| 204 | 20x |
lav_object_inspect_wls_v(object, |
| 205 | 20x |
add.labels = add.labels, add.class = add.class, |
| 206 | 20x |
drop.list.single.group = drop.list.single.group) |
| 207 | ||
| 208 | ||
| 209 | ||
| 210 |
#### data + missingness #### |
|
| 211 | 580x |
} else if (what == "data") {
|
| 212 | ! |
lav_object_inspect_data(object, add.labels = add.labels, |
| 213 | ! |
drop.list.single.group = drop.list.single.group) |
| 214 | 580x |
} else if (what == "case.idx") {
|
| 215 | ! |
lav_object_inspect_case_idx(object, |
| 216 | ! |
drop.list.single.group = drop.list.single.group) |
| 217 | 580x |
} else if (what == "ngroups") {
|
| 218 | ! |
object@Data@ngroups |
| 219 | 580x |
} else if (what == "group") {
|
| 220 | ! |
object@Data@group |
| 221 | 580x |
} else if (what == "cluster") {
|
| 222 | ! |
object@Data@cluster |
| 223 | 580x |
} else if (what == "nlevels") {
|
| 224 | ! |
object@Data@nlevels |
| 225 | 580x |
} else if (what == "nclusters") {
|
| 226 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 227 | ! |
what = "nclusters", |
| 228 | ! |
drop.list.single.group = drop.list.single.group) |
| 229 | 580x |
} else if (what == "ncluster.size") {
|
| 230 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 231 | ! |
what = "ncluster.size", |
| 232 | ! |
drop.list.single.group = drop.list.single.group) |
| 233 | 580x |
} else if (what == "cluster.size") {
|
| 234 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 235 | ! |
what = "cluster.size", |
| 236 | ! |
drop.list.single.group = drop.list.single.group) |
| 237 | 580x |
} else if (what == "cluster.id") {
|
| 238 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 239 | ! |
what = "cluster.id", |
| 240 | ! |
drop.list.single.group = drop.list.single.group) |
| 241 | 580x |
} else if (what == "cluster.idx") {
|
| 242 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 243 | ! |
what = "cluster.idx", |
| 244 | ! |
drop.list.single.group = drop.list.single.group) |
| 245 | 580x |
} else if (what == "cluster.label") {
|
| 246 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 247 | ! |
what = "cluster.label", |
| 248 | ! |
drop.list.single.group = drop.list.single.group) |
| 249 | 580x |
} else if (what == "cluster.sizes") {
|
| 250 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 251 | ! |
what = "cluster.sizes", |
| 252 | ! |
drop.list.single.group = drop.list.single.group) |
| 253 | 580x |
} else if (what == "average.cluster.size") {
|
| 254 | ! |
lav_object_inspect_cluster_info(object, level = 2L, |
| 255 | ! |
what = "average.cluster.size", |
| 256 | ! |
drop.list.single.group = drop.list.single.group) |
| 257 | 580x |
} else if (what == "ordered") {
|
| 258 | ! |
object@Data@ordered |
| 259 | 580x |
} else if (what == "group.label") {
|
| 260 | ! |
object@Data@group.label |
| 261 | 580x |
} else if (what == "level.label") {
|
| 262 | ! |
object@Data@level.label |
| 263 | 580x |
} else if (what == "nobs") {
|
| 264 | ! |
unlist(object@Data@nobs) |
| 265 | 580x |
} else if (what == "norig") {
|
| 266 | ! |
unlist(object@Data@norig) |
| 267 | 580x |
} else if (what == "ntotal") {
|
| 268 | ! |
sum(unlist(object@Data@nobs)) |
| 269 | 580x |
} else if (what == "coverage") {
|
| 270 | 20x |
lav_object_inspect_missing_coverage(object, |
| 271 | 20x |
add.labels = add.labels, add.class = add.class, |
| 272 | 20x |
drop.list.single.group = drop.list.single.group) |
| 273 | 560x |
} else if (what %in% c("patterns", "pattern")) {
|
| 274 | 20x |
lav_object_inspect_missing_patterns(object, |
| 275 | 20x |
add.labels = add.labels, add.class = add.class, |
| 276 | 20x |
drop.list.single.group = drop.list.single.group) |
| 277 | 540x |
} else if (what == "empty.idx") {
|
| 278 | ! |
lav_object_inspect_empty_idx(object, |
| 279 | ! |
drop.list.single.group = drop.list.single.group) |
| 280 | ||
| 281 | ||
| 282 |
#### rsquare #### |
|
| 283 | 540x |
} else if (what == "rsquare" || what == "r-square" || what == "r2") {
|
| 284 | 20x |
lav_object_inspect_rsquare(object, |
| 285 | 20x |
add.labels = add.labels, add.class = add.class, |
| 286 | 20x |
drop.list.single.group = drop.list.single.group) |
| 287 | ||
| 288 | ||
| 289 |
#### model-implied sample statistics #### |
|
| 290 | 520x |
} else if (what == "implied" || what == "fitted" || |
| 291 | 520x |
what == "expected" || what == "exp") {
|
| 292 | ! |
lav_object_inspect_implied(object, |
| 293 | ! |
add.labels = add.labels, add.class = add.class, |
| 294 | ! |
drop.list.single.group = drop.list.single.group) |
| 295 | 520x |
} else if (what == "resid" || what == "res" || what == "residual" || |
| 296 | 520x |
what == "residuals") {
|
| 297 | ! |
lav_object_inspect_residuals(object, h1 = TRUE, |
| 298 | ! |
add.labels = add.labels, add.class = add.class, |
| 299 | ! |
drop.list.single.group = drop.list.single.group) |
| 300 | 520x |
} else if (what == "cov.lv" || what == "veta") {
|
| 301 | 47x |
lav_object_inspect_cov_lv(object, |
| 302 | 47x |
correlation.metric = FALSE, |
| 303 | 47x |
add.labels = add.labels, add.class = add.class, |
| 304 | 47x |
drop.list.single.group = drop.list.single.group) |
| 305 | 473x |
} else if (what == "cor.lv") {
|
| 306 | 20x |
lav_object_inspect_cov_lv(object, |
| 307 | 20x |
correlation.metric = TRUE, |
| 308 | 20x |
add.labels = add.labels, add.class = add.class, |
| 309 | 20x |
drop.list.single.group = drop.list.single.group) |
| 310 | 453x |
} else if (what == "mean.lv" || what == "eeta") {
|
| 311 | 20x |
lav_object_inspect_mean_lv(object, |
| 312 | 20x |
add.labels = add.labels, add.class = add.class, |
| 313 | 20x |
drop.list.single.group = drop.list.single.group) |
| 314 | 433x |
} else if (what == "cov.all") {
|
| 315 | ! |
lav_object_inspect_cov_all(object, |
| 316 | ! |
correlation.metric = FALSE, |
| 317 | ! |
add.labels = add.labels, add.class = add.class, |
| 318 | ! |
drop.list.single.group = drop.list.single.group) |
| 319 | 433x |
} else if (what == "cor.all") {
|
| 320 | ! |
lav_object_inspect_cov_all(object, |
| 321 | ! |
correlation.metric = TRUE, |
| 322 | ! |
add.labels = add.labels, add.class = add.class, |
| 323 | ! |
drop.list.single.group = drop.list.single.group) |
| 324 | 433x |
} else if (what == "cov.ov" || what == "sigma" || what == "sigma.hat") {
|
| 325 | 20x |
lav_object_inspect_cov_ov(object, |
| 326 | 20x |
correlation.metric = FALSE, |
| 327 | 20x |
add.labels = add.labels, add.class = add.class, |
| 328 | 20x |
drop.list.single.group = drop.list.single.group) |
| 329 | 413x |
} else if (what == "cor.ov") {
|
| 330 | 20x |
lav_object_inspect_cov_ov(object, |
| 331 | 20x |
correlation.metric = TRUE, |
| 332 | 20x |
add.labels = add.labels, add.class = add.class, |
| 333 | 20x |
drop.list.single.group = drop.list.single.group) |
| 334 | 393x |
} else if (what == "mean.ov" || what == "mu" || what == "mu.hat") {
|
| 335 | 20x |
lav_object_inspect_mean_ov(object, |
| 336 | 20x |
add.labels = add.labels, add.class = add.class, |
| 337 | 20x |
drop.list.single.group = drop.list.single.group) |
| 338 | 373x |
} else if (what == "th" || what == "thresholds") {
|
| 339 | 20x |
lav_object_inspect_th(object, |
| 340 | 20x |
add.labels = add.labels, add.class = add.class, |
| 341 | 20x |
drop.list.single.group = drop.list.single.group) |
| 342 | 353x |
} else if (what == "th.idx") {
|
| 343 | ! |
lav_object_inspect_th_idx(object, |
| 344 | ! |
add.labels = add.labels, add.class = add.class, |
| 345 | ! |
drop.list.single.group = drop.list.single.group) |
| 346 | 353x |
} else if (what == "vy") {
|
| 347 | ! |
lav_object_inspect_vy(object, |
| 348 | ! |
add.labels = add.labels, add.class = add.class, |
| 349 | ! |
drop.list.single.group = drop.list.single.group) |
| 350 | 353x |
} else if (what %in% c("fs.reliability", "fs.rel", "fs.reliabilities")) {
|
| 351 | ! |
lav_object_inspect_fs_determinacy(object, squared = TRUE, |
| 352 | ! |
fs.method = "regression", |
| 353 | ! |
add.labels = add.labels, add.class = add.class, |
| 354 | ! |
drop.list.single.group = drop.list.single.group) |
| 355 | 353x |
} else if (what %in% c("fs.determinacy", "fs.det", "fs.determin",
|
| 356 | 353x |
"fs.determinacies")) {
|
| 357 | ! |
lav_object_inspect_fs_determinacy(object, squared = FALSE, |
| 358 | ! |
fs.method = "regression", |
| 359 | ! |
add.labels = add.labels, add.class = add.class, |
| 360 | ! |
drop.list.single.group = drop.list.single.group) |
| 361 | 353x |
} else if (what %in% c("fs.reliability.bartlett",
|
| 362 | 353x |
"fs.reliability.Bartlett", |
| 363 | 353x |
"fs.rel.bartlett", "fs.rel.Bartlett", |
| 364 | 353x |
"fs.reliabilities.bartlett", |
| 365 | 353x |
"fs.reliabilities.Bartlett")) {
|
| 366 | ! |
lav_object_inspect_fs_determinacy(object, squared = TRUE, |
| 367 | ! |
fs.method = "Bartlett", |
| 368 | ! |
add.labels = add.labels, add.class = add.class, |
| 369 | ! |
drop.list.single.group = drop.list.single.group) |
| 370 | 353x |
} else if (what %in% c("fs.determinacy.bartlett",
|
| 371 | 353x |
"fs.determinacy.Bartlett", |
| 372 | 353x |
"fs.det.bartlett", "fs.det.Bartlett", |
| 373 | 353x |
"fs.determin.bartlett", "fs.determin.Bartlett", |
| 374 | 353x |
"fs.determinacies.bartlett", |
| 375 | 353x |
"fs.determinacies.Bartlett")) {
|
| 376 | ! |
lav_object_inspect_fs_determinacy(object, squared = FALSE, |
| 377 | ! |
fs.method = "Bartlett", |
| 378 | ! |
add.labels = add.labels, add.class = add.class, |
| 379 | ! |
drop.list.single.group = drop.list.single.group) |
| 380 | ||
| 381 | ||
| 382 | ||
| 383 |
#### specific model matrices? #### |
|
| 384 | 353x |
} else if (what == "theta" || what == "theta.cov") {
|
| 385 | 65x |
lav_object_inspect_theta(object, correlation.metric = FALSE, |
| 386 | 65x |
add.labels = add.labels, add.class = add.class, |
| 387 | 65x |
drop.list.single.group = drop.list.single.group) |
| 388 | 288x |
} else if (what == "theta.cor") {
|
| 389 | 20x |
lav_object_inspect_theta(object, correlation.metric = TRUE, |
| 390 | 20x |
add.labels = add.labels, add.class = add.class, |
| 391 | 20x |
drop.list.single.group = drop.list.single.group) |
| 392 | ||
| 393 |
#### (squared) Mahalanobis distances #### |
|
| 394 | 268x |
} else if (what == "mdist2.fs") {
|
| 395 | ! |
lav_object_inspect_mdist2(object, type = "lv", squared = TRUE, |
| 396 | ! |
add.labels = add.labels, add.class = add.class, |
| 397 | ! |
drop.list.single.group = drop.list.single.group) |
| 398 | 268x |
} else if (what == "mdist2.resid") {
|
| 399 | ! |
lav_object_inspect_mdist2(object, type = "resid", squared = TRUE, |
| 400 | ! |
add.labels = add.labels, add.class = add.class, |
| 401 | ! |
drop.list.single.group = drop.list.single.group) |
| 402 | 268x |
} else if (what == "mdist.fs") {
|
| 403 | ! |
lav_object_inspect_mdist2(object, type = "lv", squared = FALSE, |
| 404 | ! |
add.labels = add.labels, add.class = add.class, |
| 405 | ! |
drop.list.single.group = drop.list.single.group) |
| 406 | 268x |
} else if (what == "mdist.resid") {
|
| 407 | ! |
lav_object_inspect_mdist2(object, type = "resid", squared = FALSE, |
| 408 | ! |
add.labels = add.labels, add.class = add.class, |
| 409 | ! |
drop.list.single.group = drop.list.single.group) |
| 410 | ||
| 411 |
#### convergence, meanstructure, categorical #### |
|
| 412 | 268x |
} else if (what == "converged") {
|
| 413 | 71x |
object@optim$converged |
| 414 | 197x |
} else if (what == "iterations" || |
| 415 | 197x |
what == "iter" || |
| 416 | 197x |
what == "niter") {
|
| 417 | ! |
object@optim$iterations |
| 418 | 197x |
} else if (what == "meanstructure") {
|
| 419 | ! |
object@Model@meanstructure |
| 420 | 197x |
} else if (what == "categorical") {
|
| 421 | ! |
object@Model@categorical |
| 422 | 197x |
} else if (what == "fixed.x") {
|
| 423 | ! |
object@Model@fixed.x |
| 424 | 197x |
} else if (what == "parameterization") {
|
| 425 | ! |
object@Model@parameterization |
| 426 | 197x |
} else if (what == "npar") {
|
| 427 | ! |
lav_object_inspect_npar(object, ceq = FALSE) # ignore equality constraints |
| 428 | 197x |
} else if (what == "coef") {
|
| 429 |
# this breaks simsem and semTools -- 0.6-1 |
|
| 430 |
# lav_object_inspect_coef(object, type = "free", |
|
| 431 |
# add.labels = add.labels, add.class = add.class) |
|
| 432 | ! |
lav_object_inspect_modelmatrices(object, what = "est", |
| 433 | ! |
type = "free", add.labels = add.labels, add.class = add.class, |
| 434 | ! |
list.by.group = list.by.group, |
| 435 | ! |
drop.list.single.group = drop.list.single.group) |
| 436 | ||
| 437 | ||
| 438 |
#### NACOV samplestats #### |
|
| 439 | 197x |
} else if (what == "gamma") {
|
| 440 | 3x |
lav_object_inspect_sampstat_gamma(object, |
| 441 | 3x |
add.labels = add.labels, add.class = add.class, |
| 442 | 3x |
drop.list.single.group = drop.list.single.group) |
| 443 | ||
| 444 | ||
| 445 |
#### gradient, Hessian, information, first.order, vcov #### |
|
| 446 | 194x |
} else if (what == "gradient") {
|
| 447 | ! |
lav_object_inspect_gradient(object, |
| 448 | ! |
add.labels = add.labels, add.class = add.class, logl = FALSE) |
| 449 | 194x |
} else if (what == "gradient.logl") {
|
| 450 | ! |
lav_object_inspect_gradient(object, |
| 451 | ! |
add.labels = add.labels, add.class = add.class, logl = TRUE) |
| 452 | 194x |
} else if (what == "optim.gradient") {
|
| 453 | ! |
lav_object_inspect_gradient(object, |
| 454 | ! |
add.labels = add.labels, add.class = add.class, optim = TRUE) |
| 455 | 194x |
} else if (what == "hessian") {
|
| 456 | 20x |
lav_object_inspect_hessian(object, |
| 457 | 20x |
add.labels = add.labels, add.class = add.class) |
| 458 | ||
| 459 | 174x |
} else if (what == "information") {
|
| 460 | ! |
lav_object_inspect_information(object, information = "default", |
| 461 | ! |
augmented = FALSE, inverted = FALSE, |
| 462 | ! |
add.labels = add.labels, add.class = add.class) |
| 463 | 174x |
} else if (what == "information.expected") {
|
| 464 | ! |
lav_object_inspect_information(object, information = "expected", |
| 465 | ! |
augmented = FALSE, inverted = FALSE, |
| 466 | ! |
add.labels = add.labels, add.class = add.class) |
| 467 | 174x |
} else if (what == "information.observed") {
|
| 468 | ! |
lav_object_inspect_information(object, information = "observed", |
| 469 | ! |
augmented = FALSE, inverted = FALSE, |
| 470 | ! |
add.labels = add.labels, add.class = add.class) |
| 471 | 174x |
} else if (what == "information.first.order" || |
| 472 | 174x |
what == "information.firstorder" || |
| 473 | 174x |
what == "first.order") {
|
| 474 | 1x |
lav_object_inspect_information(object, information = "first.order", |
| 475 | 1x |
augmented = FALSE, inverted = FALSE, |
| 476 | 1x |
add.labels = add.labels, add.class = add.class) |
| 477 | ||
| 478 | 173x |
} else if (what == "augmented.information") {
|
| 479 | ! |
lav_object_inspect_information(object, information = "default", |
| 480 | ! |
augmented = TRUE, inverted = FALSE, |
| 481 | ! |
add.labels = add.labels, add.class = add.class) |
| 482 | 173x |
} else if (what == "augmented.information.expected") {
|
| 483 | ! |
lav_object_inspect_information(object, information = "expected", |
| 484 | ! |
augmented = TRUE, inverted = FALSE, |
| 485 | ! |
add.labels = add.labels, add.class = add.class) |
| 486 | 173x |
} else if (what == "augmented.information.observed") {
|
| 487 | ! |
lav_object_inspect_information(object, information = "observed", |
| 488 | ! |
augmented = TRUE, inverted = FALSE, |
| 489 | ! |
add.labels = add.labels, add.class = add.class) |
| 490 | 173x |
} else if (what == "augmented.information.first.order" || |
| 491 | 173x |
what == "augmented.first.order") {
|
| 492 | ! |
lav_object_inspect_information(object, information = "first.order", |
| 493 | ! |
augmented = TRUE, inverted = FALSE, |
| 494 | ! |
add.labels = add.labels, add.class = add.class) |
| 495 | ||
| 496 | 173x |
} else if (what == "inverted.information") {
|
| 497 | 32x |
lav_object_inspect_information(object, information = "default", |
| 498 | 32x |
augmented = TRUE, inverted = TRUE, |
| 499 | 32x |
add.labels = add.labels, add.class = add.class) |
| 500 | 141x |
} else if (what == "inverted.information.expected") {
|
| 501 | ! |
lav_object_inspect_information(object, information = "expected", |
| 502 | ! |
augmented = TRUE, inverted = TRUE, |
| 503 | ! |
add.labels = add.labels, add.class = add.class) |
| 504 | 141x |
} else if (what == "inverted.information.observed") {
|
| 505 | ! |
lav_object_inspect_information(object, information = "observed", |
| 506 | ! |
augmented = TRUE, inverted = TRUE, |
| 507 | ! |
add.labels = add.labels, add.class = add.class) |
| 508 | 141x |
} else if (what == "inverted.information.first.order" || |
| 509 | 141x |
what == "inverted.first.order") {
|
| 510 | ! |
lav_object_inspect_information(object, information = "first.order", |
| 511 | ! |
augmented = TRUE, inverted = TRUE, |
| 512 | ! |
add.labels = add.labels, add.class = add.class) |
| 513 | ||
| 514 | 141x |
} else if (what == "h1.information") {
|
| 515 | ! |
lav_object_inspect_h1_information(object, information = "default", |
| 516 | ! |
h1.information = "default", inverted = FALSE, |
| 517 | ! |
add.labels = add.labels, add.class = add.class, |
| 518 | ! |
drop.list.single.group = drop.list.single.group) |
| 519 | 141x |
} else if (what == "h1.information.expected") {
|
| 520 | ! |
lav_object_inspect_h1_information(object, information = "expected", |
| 521 | ! |
h1.information = "default", inverted = FALSE, |
| 522 | ! |
add.labels = add.labels, add.class = add.class, |
| 523 | ! |
drop.list.single.group = drop.list.single.group) |
| 524 | 141x |
} else if (what == "h1.information.observed") {
|
| 525 | ! |
lav_object_inspect_h1_information(object, information = "observed", |
| 526 | ! |
h1.information = "default", inverted = FALSE, |
| 527 | ! |
add.labels = add.labels, add.class = add.class, |
| 528 | ! |
drop.list.single.group = drop.list.single.group) |
| 529 | 141x |
} else if (what == "h1.information.first.order" || |
| 530 | 141x |
what == "h1.information.firstorder" || |
| 531 | 141x |
what == "h1.first.order") {
|
| 532 | ! |
lav_object_inspect_h1_information(object, |
| 533 | ! |
information = "first.order", h1.information = "default", |
| 534 | ! |
inverted = FALSE, add.labels = add.labels, add.class = add.class, |
| 535 | ! |
drop.list.single.group = drop.list.single.group) |
| 536 | ||
| 537 | 141x |
} else if (what == "vcov") {
|
| 538 | ! |
lav_object_inspect_vcov(object, |
| 539 | ! |
standardized = FALSE, |
| 540 | ! |
add.labels = add.labels, add.class = add.class) |
| 541 | 141x |
} else if (what == "vcov.std.all" || what == "vcov.standardized" || |
| 542 | 141x |
what == "vcov.std") {
|
| 543 | ! |
lav_object_inspect_vcov(object, |
| 544 | ! |
standardized = TRUE, type = "std.all", |
| 545 | ! |
add.labels = add.labels, add.class = add.class) |
| 546 | 141x |
} else if (what == "vcov.std.lv") {
|
| 547 | ! |
lav_object_inspect_vcov(object, |
| 548 | ! |
standardized = TRUE, type = "std.lv", |
| 549 | ! |
add.labels = add.labels, add.class = add.class) |
| 550 | 141x |
} else if (what == "vcov.std.nox") {
|
| 551 | ! |
lav_object_inspect_vcov(object, |
| 552 | ! |
standardized = TRUE, type = "std.nox", |
| 553 | ! |
add.labels = add.labels, add.class = add.class) |
| 554 | ||
| 555 | 141x |
} else if (what == "vcov.def") {
|
| 556 | ! |
lav_object_inspect_vcov_def(object, joint = FALSE, |
| 557 | ! |
standardized = FALSE, |
| 558 | ! |
add.labels = add.labels, add.class = add.class) |
| 559 | 141x |
} else if (what == "vcov.def.std.all" || what == "vcov.def.standardized" || |
| 560 | 141x |
what == "vcov.def.std") {
|
| 561 | ! |
lav_object_inspect_vcov_def(object, joint = FALSE, |
| 562 | ! |
standardized = TRUE, type = "std.all", |
| 563 | ! |
add.labels = add.labels, add.class = add.class) |
| 564 | 141x |
} else if (what == "vcov.def.std.lv") {
|
| 565 | ! |
lav_object_inspect_vcov_def(object, joint = FALSE, |
| 566 | ! |
standardized = TRUE, type = "std.lv", |
| 567 | ! |
add.labels = add.labels, add.class = add.class) |
| 568 | 141x |
} else if (what == "vcov.def.std.nox") {
|
| 569 | ! |
lav_object_inspect_vcov_def(object, joint = FALSE, |
| 570 | ! |
standardized = TRUE, type = "std.nox", |
| 571 | ! |
add.labels = add.labels, add.class = add.class) |
| 572 | ||
| 573 | 141x |
} else if (what == "vcov.def.joint") {
|
| 574 | ! |
lav_object_inspect_vcov_def(object, joint = TRUE, |
| 575 | ! |
standardized = FALSE, |
| 576 | ! |
add.labels = add.labels, add.class = add.class) |
| 577 | 141x |
} else if (what == "vcov.def.joint.std.all" || |
| 578 | 141x |
what == "vcov.def.joint.standardized" || |
| 579 | 141x |
what == "vcov.def.joint.std") {
|
| 580 | ! |
lav_object_inspect_vcov_def(object, joint = TRUE, |
| 581 | ! |
standardized = TRUE, type = "std.all", |
| 582 | ! |
add.labels = add.labels, add.class = add.class) |
| 583 | 141x |
} else if (what == "vcov.def.joint.std.lv") {
|
| 584 | ! |
lav_object_inspect_vcov_def(object, joint = TRUE, |
| 585 | ! |
standardized = TRUE, type = "std.lv", |
| 586 | ! |
add.labels = add.labels, add.class = add.class) |
| 587 | 141x |
} else if (what == "vcov.def.joint.std.nox") {
|
| 588 | ! |
lav_object_inspect_vcov_def(object, joint = TRUE, |
| 589 | ! |
standardized = TRUE, type = "std.nox", |
| 590 | ! |
add.labels = add.labels, add.class = add.class) |
| 591 | ||
| 592 | 141x |
} else if (what == "ugamma" || what == "ug" || what == "u.gamma") {
|
| 593 | ! |
lav_object_inspect_UGamma(object, |
| 594 | ! |
add.labels = add.labels, add.class = add.class) |
| 595 | 141x |
} else if (what == "ufromugamma" || what == "u") {
|
| 596 | ! |
lav_object_inspect_UfromUGamma(object, |
| 597 | ! |
add.labels = add.labels, add.class = add.class, |
| 598 | ! |
drop.list.single.group = drop.list.single.group) |
| 599 | ||
| 600 |
### jacobians #### |
|
| 601 | 141x |
} else if (what == "delta") {
|
| 602 | 32x |
lav_object_inspect_delta(object, |
| 603 | 32x |
add.labels = add.labels, add.class = add.class, |
| 604 | 32x |
drop.list.single.group = drop.list.single.group) |
| 605 | 109x |
} else if (what == "delta.rownames") {
|
| 606 | ! |
lav_object_inspect_delta_rownames(object, |
| 607 | ! |
drop.list.single.group = drop.list.single.group) |
| 608 | ||
| 609 |
### casewise loglikehoods ### |
|
| 610 | 109x |
} else if (what == "loglik.casewise") {
|
| 611 | ! |
lav_object_inspect_loglik_casewise(object, log. = TRUE, |
| 612 | ! |
add.labels = add.labels, add.class = add.class, |
| 613 | ! |
drop.list.single.group = drop.list.single.group) |
| 614 | 109x |
} else if (what == "lik.casewise") {
|
| 615 | ! |
lav_object_inspect_loglik_casewise(object, log. = FALSE, |
| 616 | ! |
add.labels = add.labels, add.class = add.class, |
| 617 | ! |
drop.list.single.group = drop.list.single.group) |
| 618 | ||
| 619 |
# multilevel # |
|
| 620 | 109x |
} else if (what == "icc") {
|
| 621 | ! |
lav_object_inspect_icc(object, |
| 622 | ! |
add.labels = add.labels, add.class = add.class, |
| 623 | ! |
drop.list.single.group = drop.list.single.group) |
| 624 | 109x |
} else if (what == "ranef") {
|
| 625 | ! |
lav_object_inspect_ranef(object, |
| 626 | ! |
add.labels = add.labels, add.class = add.class, |
| 627 | ! |
drop.list.single.group = drop.list.single.group) |
| 628 | ||
| 629 |
# instrumental variables |
|
| 630 | 109x |
} else if(what %in% c("iv", "ivs", "miiv", "miivs", "instr", "instruments")) {
|
| 631 | ! |
lav_object_inspect_iv(object, |
| 632 | ! |
drop.list.single.group = drop.list.single.group) |
| 633 | 109x |
} else if(what %in% c("eqs")) {
|
| 634 | ! |
lav_object_inspect_eqs(object, |
| 635 | ! |
drop.list.single.group = drop.list.single.group) |
| 636 | 109x |
} else if(what %in% c("sargan")) {
|
| 637 | ! |
lav_object_inspect_sargan(object, |
| 638 | ! |
drop.list.single.group = drop.list.single.group) |
| 639 | ||
| 640 |
# post-checking |
|
| 641 | 109x |
} else if (what == "post.check" || what == "post") {
|
| 642 | 45x |
lav_object_post_check(object) |
| 643 | ||
| 644 |
# options |
|
| 645 | 64x |
} else if (what == "options" || what == "lavoptions") {
|
| 646 | ! |
object@Options |
| 647 | ||
| 648 |
# version |
|
| 649 | 64x |
} else if (what == "version") {
|
| 650 | ! |
object@version |
| 651 | ||
| 652 |
# call |
|
| 653 | 64x |
} else if (what == "call") {
|
| 654 | ! |
as.list(object@call) |
| 655 | ||
| 656 |
# timing |
|
| 657 | 64x |
} else if (what == "timing") {
|
| 658 | ! |
object@timing |
| 659 | ||
| 660 |
# optim |
|
| 661 | 64x |
} else if (what == "optim") {
|
| 662 | ! |
object@optim |
| 663 | ||
| 664 |
# test |
|
| 665 | 64x |
} else if (what == "test") {
|
| 666 | 64x |
object@test |
| 667 | ||
| 668 |
# zero cell tables |
|
| 669 | ! |
} else if (what == "zero.cell.tables") {
|
| 670 | ! |
lav_object_inspect_zero_cell_tables(object, |
| 671 | ! |
add.labels = add.labels, add.class = add.class, |
| 672 | ! |
drop.list.single.group = drop.list.single.group) |
| 673 | ||
| 674 |
#### not found #### |
|
| 675 |
} else {
|
|
| 676 | ! |
lav_msg_stop(gettextf( |
| 677 | ! |
"%1$s argument unknown: %2$s", |
| 678 | ! |
"what", lav_msg_view(what) |
| 679 |
)) |
|
| 680 |
} |
|
| 681 | ||
| 682 |
} |
|
| 683 | ||
| 684 | ||
| 685 |
# helper functions (mostly to deal with older 'object' that may have |
|
| 686 |
# been saved somewhere) |
|
| 687 |
lav_object_inspect_est <- function(object, unrotated = FALSE) {
|
|
| 688 | ||
| 689 | 179x |
if (inherits(object, "lavaan")) {
|
| 690 |
# from 0.5-19, they are in the partable |
|
| 691 | 179x |
if (!is.null(object@ParTable$est)) {
|
| 692 | 179x |
if (unrotated) {
|
| 693 | ! |
return.value <- object@ParTable$est.unrotated |
| 694 |
} else {
|
|
| 695 | 179x |
return.value <- object@ParTable$est # if this changes, tag @TDJorgensen in commit message |
| 696 |
} |
|
| 697 |
} else {
|
|
| 698 | ! |
partable <- parTable(object) |
| 699 | ! |
return.value <- rep(as.numeric(NA), length(partable$lhs)) |
| 700 |
} |
|
| 701 |
} else {
|
|
| 702 |
# try generic coef() |
|
| 703 | ! |
return.value <- coef(object, type = "user") |
| 704 | ! |
if (is.matrix(return.value)) {
|
| 705 |
# lavaanList? |
|
| 706 | ! |
return.value <- rowMeans(return.value) |
| 707 |
} |
|
| 708 |
} |
|
| 709 | ||
| 710 | 179x |
return.value |
| 711 |
} |
|
| 712 | ||
| 713 |
lav_object_inspect_se <- function(object) {
|
|
| 714 |
# from 0.5-19, they are in the partable |
|
| 715 | 64x |
if (!is.null(object@ParTable$se)) {
|
| 716 | 64x |
return.value <- object@ParTable$se |
| 717 |
} else {
|
|
| 718 | ! |
partable <- parTable(object) |
| 719 | ! |
return.value <- rep(as.numeric(NA), length(partable$lhs)) |
| 720 |
} |
|
| 721 | ||
| 722 | 64x |
return.value |
| 723 |
} |
|
| 724 | ||
| 725 |
lav_object_inspect_std_se <- function(object) {
|
|
| 726 | ||
| 727 | 4x |
if (!is.null(object@ParTable$se.std)) {
|
| 728 | ! |
return.value <- object@ParTable$se.std |
| 729 |
} else {
|
|
| 730 | 4x |
tmp.std <- standardizedSolution(object) |
| 731 | 4x |
return.value <- tmp.std$se |
| 732 |
} |
|
| 733 | ||
| 734 | 4x |
return.value |
| 735 |
} |
|
| 736 | ||
| 737 |
lav_object_inspect_start <- function(object) {
|
|
| 738 |
# from 0.5-19, they are in the partable |
|
| 739 | 20x |
if (!is.null(object@ParTable$start)) {
|
| 740 | 20x |
return.value <- object@ParTable$start |
| 741 |
} else {
|
|
| 742 |
# in < 0.5-19, we should look in @Fit@start |
|
| 743 | ! |
return.value <- object@Fit@start |
| 744 |
} |
|
| 745 | ||
| 746 | 20x |
return.value |
| 747 |
} |
|
| 748 | ||
| 749 |
lav_object_inspect_boot <- function(object, add.labels = FALSE, |
|
| 750 |
add.class = FALSE) {
|
|
| 751 | ||
| 752 | ! |
if (object@Options$se != "bootstrap" && |
| 753 | ! |
!any(c("bootstrap", "bollen.stine") %in% object@Options$test)) {
|
| 754 | ! |
lav_msg_stop(gettext("bootstrap was not used."))
|
| 755 |
} |
|
| 756 | ||
| 757 |
# from 0.5-19. they are in a separate slot |
|
| 758 | ! |
tmp <- try(slot(object, "boot"), silent = TRUE) |
| 759 | ! |
if (inherits(tmp, "try-error")) {
|
| 760 |
# older version of object? |
|
| 761 | ! |
est <- lav_object_inspect_est(object) |
| 762 | ! |
tmp.boot <- attr(est, "tmp.boot.COEF") |
| 763 |
} else {
|
|
| 764 |
# 0.5-19 way |
|
| 765 | ! |
tmp.boot <- object@boot$coef |
| 766 |
} |
|
| 767 | ||
| 768 |
# add coef names |
|
| 769 | ! |
if (add.labels) {
|
| 770 | ! |
colnames(tmp.boot) <- names(coef(object)) |
| 771 |
} |
|
| 772 | ||
| 773 |
# add class |
|
| 774 | ! |
if (add.class) {
|
| 775 | ! |
class(tmp.boot) <- c("lavaan.matrix", "matrix")
|
| 776 |
} |
|
| 777 | ||
| 778 | ! |
tmp.boot |
| 779 |
} |
|
| 780 | ||
| 781 | ||
| 782 |
lav_object_inspect_modelmatrices <- function(object, what = "free", # nolint |
|
| 783 |
type = "free", add.labels = FALSE, add.class = FALSE, |
|
| 784 |
list.by.group = FALSE, |
|
| 785 |
drop.list.single.group = FALSE) {
|
|
| 786 | ||
| 787 | 192x |
glist <- object@Model@GLIST |
| 788 | ||
| 789 | 192x |
current.verbose <- lav_verbose() |
| 790 | 192x |
if (what == "dx.free") {
|
| 791 | ! |
if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose), TRUE) |
| 792 | 20x |
tmp.dx <- lav_model_gradient( |
| 793 | 20x |
lavmodel = object@Model, |
| 794 | 20x |
GLIST = NULL, |
| 795 | 20x |
lavsamplestats = object@SampleStats, |
| 796 | 20x |
lavdata = object@Data, |
| 797 | 20x |
lavcache = object@Cache, |
| 798 | 20x |
type = "free", |
| 799 | 20x |
group.weight = TRUE, |
| 800 | 20x |
ceq.simple = TRUE, |
| 801 | 20x |
Delta = NULL) |
| 802 | 172x |
} else if (what == "dx.all") {
|
| 803 | ! |
if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose), TRUE) |
| 804 | ! |
glist <- lav_model_gradient(lavmodel = object@Model, |
| 805 | ! |
GLIST = NULL, |
| 806 | ! |
lavsamplestats = object@SampleStats, |
| 807 | ! |
lavdata = object@Data, |
| 808 | ! |
lavcache = object@Cache, |
| 809 | ! |
type = "allofthem", |
| 810 | ! |
group.weight = TRUE, |
| 811 | ! |
ceq.simple = FALSE, |
| 812 | ! |
Delta = NULL) |
| 813 | ! |
names(glist) <- names(object@Model@GLIST) |
| 814 | 172x |
} else if (what == "std.all") {
|
| 815 | 28x |
tmp.std <- lav_standardize_all(object) |
| 816 | 144x |
} else if (what == "std.lv") {
|
| 817 | 20x |
tmp.std <- lav_standardize_lv(object) |
| 818 | 124x |
} else if (what == "std.nox") {
|
| 819 | 20x |
tmp.std <- lav_standardize_all_nox(object) |
| 820 | 104x |
} else if (what == "se") {
|
| 821 | 20x |
tmp.se <- lav_object_inspect_se(object) |
| 822 | 84x |
} else if (what == "std.se") {
|
| 823 | 4x |
tmp.se <- lav_object_inspect_std_se(object) |
| 824 | 80x |
} else if (what == "start") {
|
| 825 | 20x |
tmp.start <- lav_object_inspect_start(object) |
| 826 | 60x |
} else if (what == "est") {
|
| 827 | 20x |
tmp.est <- lav_object_inspect_est(object) |
| 828 | 40x |
} else if (what == "est.unrotated") {
|
| 829 | ! |
if (!is.null(object@Options$rotation) && |
| 830 | ! |
object@Options$rotation == "none") {
|
| 831 | ! |
tmp.est <- lav_object_inspect_est(object, unrotated = FALSE) |
| 832 |
} else {
|
|
| 833 | ! |
tmp.est <- lav_object_inspect_est(object, unrotated = TRUE) |
| 834 |
} |
|
| 835 |
} |
|
| 836 | ||
| 837 | 192x |
for (mm in seq_along(glist)) {
|
| 838 | ||
| 839 | 1143x |
if (add.labels) {
|
| 840 | 1143x |
dimnames(glist[[mm]]) <- object@Model@dimNames[[mm]] |
| 841 |
} |
|
| 842 | ||
| 843 | 1143x |
if (what == "free") {
|
| 844 |
# fill in free parameter counts |
|
| 845 | 246x |
if (type == "free") {
|
| 846 | 123x |
m.el.idx <- object@Model@m.free.idx[[mm]] |
| 847 | 123x |
x.el.idx <- object@Model@x.free.idx[[mm]] |
| 848 |
# } else if(type == "unco") {
|
|
| 849 |
# m.el.idx <- object@Model@m.unco.idx[[mm]] |
|
| 850 |
# x.el.idx <- object@Model@x.unco.idx[[mm]] |
|
| 851 | 123x |
} else if (type == "partable") {
|
| 852 | 123x |
m.el.idx <- object@Model@m.user.idx[[mm]] |
| 853 | 123x |
x.el.idx <- object@Model@x.user.idx[[mm]] |
| 854 |
} else {
|
|
| 855 | ! |
lav_msg_stop(gettextf( |
| 856 | ! |
"%1$s argument unknown: %2$s", |
| 857 | ! |
"type", lav_msg_view(type) |
| 858 |
)) |
|
| 859 |
} |
|
| 860 |
# erase everything |
|
| 861 | 246x |
glist[[mm]][, ] <- 0.0 |
| 862 | 246x |
glist[[mm]][m.el.idx] <- x.el.idx |
| 863 | 897x |
} else if (what == "se" || what == "std.se") {
|
| 864 |
# fill in standard errors |
|
| 865 | 135x |
m.user.idx <- object@Model@m.user.idx[[mm]] |
| 866 | 135x |
x.user.idx <- object@Model@x.user.idx[[mm]] |
| 867 |
# erase everything |
|
| 868 | 135x |
glist[[mm]][, ] <- 0.0 |
| 869 | 135x |
glist[[mm]][m.user.idx] <- tmp.se[x.user.idx] |
| 870 | 762x |
} else if (what == "start") {
|
| 871 |
# fill in starting values |
|
| 872 | 123x |
m.user.idx <- object@Model@m.user.idx[[mm]] |
| 873 | 123x |
x.user.idx <- object@Model@x.user.idx[[mm]] |
| 874 | 123x |
glist[[mm]][m.user.idx] <- tmp.start[x.user.idx] |
| 875 | 639x |
} else if (what %in% c("est", "est.unrotated")) {
|
| 876 |
# fill in estimated parameter values |
|
| 877 | 123x |
m.user.idx <- object@Model@m.user.idx[[mm]] |
| 878 | 123x |
x.user.idx <- object@Model@x.user.idx[[mm]] |
| 879 | 123x |
glist[[mm]][m.user.idx] <- tmp.est[x.user.idx] |
| 880 | 516x |
} else if (what == "dx.free") {
|
| 881 |
# fill in derivatives free parameters |
|
| 882 | 123x |
m.el.idx <- object@Model@m.free.idx[[mm]] |
| 883 | 123x |
x.el.idx <- object@Model@x.free.idx[[mm]] |
| 884 |
# erase everything |
|
| 885 | 123x |
glist[[mm]][, ] <- 0.0 |
| 886 | 123x |
glist[[mm]][m.el.idx] <- tmp.dx[x.el.idx] |
| 887 | 393x |
} else if (what %in% c("std.all", "std.lv", "std.nox")) {
|
| 888 | 393x |
m.user.idx <- object@Model@m.user.idx[[mm]] |
| 889 | 393x |
x.user.idx <- object@Model@x.user.idx[[mm]] |
| 890 | 393x |
glist[[mm]][m.user.idx] <- tmp.std[x.user.idx] |
| 891 |
} |
|
| 892 | ||
| 893 |
# class |
|
| 894 | 1143x |
if (add.class) {
|
| 895 | 1143x |
if (object@Model@isSymmetric[mm]) {
|
| 896 | 465x |
class(glist[[mm]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 897 |
} else {
|
|
| 898 | 678x |
class(glist[[mm]]) <- c("lavaan.matrix", "matrix")
|
| 899 |
} |
|
| 900 |
} |
|
| 901 |
} |
|
| 902 | ||
| 903 |
# try to reflect `equality constraints' |
|
| 904 | 192x |
con.flag <- FALSE |
| 905 | 192x |
if (what == "free" && object@Model@eq.constraints) {
|
| 906 |
# extract constraints from parameter table |
|
| 907 | 10x |
partable <- parTable(object) |
| 908 | 10x |
tmp.con <- partable[partable$op %in% c("==", "<", ">"),
|
| 909 | 10x |
c("lhs", "op", "rhs")]
|
| 910 | 10x |
rownames(tmp.con) <- NULL |
| 911 | ||
| 912 |
# replace 'labels' by parameter numbers |
|
| 913 | 10x |
tmp.id <- lav_partable_constraints_label_id(partable) |
| 914 | 10x |
tmp.label <- names(tmp.id) |
| 915 | 10x |
for (con in seq_len(nrow(tmp.con))) {
|
| 916 |
# lhs |
|
| 917 | 110x |
lhs.labels <- all.vars(as.formula(paste("~", tmp.con[con, "lhs"])))
|
| 918 | ||
| 919 | 110x |
if (length(lhs.labels) > 0L) {
|
| 920 |
# par id |
|
| 921 | 110x |
lhs.freeid <- tmp.id[match(lhs.labels, tmp.label)] |
| 922 | ||
| 923 |
# substitute |
|
| 924 | 110x |
tmp <- tmp.con[con, "lhs"] |
| 925 | 110x |
for (pat in seq_along(lhs.labels)) {
|
| 926 | 110x |
tmp <- sub(lhs.labels[pat], lhs.freeid[pat], tmp) |
| 927 |
} |
|
| 928 | 110x |
tmp.con[con, "lhs"] <- tmp |
| 929 |
} |
|
| 930 | ||
| 931 |
# rhs |
|
| 932 | 110x |
rhs.labels <- all.vars(as.formula(paste("~", tmp.con[con, "rhs"])))
|
| 933 | ||
| 934 | 110x |
if (length(rhs.labels) > 0L) {
|
| 935 |
# par id |
|
| 936 | 110x |
rhs.freeid <- tmp.id[match(rhs.labels, tmp.label)] |
| 937 |
# substitute |
|
| 938 | 110x |
tmp <- tmp.con[con, "rhs"] |
| 939 | 110x |
for (pat in seq_along(rhs.labels)) {
|
| 940 | 110x |
tmp <- sub(rhs.labels[pat], rhs.freeid[pat], tmp) |
| 941 |
} |
|
| 942 | 110x |
tmp.con[con, "rhs"] <- tmp |
| 943 |
} |
|
| 944 |
} # con |
|
| 945 | ||
| 946 |
# add this info at the top |
|
| 947 |
# glist <- c(constraints = list(tmp.con), glist) |
|
| 948 |
# no, not a good idea, it does not work with list.by.group |
|
| 949 | ||
| 950 |
# add it as a 'header' attribute? |
|
| 951 | 10x |
attr(tmp.con, "header") <- "Note: model contains equality constraints:" |
| 952 | 10x |
con.flag <- TRUE |
| 953 |
} |
|
| 954 | ||
| 955 |
# should we group them per block? |
|
| 956 | 192x |
if (list.by.group) {
|
| 957 | 180x |
lavmodel <- object@Model |
| 958 | 180x |
nmat <- lavmodel@nmat |
| 959 | ||
| 960 | 180x |
return.value <- vector("list", length = lavmodel@nblocks)
|
| 961 | 180x |
for (b in seq_len(lavmodel@nblocks)) {
|
| 962 |
# which mm belong to this block? |
|
| 963 | 216x |
mm.in.group <- 1:nmat[b] + cumsum(c(0, nmat))[b] |
| 964 | ||
| 965 | 216x |
return.value[[b]] <- glist[mm.in.group] |
| 966 |
} |
|
| 967 | ||
| 968 | 180x |
if (lavmodel@nblocks == 1L && drop.list.single.group) {
|
| 969 | 162x |
return.value <- return.value[[1]] |
| 970 | 18x |
} else if (lavmodel@nblocks > 1L) {
|
| 971 | 18x |
names(return.value) <- object@Data@block.label |
| 972 |
} |
|
| 973 |
} else {
|
|
| 974 | 12x |
return.value <- glist |
| 975 |
} |
|
| 976 | ||
| 977 |
# header |
|
| 978 | 192x |
if (con.flag) {
|
| 979 | 10x |
attr(return.value, "header") <- tmp.con |
| 980 |
} |
|
| 981 | ||
| 982 |
# lavaan.list |
|
| 983 | 192x |
if (add.class) {
|
| 984 | 192x |
class(return.value) <- c("lavaan.list", "list")
|
| 985 |
} |
|
| 986 | ||
| 987 | 192x |
return.value |
| 988 |
} |
|
| 989 | ||
| 990 | ||
| 991 | ||
| 992 | ||
| 993 |
# - fixme, should we export this function? |
|
| 994 |
# - since 0.5-21, conditional.x = TRUE returns residual sample statistics |
|
| 995 |
# for ML, we have both joint and residual cov/var/...; but for |
|
| 996 |
# categorical = TRUE, we only have residual cov/var...; so, we |
|
| 997 |
# only return residual in both cases, whenever residual |
|
| 998 |
# - since 0.6-3, we always extract the values from the @h1 slot (if present) |
|
| 999 |
# if meanstructure = FALSE, do NOT include $mean elements any longer |
|
| 1000 |
lav_object_inspect_sampstat <- function(object, h1 = TRUE, # nolint |
|
| 1001 |
std = FALSE, |
|
| 1002 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1003 | ||
| 1004 | 153x |
nblocks <- object@Model@nblocks |
| 1005 | 153x |
ov.names <- object@pta$vnames$ov |
| 1006 | 153x |
ov.names.res <- object@pta$vnames$ov.nox |
| 1007 | 153x |
ov.names.x <- object@pta$vnames$ov.x |
| 1008 | ||
| 1009 |
# slots |
|
| 1010 | 153x |
lavsamplestats <- object@SampleStats |
| 1011 | 153x |
lavmodel <- object@Model |
| 1012 | ||
| 1013 |
# if nlevels, override h1 to be TRUE, and set conditional.x = FALSE |
|
| 1014 | 153x |
if (object@Data@nlevels > 1L) {
|
| 1015 | 4x |
h1 <- TRUE |
| 1016 | 4x |
conditional.x <- FALSE # for now (0.6-12) |
| 1017 |
} else {
|
|
| 1018 | 149x |
conditional.x <- lavmodel@conditional.x |
| 1019 |
} |
|
| 1020 | ||
| 1021 |
# check if we have a non-empty @h1 slot |
|
| 1022 | 153x |
if (length(object@h1) == 0L) {
|
| 1023 | ! |
h1 <- FALSE |
| 1024 |
} else {
|
|
| 1025 | 153x |
h1.implied <- object@h1$implied |
| 1026 |
} |
|
| 1027 | ||
| 1028 |
# if h1 = FALSE and nlevels > 1L, nothing to show... |
|
| 1029 | 153x |
if (!h1 && object@Data@nlevels > 1L) {
|
| 1030 | ! |
lav_msg_stop(gettext( |
| 1031 | ! |
"sample statistics not available; refit with option h1 = TRUE")) |
| 1032 |
} |
|
| 1033 | ||
| 1034 | 153x |
return.value <- vector("list", length = nblocks)
|
| 1035 | 153x |
for (b in seq_len(nblocks)) {
|
| 1036 | ||
| 1037 | 172x |
if (!conditional.x) {
|
| 1038 |
# covariance matrix |
|
| 1039 | 167x |
if (h1) {
|
| 1040 | 167x |
return.value[[b]]$cov <- h1.implied$cov[[b]] |
| 1041 |
} else {
|
|
| 1042 | ! |
return.value[[b]]$cov <- lavsamplestats@cov[[b]] |
| 1043 |
} |
|
| 1044 | 167x |
if (std) {
|
| 1045 | ! |
diag.orig <- diag(return.value[[b]]$cov) |
| 1046 | ! |
return.value[[b]]$cov <- cov2cor(return.value[[b]]$cov) |
| 1047 |
} |
|
| 1048 | 167x |
if (add.labels && !is.null(return.value[[b]]$cov)) {
|
| 1049 | 98x |
rownames(return.value[[b]]$cov) <- colnames(return.value[[b]]$cov) <- |
| 1050 | 98x |
ov.names[[b]] |
| 1051 |
} |
|
| 1052 | 167x |
if (add.class) {
|
| 1053 | 82x |
class(return.value[[b]]$cov) <- c("lavaan.matrix.symmetric", "matrix")
|
| 1054 |
} |
|
| 1055 | ||
| 1056 |
# mean vector |
|
| 1057 | 167x |
if (lavmodel@meanstructure) {
|
| 1058 | 98x |
if (h1) {
|
| 1059 | 98x |
return.value[[b]]$mean <- as.numeric(h1.implied$mean[[b]]) |
| 1060 |
} else {
|
|
| 1061 | ! |
return.value[[b]]$mean <- as.numeric(lavsamplestats@mean[[b]]) |
| 1062 |
} |
|
| 1063 | 98x |
if (std) {
|
| 1064 | ! |
diag.orig[diag.orig < .Machine$double.eps] <- NA |
| 1065 | ! |
return.value[[b]]$mean <- return.value[[b]]$mean / sqrt(diag.orig) |
| 1066 |
} |
|
| 1067 | 98x |
if (add.labels) {
|
| 1068 | 68x |
names(return.value[[b]]$mean) <- ov.names[[b]] |
| 1069 |
} |
|
| 1070 | 98x |
if (add.class) {
|
| 1071 | 52x |
class(return.value[[b]]$mean) <- c("lavaan.vector", "numeric")
|
| 1072 |
} |
|
| 1073 |
} |
|
| 1074 | ||
| 1075 |
# thresholds |
|
| 1076 | 167x |
if (lavmodel@categorical) {
|
| 1077 | ! |
if (h1) {
|
| 1078 | ! |
return.value[[b]]$th <- as.numeric(h1.implied$th[[b]]) |
| 1079 |
} else {
|
|
| 1080 | ! |
return.value[[b]]$th <- as.numeric(lavsamplestats@th[[b]]) |
| 1081 |
} |
|
| 1082 | ! |
if (length(lavmodel@num.idx[[b]]) > 0L) {
|
| 1083 | ! |
num.idx <- which(lavmodel@th.idx[[b]] == 0) |
| 1084 | ! |
return.value[[b]]$th <- return.value[[b]]$th[-num.idx] |
| 1085 |
} |
|
| 1086 |
# FIXME: what to do if std = TRUE (depends on delta/theta) |
|
| 1087 | ! |
if (add.labels) {
|
| 1088 | ! |
names(return.value[[b]]$th) <- object@pta$vnames$th[[b]] |
| 1089 |
} |
|
| 1090 | ! |
if (add.class) {
|
| 1091 | ! |
class(return.value[[b]]$th) <- c("lavaan.vector", "numeric")
|
| 1092 |
} |
|
| 1093 |
} |
|
| 1094 |
# !conditional.x |
|
| 1095 |
} else {
|
|
| 1096 |
# if conditional.x = TRUE |
|
| 1097 | ||
| 1098 |
# residual covariance matrix |
|
| 1099 | 5x |
if (h1) {
|
| 1100 | 5x |
return.value[[b]]$res.cov <- h1.implied$res.cov[[b]] |
| 1101 |
} else {
|
|
| 1102 | ! |
return.value[[b]]$res.cov <- lavsamplestats@res.cov[[b]] |
| 1103 |
} |
|
| 1104 | 5x |
if (std) {
|
| 1105 | ! |
diag.orig <- diag(return.value[[b]]$res.cov) |
| 1106 | ! |
return.value[[b]]$res.cov <- cov2cor(return.value[[b]]$res.cov) |
| 1107 |
} |
|
| 1108 | 5x |
if (add.labels) {
|
| 1109 | 2x |
rownames(return.value[[b]]$res.cov) <- |
| 1110 | 2x |
colnames(return.value[[b]]$res.cov) <- |
| 1111 | 2x |
ov.names.res[[b]] |
| 1112 |
} |
|
| 1113 | 5x |
if (add.class) {
|
| 1114 | 2x |
class(return.value[[b]]$res.cov) <- |
| 1115 | 2x |
c("lavaan.matrix.symmetric", "matrix")
|
| 1116 |
} |
|
| 1117 | ||
| 1118 |
# intercepts |
|
| 1119 | 5x |
if (lavmodel@meanstructure) {
|
| 1120 | 5x |
if (h1) {
|
| 1121 | 5x |
return.value[[b]]$res.int <- as.numeric(h1.implied$res.int[[b]]) |
| 1122 |
} else {
|
|
| 1123 | ! |
return.value[[b]]$res.int <- as.numeric(lavsamplestats@res.int[[b]]) |
| 1124 |
} |
|
| 1125 | 5x |
if (std) {
|
| 1126 | ! |
diag.orig[diag.orig < .Machine$double.eps] <- NA |
| 1127 | ! |
return.value[[b]]$res.int <- return.value[[b]]$res.int / |
| 1128 | ! |
sqrt(diag.orig) |
| 1129 |
} |
|
| 1130 | 5x |
if (add.labels) {
|
| 1131 | 2x |
names(return.value[[b]]$res.int) <- ov.names.res[[b]] |
| 1132 |
} |
|
| 1133 | 5x |
if (add.class) {
|
| 1134 | 2x |
class(return.value[[b]]$res.int) <- c("lavaan.vector", "numeric")
|
| 1135 |
} |
|
| 1136 |
} |
|
| 1137 | ||
| 1138 |
# thresholds |
|
| 1139 | 5x |
if (lavmodel@categorical) {
|
| 1140 | 5x |
if (h1) {
|
| 1141 | 5x |
return.value[[b]]$res.th <- as.numeric(h1.implied$res.th[[b]]) |
| 1142 |
} else {
|
|
| 1143 | ! |
return.value[[b]]$res.th <- as.numeric(lavsamplestats@res.th[[b]]) |
| 1144 |
} |
|
| 1145 | 5x |
if (length(lavmodel@num.idx[[b]]) > 0L) {
|
| 1146 | 5x |
num.idx <- which(lavmodel@th.idx[[b]] == 0) |
| 1147 | 5x |
return.value[[b]]$res.th <- return.value[[b]]$res.th[-num.idx] |
| 1148 |
} |
|
| 1149 |
# FIXME: if std: what to do? |
|
| 1150 | 5x |
if (add.labels) {
|
| 1151 | 2x |
names(return.value[[b]]$res.th) <- object@pta$vnames$th[[b]] |
| 1152 |
} |
|
| 1153 | 5x |
if (add.class) {
|
| 1154 | 2x |
class(return.value[[b]]$res.th) <- c("lavaan.vector", "numeric")
|
| 1155 |
} |
|
| 1156 |
} |
|
| 1157 | ||
| 1158 |
# slopes |
|
| 1159 | 5x |
if (lavmodel@nexo[b] > 0L) {
|
| 1160 | 5x |
if (h1) {
|
| 1161 | 5x |
return.value[[b]]$res.slopes <- h1.implied$res.slopes[[b]] |
| 1162 |
} else {
|
|
| 1163 | ! |
return.value[[b]]$res.slopes <- lavsamplestats@res.slopes[[b]] |
| 1164 |
} |
|
| 1165 |
# FIXME: if std: what to do? (here: b.z = b * s.x /s.y) |
|
| 1166 | 5x |
if (std) {
|
| 1167 | ! |
tmp.y <- matrix(sqrt(diag.orig), |
| 1168 | ! |
nrow(return.value[[b]]$res.slopes), |
| 1169 | ! |
ncol(return.value[[b]]$res.slopes)) |
| 1170 | ! |
tmp.x <- matrix(sqrt(diag(lavsamplestats@cov.x[[b]])), |
| 1171 | ! |
nrow(return.value[[b]]$res.slopes), |
| 1172 | ! |
ncol(return.value[[b]]$res.slopes), byrow = TRUE) |
| 1173 | ! |
return.value[[b]]$res.slopes <- return.value[[b]]$res.slopes / |
| 1174 | ! |
tmp.y * tmp.x |
| 1175 |
} |
|
| 1176 | 5x |
if (add.labels) {
|
| 1177 | 2x |
rownames(return.value[[b]]$res.slopes) <- ov.names.res[[b]] |
| 1178 | 2x |
colnames(return.value[[b]]$res.slopes) <- ov.names.x[[b]] |
| 1179 |
} |
|
| 1180 | 5x |
if (add.class) {
|
| 1181 | 2x |
class(return.value[[b]]$res.slopes) <- c("lavaan.matrix", "matrix")
|
| 1182 |
} |
|
| 1183 |
} |
|
| 1184 | ||
| 1185 |
# cov.x |
|
| 1186 | 5x |
if (lavmodel@nexo[b] > 0L) {
|
| 1187 | 5x |
return.value[[b]]$cov.x <- lavsamplestats@cov.x[[b]] |
| 1188 | 5x |
if (std) {
|
| 1189 | ! |
diag.orig <- diag(return.value[[b]]$cov.x) |
| 1190 | ! |
return.value[[b]]$cov.x <- cov2cor(return.value[[b]]$cov.x) |
| 1191 |
} |
|
| 1192 | 5x |
if (add.labels) {
|
| 1193 | 2x |
rownames(return.value[[b]]$cov.x) <- ov.names.x[[b]] |
| 1194 | 2x |
colnames(return.value[[b]]$cov.x) <- ov.names.x[[b]] |
| 1195 |
} |
|
| 1196 | 5x |
if (add.class) {
|
| 1197 | 2x |
class(return.value[[b]]$cov.x) <- |
| 1198 | 2x |
c("lavaan.matrix.symmetric", "matrix")
|
| 1199 |
} |
|
| 1200 |
} |
|
| 1201 | ||
| 1202 |
# mean.x |
|
| 1203 | 5x |
if (lavmodel@nexo[b] > 0L) {
|
| 1204 | 5x |
return.value[[b]]$mean.x <- as.numeric(object@SampleStats@mean.x[[b]]) |
| 1205 | 5x |
if (std) {
|
| 1206 | ! |
diag.orig[diag.orig < .Machine$double.eps] <- NA |
| 1207 | ! |
return.value[[b]]$mean.x <- return.value[[b]]$mean.x / sqrt(diag.orig) |
| 1208 |
} |
|
| 1209 | 5x |
if (add.labels) {
|
| 1210 | 2x |
names(return.value[[b]]$mean.x) <- ov.names.x[[b]] |
| 1211 |
} |
|
| 1212 | 5x |
if (add.class) {
|
| 1213 | 2x |
class(return.value[[b]]$mean.x) <- c("lavaan.vector", "numeric")
|
| 1214 |
} |
|
| 1215 |
} |
|
| 1216 | ||
| 1217 |
} # conditional.x |
|
| 1218 | ||
| 1219 |
# stochastic weights |
|
| 1220 | 172x |
if (lavmodel@group.w.free) {
|
| 1221 |
# to be consistent with the 'implied' values, |
|
| 1222 |
# transform so group.w is the 'log(group.freq)' |
|
| 1223 | ! |
return.value[[b]]$group.w <- |
| 1224 | ! |
log(lavsamplestats@group.w[[b]] * lavsamplestats@ntotal) |
| 1225 | ! |
if (add.labels) {
|
| 1226 | ! |
names(return.value[[b]]$group.w) <- "w" |
| 1227 |
} |
|
| 1228 | ! |
if (add.class) {
|
| 1229 | ! |
class(return.value[[b]]$group.w) <- c("lavaan.vector", "numeric")
|
| 1230 |
} |
|
| 1231 |
} |
|
| 1232 |
} |
|
| 1233 | ||
| 1234 | 153x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1235 | 36x |
return.value <- return.value[[1]] |
| 1236 | 117x |
} else if (nblocks > 1L) {
|
| 1237 | 11x |
names(return.value) <- object@Data@block.label |
| 1238 |
} |
|
| 1239 | ||
| 1240 | 153x |
return.value |
| 1241 |
} |
|
| 1242 | ||
| 1243 | ||
| 1244 |
lav_object_inspect_data <- function(object, add.labels = FALSE, |
|
| 1245 |
drop.list.single.group = FALSE) {
|
|
| 1246 | ||
| 1247 | ! |
n.g <- object@Data@ngroups |
| 1248 | ! |
if (object@Model@conditional.x) {
|
| 1249 | ! |
return.value <- vector("list", length = n.g)
|
| 1250 | ! |
for (g in 1:n.g) {
|
| 1251 | ! |
return.value[[g]] <- cbind(object@Data@X[[g]], |
| 1252 | ! |
object@Data@eXo[[g]]) |
| 1253 |
} |
|
| 1254 |
} else {
|
|
| 1255 | ! |
return.value <- object@Data@X |
| 1256 |
} |
|
| 1257 | ||
| 1258 | ! |
if (add.labels) {
|
| 1259 | ! |
for (g in 1:n.g) {
|
| 1260 | ! |
if (object@Model@conditional.x) {
|
| 1261 | ! |
colnames(return.value[[g]]) <- c(object@Data@ov.names[[g]], |
| 1262 | ! |
object@Data@ov.names.x[[g]]) |
| 1263 |
} else {
|
|
| 1264 | ! |
colnames(return.value[[g]]) <- object@Data@ov.names[[g]] |
| 1265 |
} |
|
| 1266 |
} |
|
| 1267 |
} |
|
| 1268 | ||
| 1269 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 1270 | ! |
return.value <- return.value[[1]] |
| 1271 |
} else {
|
|
| 1272 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 1273 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 1274 |
} |
|
| 1275 |
} |
|
| 1276 | ||
| 1277 | ! |
return.value |
| 1278 |
} |
|
| 1279 | ||
| 1280 |
lav_object_inspect_case_idx <- function(object, |
|
| 1281 |
drop.list.single.group = FALSE) {
|
|
| 1282 | ! |
n.g <- object@Data@ngroups |
| 1283 | ||
| 1284 | ! |
return.value <- object@Data@case.idx |
| 1285 | ||
| 1286 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 1287 | ! |
return.value <- return.value[[1]] |
| 1288 |
} else {
|
|
| 1289 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 1290 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 1291 |
} |
|
| 1292 |
} |
|
| 1293 | ||
| 1294 | ! |
return.value |
| 1295 |
} |
|
| 1296 | ||
| 1297 |
# lav_object_inspect_case_idx <- function(object, level = 1L, |
|
| 1298 |
# drop.list.single.group = FALSE) {
|
|
| 1299 |
# #FIXME: if lavaan ever allows 3-level or cross-classifed models, |
|
| 1300 |
# # "level=" should be a character indicating the clustering variable |
|
| 1301 |
# |
|
| 1302 |
# n.g <- object@Data@ngroups |
|
| 1303 |
# nlevels <- object@Data@nlevels |
|
| 1304 |
# if (nlevels == 1L) level <- 1L |
|
| 1305 |
# # if what="cluster.idx" for single-level model |
|
| 1306 |
# |
|
| 1307 |
# if (level == 2L) {
|
|
| 1308 |
# # level-2 (cluster) IDs |
|
| 1309 |
# return.value <- lapply(object@Data@Lp, function(gg) |
|
| 1310 |
# gg$cluster.id[[2]][ gg$cluster.idx[[2]] ]) |
|
| 1311 |
# #FIXME: update if lavaan ever accepts 3-level or |
|
| 1312 |
# cross-classified models |
|
| 1313 |
# |
|
| 1314 |
# } else return.value <- object@Data@case.idx # level-1 (casewise) IDs |
|
| 1315 |
# |
|
| 1316 |
# if(n.g == 1L && drop.list.single.group) {
|
|
| 1317 |
# return.value <- return.value[[1]] |
|
| 1318 |
# } else {
|
|
| 1319 |
# if(length(object@Data@group.label) > 0L) {
|
|
| 1320 |
# names(return.value) <- unlist(object@Data@group.label) |
|
| 1321 |
# } |
|
| 1322 |
# } |
|
| 1323 |
# return.value |
|
| 1324 |
# } |
|
| 1325 |
# |
|
| 1326 | ||
| 1327 |
# cluster info |
|
| 1328 |
lav_object_inspect_cluster_info <- function( # nolint |
|
| 1329 |
object, |
|
| 1330 |
what = "cluster.size", |
|
| 1331 |
level = 2L, |
|
| 1332 |
drop.list.single.group = FALSE) {
|
|
| 1333 | ||
| 1334 | ! |
n.g <- object@Data@ngroups |
| 1335 | ! |
nlevels <- object@Data@nlevels |
| 1336 | ||
| 1337 |
# just in case we have no clusters |
|
| 1338 | ! |
if (nlevels == 1L) {
|
| 1339 | ! |
if (what %in% c("nclusters", "ncluster.size", "cluster.id")) {
|
| 1340 | ! |
return.value <- as.list(rep(1L, n.g)) |
| 1341 | ! |
} else if (what %in% c("cluster.size", "cluster.sizes")) {
|
| 1342 | ! |
return.value <- object@Data@nobs |
| 1343 | ! |
} else if (what %in% c("cluster.idx", "cluster.label")) {
|
| 1344 |
# everybody belongs to cluster 1 |
|
| 1345 | ! |
return.value <- lapply(seq_len(n.g), |
| 1346 | ! |
function(gg) rep(1L, object@Data@nobs[[gg]])) |
| 1347 |
} |
|
| 1348 |
} |
|
| 1349 | ||
| 1350 |
# if we do have clusters |
|
| 1351 | ! |
if (nlevels > 1L) {
|
| 1352 | ! |
return.value <- vector("list", length = n.g)
|
| 1353 | ||
| 1354 | ! |
for (g in seq_len(n.g)) {
|
| 1355 | ! |
tmp.lp <- object@Data@Lp[[g]] |
| 1356 | ! |
if (what == "nclusters") {
|
| 1357 | ! |
return.value[[g]] <- tmp.lp$nclusters[[level]] |
| 1358 | ! |
} else if (what == "ncluster.size") {
|
| 1359 | ! |
return.value[[g]] <- tmp.lp$ncluster.size[[level]] |
| 1360 | ! |
} else if (what == "cluster.size") {
|
| 1361 | ! |
return.value[[g]] <- tmp.lp$cluster.size[[level]] |
| 1362 | ! |
} else if (what == "cluster.id") {
|
| 1363 | ! |
return.value[[g]] <- tmp.lp$cluster.id[[level]] |
| 1364 | ! |
} else if (what == "cluster.idx") {
|
| 1365 | ! |
return.value[[g]] <- tmp.lp$cluster.idx[[level]] |
| 1366 | ! |
} else if (what == "cluster.label") {
|
| 1367 | ! |
return.value[[g]] <- |
| 1368 | ! |
tmp.lp$cluster.id[[level]][tmp.lp$cluster.idx[[level]]] |
| 1369 | ! |
} else if (what == "cluster.sizes") {
|
| 1370 | ! |
return.value[[g]] <- tmp.lp$cluster.sizes[[level]] |
| 1371 | ! |
} else if (what == "average.cluster.size") {
|
| 1372 | ! |
nn.g <- object@Data@nobs[[g]] |
| 1373 | ! |
cluster.size <- tmp.lp$cluster.size[[level]] |
| 1374 | ! |
nclusters <- tmp.lp$nclusters[[level]] |
| 1375 | ! |
return.value[[g]] <- (nn.g^2 - sum(cluster.size^2)) / |
| 1376 | ! |
(nn.g * (nclusters - 1L)) |
| 1377 |
} |
|
| 1378 |
} # g |
|
| 1379 |
} # nlevels > 1L |
|
| 1380 | ||
| 1381 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 1382 | ! |
return.value <- return.value[[1]] |
| 1383 |
} else {
|
|
| 1384 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 1385 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 1386 |
} |
|
| 1387 |
} |
|
| 1388 | ||
| 1389 | ! |
return.value |
| 1390 |
} |
|
| 1391 | ||
| 1392 | ||
| 1393 |
# count the number of clusters, or obtain tmp.n within each cluster |
|
| 1394 |
# lav_object_inspect_ncluster <- function(object, sizes = FALSE, #level = 2L, |
|
| 1395 |
# drop.list.single.group = FALSE) {
|
|
| 1396 |
# n.g <- object@Data@ngroups |
|
| 1397 |
# nlevels <- object@Data@nlevels |
|
| 1398 |
# |
|
| 1399 |
# if (nlevels == 1L) {
|
|
| 1400 |
# # single-level model, return sample size(s) or count 1 cluster per group |
|
| 1401 |
# return.value <- if (sizes) unlist(object@Data@nobs) else rep(1L, n.g) |
|
| 1402 |
# |
|
| 1403 |
# } else if (sizes) {
|
|
| 1404 |
# # for each group, a vector of cluster sizes |
|
| 1405 |
# return.value <- lapply(object@Data@Lp, function(gg) gg$cluster.size[[2]]) |
|
| 1406 |
# #FIXME: update if lavaan ever accepts 3-level or cross-classified models |
|
| 1407 |
# |
|
| 1408 |
# if (n.g == 1L && drop.list.single.group) |
|
| 1409 |
# return.value <- return.value[[1]] |
|
| 1410 |
# |
|
| 1411 |
# } else {
|
|
| 1412 |
# # number of clusters in each group |
|
| 1413 |
# return.value <- sapply(object@Data@Lp, function(gg) gg$nclusters[[2]]) |
|
| 1414 |
# #FIXME: update if lavaan ever accepts 3-level or cross-classified models |
|
| 1415 |
# } |
|
| 1416 |
# |
|
| 1417 |
# # assign group names, if applicable |
|
| 1418 |
# if (n.g > 1L) names(return.value) <- unlist(object@Data@group.label) |
|
| 1419 |
# return.value |
|
| 1420 |
# } |
|
| 1421 | ||
| 1422 |
lav_object_inspect_rsquare <- function(object, est.std.all = NULL, |
|
| 1423 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1424 | ||
| 1425 | 20x |
nblocks <- object@Model@nblocks |
| 1426 | 20x |
return.value <- vector("list", length = nblocks)
|
| 1427 | ||
| 1428 | 20x |
if (is.null(est.std.all)) {
|
| 1429 | 20x |
est.std.all <- lav_standardize_all(object) |
| 1430 |
} |
|
| 1431 | ||
| 1432 | 20x |
partable <- object@ParTable |
| 1433 | 20x |
partable$rsquare <- 1.0 - est.std.all |
| 1434 |
# no values > 1.0 |
|
| 1435 | 20x |
partable$rsquare[partable$rsquare > 1.0] <- as.numeric(NA) |
| 1436 | ||
| 1437 | 20x |
for (b in seq_len(nblocks)) {
|
| 1438 | 24x |
ind.names <- partable$rhs[which(partable$op == "=~" & |
| 1439 | 24x |
partable$block == b)] |
| 1440 | 24x |
eqs.y.names <- partable$lhs[which(partable$op == "~" & |
| 1441 | 24x |
partable$block == b)] |
| 1442 | 24x |
y.names <- unique(c(ind.names, eqs.y.names)) |
| 1443 | ||
| 1444 | 24x |
idx <- which(partable$op == "~~" & partable$lhs %in% y.names & |
| 1445 | 24x |
partable$rhs == partable$lhs & partable$block == b) |
| 1446 | 24x |
tmp <- partable$rsquare[idx] |
| 1447 | ||
| 1448 | 24x |
if (add.labels && length(tmp) > 0L) {
|
| 1449 | 24x |
names(tmp) <- partable$lhs[idx] |
| 1450 |
} |
|
| 1451 | 24x |
if (add.class) {
|
| 1452 | 24x |
class(tmp) <- c("lavaan.vector", "numeric")
|
| 1453 |
} |
|
| 1454 | ||
| 1455 | 24x |
return.value[[b]] <- tmp |
| 1456 |
} |
|
| 1457 | ||
| 1458 | 20x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1459 | 18x |
return.value <- return.value[[1]] |
| 1460 | 2x |
} else if (nblocks > 1L) {
|
| 1461 | 2x |
names(return.value) <- object@Data@block.label |
| 1462 |
} |
|
| 1463 | ||
| 1464 | 20x |
return.value |
| 1465 |
} |
|
| 1466 | ||
| 1467 |
# model implied sample stats |
|
| 1468 |
lav_object_inspect_implied <- function(object, # nolint |
|
| 1469 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1470 | ||
| 1471 | 141x |
nblocks <- object@Model@nblocks |
| 1472 | 141x |
ov.names <- object@pta$vnames$ov |
| 1473 | 141x |
ov.names.res <- object@pta$vnames$ov.nox |
| 1474 | 141x |
ov.names.x <- object@pta$vnames$ov.x |
| 1475 | ||
| 1476 |
# slots |
|
| 1477 | 141x |
lavimplied <- object@implied |
| 1478 | 141x |
lavmodel <- object@Model |
| 1479 | ||
| 1480 |
# if nlevels, always set conditional.x = FALSE |
|
| 1481 | 141x |
if (object@Data@nlevels > 1L) {
|
| 1482 | 5x |
lavimplied <- lav_model_implied_cond2uncond(lavimplied) |
| 1483 | 5x |
conditional.x <- FALSE # for now (0.6-12) |
| 1484 |
} else {
|
|
| 1485 | 136x |
conditional.x <- lavmodel@conditional.x |
| 1486 |
} |
|
| 1487 | ||
| 1488 | 141x |
return.value <- vector("list", length = nblocks)
|
| 1489 | 141x |
for (b in seq_len(nblocks)) {
|
| 1490 | ||
| 1491 | 164x |
if (!conditional.x) {
|
| 1492 |
# covariance matrix |
|
| 1493 | 159x |
return.value[[b]]$cov <- lavimplied$cov[[b]] |
| 1494 | 159x |
if (add.labels && !is.null(return.value[[b]]$cov)) {
|
| 1495 | 90x |
rownames(return.value[[b]]$cov) <- colnames(return.value[[b]]$cov) <- |
| 1496 | 90x |
ov.names[[b]] |
| 1497 |
} |
|
| 1498 | 159x |
if (add.class) {
|
| 1499 | 90x |
class(return.value[[b]]$cov) <- c("lavaan.matrix.symmetric", "matrix")
|
| 1500 |
} |
|
| 1501 | ||
| 1502 |
# mean vector |
|
| 1503 | 159x |
if (lavmodel@meanstructure) {
|
| 1504 | 87x |
return.value[[b]]$mean <- as.numeric(lavimplied$mean[[b]]) |
| 1505 | 87x |
if (add.labels) {
|
| 1506 | 57x |
names(return.value[[b]]$mean) <- ov.names[[b]] |
| 1507 |
} |
|
| 1508 | 87x |
if (add.class) {
|
| 1509 | 57x |
class(return.value[[b]]$mean) <- c("lavaan.vector", "numeric")
|
| 1510 |
} |
|
| 1511 |
} |
|
| 1512 | ||
| 1513 |
# thresholds |
|
| 1514 | 159x |
if (lavmodel@categorical) {
|
| 1515 | ! |
return.value[[b]]$th <- as.numeric(lavimplied$th[[b]]) |
| 1516 | ! |
if (length(object@Model@num.idx[[b]]) > 0L) {
|
| 1517 | ! |
num.idx <- which(object@Model@th.idx[[b]] == 0) |
| 1518 | ! |
return.value[[b]]$th <- return.value[[b]]$th[-num.idx] |
| 1519 |
} |
|
| 1520 | ! |
if (add.labels) {
|
| 1521 | ! |
names(return.value[[b]]$th) <- object@pta$vnames$th[[b]] |
| 1522 |
} |
|
| 1523 | ! |
if (add.class) {
|
| 1524 | ! |
class(return.value[[b]]$th) <- c("lavaan.vector", "numeric")
|
| 1525 |
} |
|
| 1526 |
} |
|
| 1527 |
# !conditional.x |
|
| 1528 |
} else {
|
|
| 1529 |
# if conditional.x = TRUE |
|
| 1530 |
# residual covariance matrix |
|
| 1531 | 5x |
return.value[[b]]$res.cov <- lavimplied$res.cov[[b]] |
| 1532 | 5x |
if (add.labels) {
|
| 1533 | 2x |
rownames(return.value[[b]]$res.cov) <- |
| 1534 | 2x |
colnames(return.value[[b]]$res.cov) <- |
| 1535 | 2x |
ov.names.res[[b]] |
| 1536 |
} |
|
| 1537 | 5x |
if (add.class) {
|
| 1538 | 2x |
class(return.value[[b]]$res.cov) <- |
| 1539 | 2x |
c("lavaan.matrix.symmetric", "matrix")
|
| 1540 |
} |
|
| 1541 | ||
| 1542 |
# intercepts |
|
| 1543 | 5x |
if (lavmodel@meanstructure) {
|
| 1544 | 5x |
return.value[[b]]$res.int <- as.numeric(lavimplied$res.int[[b]]) |
| 1545 | 5x |
if (add.labels) {
|
| 1546 | 2x |
names(return.value[[b]]$res.int) <- ov.names.res[[b]] |
| 1547 |
} |
|
| 1548 | 5x |
if (add.class) {
|
| 1549 | 2x |
class(return.value[[b]]$res.int) <- c("lavaan.vector", "numeric")
|
| 1550 |
} |
|
| 1551 |
} |
|
| 1552 | ||
| 1553 |
# thresholds |
|
| 1554 | 5x |
if (lavmodel@categorical) {
|
| 1555 | 5x |
return.value[[b]]$res.th <- as.numeric(lavimplied$res.th[[b]]) |
| 1556 | 5x |
if (length(object@Model@num.idx[[b]]) > 0L) {
|
| 1557 | 5x |
num.idx <- which(object@Model@th.idx[[b]] == 0) |
| 1558 | 5x |
return.value[[b]]$res.th <- return.value[[b]]$res.th[-num.idx] |
| 1559 |
} |
|
| 1560 | 5x |
if (add.labels) {
|
| 1561 | 2x |
names(return.value[[b]]$res.th) <- object@pta$vnames$th[[b]] |
| 1562 |
} |
|
| 1563 | 5x |
if (add.class) {
|
| 1564 | 2x |
class(return.value[[b]]$res.th) <- c("lavaan.vector", "numeric")
|
| 1565 |
} |
|
| 1566 |
} |
|
| 1567 | ||
| 1568 |
# slopes |
|
| 1569 | 5x |
if (lavmodel@nexo[b] > 0L) {
|
| 1570 | 5x |
return.value[[b]]$res.slopes <- lavimplied$res.slopes[[b]] |
| 1571 | 5x |
if (add.labels) {
|
| 1572 | 2x |
rownames(return.value[[b]]$res.slopes) <- ov.names.res[[b]] |
| 1573 | 2x |
colnames(return.value[[b]]$res.slopes) <- ov.names.x[[b]] |
| 1574 |
} |
|
| 1575 | 5x |
if (add.class) {
|
| 1576 | 2x |
class(return.value[[b]]$res.slopes) <- c("lavaan.matrix", "matrix")
|
| 1577 |
} |
|
| 1578 |
} |
|
| 1579 | ||
| 1580 |
# cov.x |
|
| 1581 | 5x |
if (lavmodel@nexo[b] > 0L) {
|
| 1582 | 5x |
return.value[[b]]$cov.x <- lavimplied$cov.x[[b]] |
| 1583 | 5x |
if (add.labels) {
|
| 1584 | 2x |
rownames(return.value[[b]]$cov.x) <- ov.names.x[[b]] |
| 1585 | 2x |
colnames(return.value[[b]]$cov.x) <- ov.names.x[[b]] |
| 1586 |
} |
|
| 1587 | 5x |
if (add.class) {
|
| 1588 | 2x |
class(return.value[[b]]$cov.x) <- |
| 1589 | 2x |
c("lavaan.matrix.symmetric", "matrix")
|
| 1590 |
} |
|
| 1591 |
} |
|
| 1592 | ||
| 1593 |
# mean.x |
|
| 1594 | 5x |
if (lavmodel@nexo[b] > 0L) {
|
| 1595 | 5x |
return.value[[b]]$mean.x <- as.numeric(lavimplied$mean.x[[b]]) |
| 1596 | 5x |
if (add.labels) {
|
| 1597 | 2x |
names(return.value[[b]]$mean.x) <- ov.names.x[[b]] |
| 1598 |
} |
|
| 1599 | 5x |
if (add.class) {
|
| 1600 | 2x |
class(return.value[[b]]$mean.x) <- c("lavaan.vector", "numeric")
|
| 1601 |
} |
|
| 1602 |
} |
|
| 1603 | ||
| 1604 | ||
| 1605 |
} # conditional.x |
|
| 1606 | ||
| 1607 |
# stochastic weights |
|
| 1608 | 164x |
if (lavmodel@group.w.free) {
|
| 1609 | ! |
return.value[[b]]$group.w <- lavimplied$group.w[[b]] |
| 1610 | ! |
if (add.labels) {
|
| 1611 | ! |
names(return.value[[b]]$group.w) <- "w" # somewhat redundant |
| 1612 |
} |
|
| 1613 | ! |
if (add.class) {
|
| 1614 | ! |
class(return.value[[b]]$group.w) <- c("lavaan.vector", "numeric")
|
| 1615 |
} |
|
| 1616 |
} |
|
| 1617 |
} |
|
| 1618 | ||
| 1619 | 141x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1620 | 38x |
return.value <- return.value[[1]] |
| 1621 | 103x |
} else if (nblocks > 1L) {
|
| 1622 | 13x |
names(return.value) <- object@Data@block.label |
| 1623 |
} |
|
| 1624 | ||
| 1625 | 141x |
return.value |
| 1626 |
} |
|
| 1627 | ||
| 1628 | ||
| 1629 |
# residuals: _inspect_sampstat - _inspect_implied |
|
| 1630 |
lav_object_inspect_residuals <- function(object, h1 = TRUE, |
|
| 1631 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1632 | ||
| 1633 | ! |
lav_residuals(object, type = "raw", h1 = h1, |
| 1634 | ! |
add.labels = add.labels, add.class = add.class, |
| 1635 | ! |
drop.list.single.group = drop.list.single.group) |
| 1636 |
} |
|
| 1637 | ||
| 1638 | ||
| 1639 |
lav_object_inspect_cov_lv <- function(object, correlation.metric = FALSE, |
|
| 1640 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1641 |
# compute lv covar |
|
| 1642 | 67x |
return.value <- lav_model_veta(lavmodel = object@Model, remove.dummy.lv = TRUE) |
| 1643 | ||
| 1644 |
# nblocks |
|
| 1645 | 67x |
nblocks <- length(return.value) |
| 1646 | ||
| 1647 |
# cor + labels + class |
|
| 1648 | 67x |
for (b in seq_len(nblocks)) {
|
| 1649 | ||
| 1650 | 83x |
if (correlation.metric && nrow(return.value[[b]]) > 1L) {
|
| 1651 |
# note: cov2cor fails if matrix is empty! |
|
| 1652 | 12x |
return.value[[b]] <- cov2cor(return.value[[b]]) |
| 1653 |
} |
|
| 1654 | ||
| 1655 | 83x |
if (add.labels) {
|
| 1656 | 48x |
colnames(return.value[[b]]) <- rownames(return.value[[b]]) <- |
| 1657 | 48x |
object@pta$vnames$lv[[b]] |
| 1658 |
} |
|
| 1659 | ||
| 1660 | 83x |
if (add.class) {
|
| 1661 | 48x |
class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 1662 |
} |
|
| 1663 |
} |
|
| 1664 | ||
| 1665 | 67x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1666 | 36x |
return.value <- return.value[[1]] |
| 1667 | 31x |
} else if (nblocks > 1L) {
|
| 1668 | 8x |
names(return.value) <- object@Data@block.label |
| 1669 |
} |
|
| 1670 | ||
| 1671 | 67x |
return.value |
| 1672 |
} |
|
| 1673 | ||
| 1674 |
lav_object_inspect_mean_lv <- function(object, |
|
| 1675 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1676 |
# compute lv means |
|
| 1677 | 20x |
return.value <- lav_model_eeta(lavmodel = object@Model, |
| 1678 | 20x |
lavsamplestats = object@SampleStats, |
| 1679 | 20x |
remove.dummy.lv = TRUE) |
| 1680 | ||
| 1681 |
# nblocks |
|
| 1682 | 20x |
nblocks <- length(return.value) |
| 1683 | ||
| 1684 |
# ensure numeric |
|
| 1685 | 20x |
return.value <- lapply(return.value, as.numeric) |
| 1686 | ||
| 1687 |
# labels + class |
|
| 1688 | 20x |
for (b in seq_len(nblocks)) {
|
| 1689 | 24x |
if (add.labels && length(return.value[[b]]) > 0L) {
|
| 1690 | 16x |
names(return.value[[b]]) <- object@pta$vnames$lv[[b]] |
| 1691 |
} |
|
| 1692 | 24x |
if (add.class) {
|
| 1693 | 24x |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 1694 |
} |
|
| 1695 |
} |
|
| 1696 | ||
| 1697 | 20x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1698 | 18x |
return.value <- return.value[[1]] |
| 1699 | 2x |
} else if (nblocks > 1L) {
|
| 1700 | 2x |
names(return.value) <- object@Data@block.label |
| 1701 |
} |
|
| 1702 | ||
| 1703 | 20x |
return.value |
| 1704 |
} |
|
| 1705 | ||
| 1706 |
lav_object_inspect_cov_all <- function(object, correlation.metric = FALSE, |
|
| 1707 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1708 |
# compute extended model implied covariance matrix (both ov and lv) |
|
| 1709 | ! |
return.value <- lav_model_cov_both(lavmodel = object@Model, |
| 1710 | ! |
remove.dummy.lv = TRUE) |
| 1711 | ||
| 1712 |
# nblocks |
|
| 1713 | ! |
nblocks <- length(return.value) |
| 1714 | ||
| 1715 |
# cor + labels + class |
|
| 1716 | ! |
for (b in seq_len(nblocks)) {
|
| 1717 | ||
| 1718 | ! |
if (correlation.metric && nrow(return.value[[b]]) > 1L) {
|
| 1719 |
# note: cov2cor fails if matrix is empty! |
|
| 1720 | ! |
return.value[[b]] <- cov2cor(return.value[[b]]) |
| 1721 |
} |
|
| 1722 | ||
| 1723 | ! |
if (add.labels) {
|
| 1724 | ! |
tmp.names <- c(object@pta$vnames$ov.model[[b]], |
| 1725 | ! |
object@pta$vnames$lv[[b]]) |
| 1726 | ! |
colnames(return.value[[b]]) <- rownames(return.value[[b]]) <- tmp.names |
| 1727 |
} |
|
| 1728 | ! |
if (add.class) {
|
| 1729 | ! |
class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 1730 |
} |
|
| 1731 |
} |
|
| 1732 | ||
| 1733 | ! |
if (nblocks == 1L && drop.list.single.group) {
|
| 1734 | ! |
return.value <- return.value[[1]] |
| 1735 | ! |
} else if (nblocks > 1L) {
|
| 1736 | ! |
names(return.value) <- object@Data@block.label |
| 1737 |
} |
|
| 1738 | ||
| 1739 | ! |
return.value |
| 1740 |
} |
|
| 1741 | ||
| 1742 | ||
| 1743 |
lav_object_inspect_cov_ov <- function(object, correlation.metric = FALSE, |
|
| 1744 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1745 |
# get model-implied covariance matrix observed |
|
| 1746 | 40x |
if (object@Model@conditional.x) {
|
| 1747 | 2x |
return.value <- object@implied$res.cov |
| 1748 |
} else {
|
|
| 1749 | 38x |
return.value <- object@implied$cov |
| 1750 |
} |
|
| 1751 | ||
| 1752 |
# nblocks |
|
| 1753 | 40x |
nblocks <- length(return.value) |
| 1754 | ||
| 1755 |
# cor + labels + class |
|
| 1756 | 40x |
for (b in seq_len(nblocks)) {
|
| 1757 | ||
| 1758 | 48x |
if (correlation.metric && nrow(return.value[[b]]) > 1L) {
|
| 1759 |
# note: cov2cor fails if matrix is empty! |
|
| 1760 | 24x |
return.value[[b]] <- cov2cor(return.value[[b]]) |
| 1761 |
} |
|
| 1762 | ||
| 1763 | 48x |
if (add.labels) {
|
| 1764 | 48x |
colnames(return.value[[b]]) <- rownames(return.value[[b]]) <- |
| 1765 | 48x |
object@pta$vnames$ov.model[[b]] |
| 1766 |
} |
|
| 1767 | 48x |
if (add.class) {
|
| 1768 | 48x |
class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 1769 |
} |
|
| 1770 |
} |
|
| 1771 | ||
| 1772 | 40x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1773 | 36x |
return.value <- return.value[[1]] |
| 1774 |
} else {
|
|
| 1775 | 4x |
names(return.value) <- object@Data@block.label |
| 1776 |
} |
|
| 1777 | ||
| 1778 | 40x |
return.value |
| 1779 |
} |
|
| 1780 | ||
| 1781 |
lav_object_inspect_mean_ov <- function(object, |
|
| 1782 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1783 |
# compute ov means |
|
| 1784 | 20x |
if (object@Model@conditional.x) {
|
| 1785 | 1x |
return.value <- object@implied$res.int |
| 1786 |
} else {
|
|
| 1787 | 19x |
return.value <- object@implied$mean |
| 1788 |
} |
|
| 1789 | ||
| 1790 |
# nblocks |
|
| 1791 | 20x |
nblocks <- length(return.value) |
| 1792 | ||
| 1793 |
# make numeric |
|
| 1794 | 20x |
return.value <- lapply(return.value, as.numeric) |
| 1795 | ||
| 1796 |
# labels + class |
|
| 1797 | 20x |
for (b in seq_len(nblocks)) {
|
| 1798 | 24x |
if (add.labels && length(return.value[[b]]) > 0L) {
|
| 1799 | 15x |
names(return.value[[b]]) <- object@pta$vnames$ov.model[[b]] |
| 1800 |
} |
|
| 1801 | 24x |
if (add.class) {
|
| 1802 | 24x |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 1803 |
} |
|
| 1804 |
} |
|
| 1805 | ||
| 1806 | 20x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1807 | 18x |
return.value <- return.value[[1]] |
| 1808 | 2x |
} else if (nblocks > 1L) {
|
| 1809 | 2x |
names(return.value) <- object@Data@block.label |
| 1810 |
} |
|
| 1811 | ||
| 1812 | 20x |
return.value |
| 1813 |
} |
|
| 1814 | ||
| 1815 |
lav_object_inspect_th <- function(object, |
|
| 1816 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1817 |
# thresholds |
|
| 1818 | 20x |
if (object@Model@conditional.x) {
|
| 1819 | 1x |
return.value <- object@implied$res.th |
| 1820 |
} else {
|
|
| 1821 | 19x |
return.value <- object@implied$th |
| 1822 |
} |
|
| 1823 | ||
| 1824 |
# nblocks |
|
| 1825 | 20x |
nblocks <- length(return.value) |
| 1826 | ||
| 1827 |
# make numeric |
|
| 1828 | 20x |
return.value <- lapply(return.value, as.numeric) |
| 1829 | ||
| 1830 |
# labels + class |
|
| 1831 | 20x |
for (b in seq_len(nblocks)) {
|
| 1832 | 23x |
if (length(object@Model@num.idx[[b]]) > 0L) {
|
| 1833 | 23x |
num.idx <- which(object@Model@th.idx[[b]] == 0) |
| 1834 | 22x |
return.value[[b]] <- return.value[[b]][-num.idx] |
| 1835 |
} |
|
| 1836 | 22x |
if (add.labels && length(return.value[[b]]) > 0L) {
|
| 1837 | 1x |
names(return.value[[b]]) <- object@pta$vnames$th[[b]] |
| 1838 |
} |
|
| 1839 | 22x |
if (add.class) {
|
| 1840 | 22x |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 1841 |
} |
|
| 1842 |
} |
|
| 1843 | ||
| 1844 | 19x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1845 | 18x |
return.value <- return.value[[1]] |
| 1846 | 1x |
} else if (nblocks > 1L) {
|
| 1847 | 1x |
names(return.value) <- object@Data@block.label |
| 1848 |
} |
|
| 1849 | ||
| 1850 | 19x |
return.value |
| 1851 |
} |
|
| 1852 | ||
| 1853 |
lav_object_inspect_th_idx <- function(object, |
|
| 1854 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1855 |
# thresholds idx |
|
| 1856 | ! |
return.value <- object@SampleStats@th.idx |
| 1857 | ||
| 1858 |
# nblocks |
|
| 1859 | ! |
nblocks <- length(return.value) |
| 1860 | ||
| 1861 |
# labels + class |
|
| 1862 | ! |
for (b in seq_len(nblocks)) {
|
| 1863 | ! |
if (add.labels && length(return.value[[b]]) > 0L) {
|
| 1864 | ! |
names(return.value[[b]]) <- object@SampleStats@th.names[[b]] |
| 1865 |
} |
|
| 1866 | ! |
if (add.class && !is.null(return.value[[b]])) {
|
| 1867 | ! |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 1868 |
} |
|
| 1869 |
} |
|
| 1870 | ||
| 1871 | ! |
if (nblocks == 1L && drop.list.single.group) {
|
| 1872 | ! |
return.value <- return.value[[1]] |
| 1873 | ! |
} else if (nblocks > 1L) {
|
| 1874 | ! |
names(return.value) <- object@Data@block.label |
| 1875 |
} |
|
| 1876 | ||
| 1877 | ! |
return.value |
| 1878 |
} |
|
| 1879 | ||
| 1880 |
lav_object_inspect_vy <- function(object, |
|
| 1881 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1882 |
# 'unconditional' model-implied variances |
|
| 1883 |
# - same as diag(Sigma.hat) if all Y are continuous) |
|
| 1884 |
# - 1.0 (or delta^2) if categorical |
|
| 1885 |
# - if also Gamma, cov.x is used (only if categorical) |
|
| 1886 | ||
| 1887 | ! |
return.value <- lav_model_vy(lavmodel = object@Model, GLIST = NULL, |
| 1888 | ! |
diagonal.only = TRUE) |
| 1889 | ||
| 1890 |
# nblocks |
|
| 1891 | ! |
nblocks <- length(return.value) |
| 1892 | ||
| 1893 |
# labels + class |
|
| 1894 | ! |
for (b in seq_len(nblocks)) {
|
| 1895 | ! |
if (add.labels && length(return.value[[b]]) > 0L) {
|
| 1896 | ! |
if (object@Model@categorical) {
|
| 1897 | ! |
names(return.value[[b]]) <- object@pta$vnames$ov.nox[[b]] |
| 1898 |
} else {
|
|
| 1899 | ! |
names(return.value[[b]]) <- object@pta$vnames$ov[[b]] |
| 1900 |
} |
|
| 1901 |
} |
|
| 1902 | ! |
if (add.class) {
|
| 1903 | ! |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 1904 |
} |
|
| 1905 |
} |
|
| 1906 | ||
| 1907 | ! |
if (nblocks == 1L && drop.list.single.group) {
|
| 1908 | ! |
return.value <- return.value[[1]] |
| 1909 | ! |
} else if (nblocks > 1L) {
|
| 1910 | ! |
names(return.value) <- object@Data@block.label |
| 1911 |
} |
|
| 1912 | ||
| 1913 | ! |
return.value |
| 1914 |
} |
|
| 1915 | ||
| 1916 |
lav_object_inspect_fs_determinacy <- function(object, |
|
| 1917 |
squared = TRUE, fs.method = "regression", |
|
| 1918 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1919 | ||
| 1920 | ! |
FS <- lavPredict(object, type = "lv", method = fs.method, rel = TRUE) |
| 1921 | ! |
return.value <- attr(FS, "rel") |
| 1922 | ||
| 1923 |
# determinacies or reliabilities? |
|
| 1924 | ! |
if (!squared) {
|
| 1925 | ! |
return.value <- lapply(return.value, sqrt) |
| 1926 |
} |
|
| 1927 | ||
| 1928 |
# nblocks |
|
| 1929 | ! |
nblocks <- length(return.value) |
| 1930 | ||
| 1931 |
# ensure numeric |
|
| 1932 | ! |
return.value <- lapply(return.value, as.numeric) |
| 1933 | ||
| 1934 |
# labels + class |
|
| 1935 | ! |
for (b in seq_len(nblocks)) {
|
| 1936 | ! |
if (add.labels && length(return.value[[b]]) > 0L) {
|
| 1937 | ! |
names(return.value[[b]]) <- object@pta$vnames$lv[[b]] |
| 1938 |
} |
|
| 1939 | ! |
if (add.class) {
|
| 1940 | ! |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 1941 |
} |
|
| 1942 |
} |
|
| 1943 | ||
| 1944 | ! |
if (nblocks == 1L && drop.list.single.group) {
|
| 1945 | ! |
return.value <- return.value[[1]] |
| 1946 | ! |
} else if (nblocks > 1L) {
|
| 1947 | ! |
names(return.value) <- object@Data@block.label |
| 1948 |
} |
|
| 1949 | ||
| 1950 | ! |
return.value |
| 1951 |
} |
|
| 1952 | ||
| 1953 | ||
| 1954 |
lav_object_inspect_theta <- function(object, correlation.metric = FALSE, |
|
| 1955 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1956 |
# get residual covariances |
|
| 1957 | 85x |
return.value <- lav_model_theta(lavmodel = object@Model) |
| 1958 | ||
| 1959 |
# nblocks |
|
| 1960 | 85x |
nblocks <- length(return.value) |
| 1961 | ||
| 1962 |
# labels + class |
|
| 1963 | 85x |
for (b in seq_len(nblocks)) {
|
| 1964 | ||
| 1965 | 101x |
if (correlation.metric && nrow(return.value[[b]]) > 0L) {
|
| 1966 | 24x |
if (all(return.value[[b]] == 0)) {
|
| 1967 | ! |
return.value[[b]] <- return.value[[b]] |
| 1968 |
} else {
|
|
| 1969 | 24x |
return.value[[b]] <- cov2cor(return.value[[b]]) |
| 1970 |
} |
|
| 1971 |
} |
|
| 1972 | ||
| 1973 | 101x |
if (add.labels && length(return.value[[b]]) > 0L) {
|
| 1974 | 48x |
colnames(return.value[[b]]) <- rownames(return.value[[b]]) <- |
| 1975 | 48x |
object@pta$vnames$ov.model[[b]] |
| 1976 |
} |
|
| 1977 | ||
| 1978 | 101x |
if (add.class) {
|
| 1979 | 48x |
class(return.value[[b]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 1980 |
} |
|
| 1981 |
} |
|
| 1982 | ||
| 1983 | 85x |
if (nblocks == 1L && drop.list.single.group) {
|
| 1984 | 36x |
return.value <- return.value[[1]] |
| 1985 | 49x |
} else if (nblocks > 1L) {
|
| 1986 | 8x |
names(return.value) <- object@Data@block.label |
| 1987 |
} |
|
| 1988 | ||
| 1989 | 85x |
return.value |
| 1990 |
} |
|
| 1991 | ||
| 1992 | ||
| 1993 |
lav_object_inspect_missing_coverage <- function(object, # nolint |
|
| 1994 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 1995 | ||
| 1996 | 20x |
n.g <- object@Data@ngroups |
| 1997 | 20x |
return.value <- vector("list", n.g)
|
| 1998 | ||
| 1999 | 20x |
for (g in 1:n.g) {
|
| 2000 | 22x |
if (!is.null(object@Data@Mp[[g]])) {
|
| 2001 | 5x |
return.value[[g]] <- object@Data@Mp[[g]]$coverage |
| 2002 |
} else {
|
|
| 2003 | 17x |
nvar <- length(object@Data@ov.names[[g]]) |
| 2004 | 17x |
return.value[[g]] <- matrix(1.0, nvar, nvar) |
| 2005 |
} |
|
| 2006 | ||
| 2007 | 22x |
if (add.labels && length(return.value[[g]]) > 0L) {
|
| 2008 | 22x |
colnames(return.value[[g]]) <- rownames(return.value[[g]]) <- |
| 2009 | 22x |
object@pta$vnames$ov.model[[g]] |
| 2010 |
} |
|
| 2011 | ||
| 2012 | 22x |
if (add.class) {
|
| 2013 | 22x |
class(return.value[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2014 |
} |
|
| 2015 |
} |
|
| 2016 | ||
| 2017 | 20x |
if (n.g == 1L && drop.list.single.group) {
|
| 2018 | 18x |
return.value <- return.value[[1]] |
| 2019 |
} else {
|
|
| 2020 | 2x |
if (length(object@Data@group.label) > 0L) {
|
| 2021 | 2x |
names(return.value) <- unlist(object@Data@group.label) |
| 2022 |
} |
|
| 2023 |
} |
|
| 2024 | ||
| 2025 | 20x |
return.value |
| 2026 |
} |
|
| 2027 | ||
| 2028 |
lav_object_inspect_missing_patterns <- function(object, # nolint |
|
| 2029 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2030 | ||
| 2031 | 20x |
n.g <- object@Data@ngroups |
| 2032 | 20x |
return.value <- vector("list", n.g)
|
| 2033 | ||
| 2034 | 20x |
for (g in 1:n.g) {
|
| 2035 | 22x |
if (!is.null(object@Data@Mp[[g]])) {
|
| 2036 | 5x |
return.value[[g]] <- object@Data@Mp[[g]]$pat |
| 2037 |
} else {
|
|
| 2038 | 17x |
nvar <- length(object@Data@ov.names[[g]]) |
| 2039 | 17x |
return.value[[g]] <- matrix(TRUE, 1L, nvar) |
| 2040 | 17x |
rownames(return.value[[g]]) <- object@Data@nobs[[g]] |
| 2041 |
} |
|
| 2042 | ||
| 2043 | 22x |
if (add.labels && length(return.value[[g]]) > 0L) {
|
| 2044 | 22x |
colnames(return.value[[g]]) <- object@pta$vnames$ov.model[[g]] |
| 2045 |
} |
|
| 2046 | ||
| 2047 | 22x |
if (add.class) {
|
| 2048 | 22x |
class(return.value[[g]]) <- c("lavaan.matrix", "matrix")
|
| 2049 |
} |
|
| 2050 |
} |
|
| 2051 | ||
| 2052 | 20x |
if (n.g == 1L && drop.list.single.group) {
|
| 2053 | 18x |
return.value <- return.value[[1]] |
| 2054 |
} else {
|
|
| 2055 | 2x |
if (length(object@Data@group.label) > 0L) {
|
| 2056 | 2x |
names(return.value) <- unlist(object@Data@group.label) |
| 2057 |
} |
|
| 2058 |
} |
|
| 2059 | ||
| 2060 | 20x |
return.value |
| 2061 |
} |
|
| 2062 | ||
| 2063 |
lav_object_inspect_empty_idx <- function(object, |
|
| 2064 |
drop.list.single.group = FALSE) {
|
|
| 2065 | ||
| 2066 | ! |
n.g <- object@Data@ngroups |
| 2067 | ||
| 2068 |
# get empty idx |
|
| 2069 | ! |
return.value <- vector("list", n.g)
|
| 2070 | ||
| 2071 | ! |
for (g in 1:n.g) {
|
| 2072 | ! |
if (!is.null(object@Data@Mp[[g]])) {
|
| 2073 | ! |
return.value[[g]] <- object@Data@Mp[[g]]$empty.idx |
| 2074 |
} else {
|
|
| 2075 | ! |
return.value[[g]] <- integer(0L) |
| 2076 |
} |
|
| 2077 |
} |
|
| 2078 | ||
| 2079 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 2080 | ! |
return.value <- return.value[[1]] |
| 2081 |
} else {
|
|
| 2082 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 2083 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 2084 |
} |
|
| 2085 |
} |
|
| 2086 | ||
| 2087 | ! |
return.value |
| 2088 |
} |
|
| 2089 | ||
| 2090 | ||
| 2091 |
lav_object_inspect_wls_est <- function(object, |
|
| 2092 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2093 | ||
| 2094 | 39x |
return.value <- lav_model_wls_est(object@Model) |
| 2095 | ||
| 2096 | 39x |
if (add.labels) {
|
| 2097 | 20x |
tmp.names <- lav_object_inspect_delta_rownames(object, |
| 2098 | 20x |
drop.list.single.group = FALSE) |
| 2099 |
} |
|
| 2100 | ||
| 2101 |
# nblocks |
|
| 2102 | 39x |
nblocks <- length(return.value) |
| 2103 | ||
| 2104 | 39x |
for (b in seq_len(nblocks)) {
|
| 2105 | 44x |
if (add.labels && length(return.value[[b]]) > 0L && |
| 2106 | 44x |
object@Data@nlevels == 1L) {
|
| 2107 | 20x |
names(return.value[[b]]) <- tmp.names[[b]] |
| 2108 |
} |
|
| 2109 | ||
| 2110 | 44x |
if (add.class) {
|
| 2111 | 24x |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 2112 |
} |
|
| 2113 |
} |
|
| 2114 | ||
| 2115 | 39x |
if (nblocks == 1L && drop.list.single.group) {
|
| 2116 | 18x |
return.value <- return.value[[1]] |
| 2117 | 21x |
} else if (nblocks > 1L) {
|
| 2118 | 3x |
names(return.value) <- object@Data@block.label |
| 2119 |
} |
|
| 2120 | ||
| 2121 | 39x |
return.value |
| 2122 |
} |
|
| 2123 | ||
| 2124 |
lav_object_inspect_wls_obs <- function(object, |
|
| 2125 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2126 | ||
| 2127 | 39x |
return.value <- object@SampleStats@WLS.obs ### FIXME: should be in @h1?? |
| 2128 | ||
| 2129 | 39x |
if (add.labels) {
|
| 2130 | 20x |
tmp.names <- lav_object_inspect_delta_rownames(object, |
| 2131 | 20x |
drop.list.single.group = FALSE) |
| 2132 |
} |
|
| 2133 | ||
| 2134 |
# nblocks |
|
| 2135 | 39x |
nblocks <- length(return.value) |
| 2136 | ||
| 2137 | 39x |
for (b in seq_len(nblocks)) {
|
| 2138 | 41x |
if (add.labels && length(return.value[[b]]) > 0L && |
| 2139 | 41x |
object@Data@nlevels == 1L) {
|
| 2140 | 20x |
names(return.value[[b]]) <- tmp.names[[b]] |
| 2141 |
} |
|
| 2142 | ||
| 2143 | 41x |
if (add.class) {
|
| 2144 | 21x |
class(return.value[[b]]) <- c("lavaan.vector", "numeric")
|
| 2145 |
} |
|
| 2146 |
} |
|
| 2147 | ||
| 2148 | 38x |
if (nblocks == 1L && drop.list.single.group) {
|
| 2149 | 18x |
return.value <- return.value[[1]] |
| 2150 | 20x |
} else if (nblocks > 1L) {
|
| 2151 | 2x |
names(return.value) <- object@Data@block.label |
| 2152 |
} |
|
| 2153 | ||
| 2154 | 38x |
return.value |
| 2155 |
} |
|
| 2156 | ||
| 2157 |
lav_object_inspect_wls_v <- function(object, |
|
| 2158 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2159 | ||
| 2160 |
# return.value <- lav_model_wls_v(lavmodel = object@Model, |
|
| 2161 |
# lavsamplestats = object@SampleStats, |
|
| 2162 |
# structured = TRUE, |
|
| 2163 |
# lavdata = object@Data) |
|
| 2164 |
# WLS.V == (traditionally) h1 expected information |
|
| 2165 | 39x |
return.value <- lav_model_h1_information_expected(lavobject = object) |
| 2166 |
# this affects fit measures gfi, agfi, pgfi |
|
| 2167 | ||
| 2168 | ||
| 2169 |
# nblocks |
|
| 2170 | 39x |
nblocks <- length(return.value) |
| 2171 | ||
| 2172 |
# if estimator == "DWLS" or "ULS", we only stored the diagonal |
|
| 2173 |
# hence, we create a full matrix here |
|
| 2174 | 39x |
if (object@Options$estimator %in% c("DWLS", "ULS")) {
|
| 2175 | 2x |
return.value <- lapply(return.value, |
| 2176 | 2x |
function(x) {
|
| 2177 | 2x |
nr <- NROW(x) |
| 2178 | 2x |
diag(x, nrow = nr, ncol = nr) |
| 2179 |
}) |
|
| 2180 |
} |
|
| 2181 | ||
| 2182 | 39x |
if (add.labels) {
|
| 2183 | 20x |
tmp.names <- lav_object_inspect_delta_rownames(object, |
| 2184 | 20x |
drop.list.single.group = FALSE) |
| 2185 |
} |
|
| 2186 | ||
| 2187 |
# label + class |
|
| 2188 | 39x |
for (b in seq_len(nblocks)) {
|
| 2189 |
# labels |
|
| 2190 | 42x |
if (add.labels && nrow(return.value[[b]]) > 0L && |
| 2191 | 42x |
object@Data@nlevels == 1L) {
|
| 2192 | 20x |
colnames(return.value[[b]]) <- |
| 2193 | 20x |
rownames(return.value[[b]]) <- tmp.names[[b]] |
| 2194 |
} |
|
| 2195 | ||
| 2196 |
# class |
|
| 2197 | 42x |
if (add.class) {
|
| 2198 | 22x |
class(return.value[[b]]) <- c("lavaan.matrix", "matrix")
|
| 2199 |
} |
|
| 2200 |
} |
|
| 2201 | ||
| 2202 | 39x |
if (nblocks == 1L && drop.list.single.group) {
|
| 2203 | 18x |
return.value <- return.value[[1]] |
| 2204 | 21x |
} else if (nblocks > 1L) {
|
| 2205 | 3x |
names(return.value) <- object@Data@block.label |
| 2206 |
} |
|
| 2207 | ||
| 2208 | 38x |
return.value |
| 2209 |
} |
|
| 2210 | ||
| 2211 | ||
| 2212 |
lav_object_inspect_sampstat_gamma <- function(object, # nolint |
|
| 2213 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2214 | ||
| 2215 | 3x |
if (!is.null(object@SampleStats@NACOV[[1]])) {
|
| 2216 | ! |
return.value <- object@SampleStats@NACOV |
| 2217 |
} else {
|
|
| 2218 | 3x |
return.value <- lav_object_gamma(object) |
| 2219 |
} |
|
| 2220 | ||
| 2221 | 3x |
if (add.labels) {
|
| 2222 | 3x |
tmp.names <- lav_object_inspect_delta_rownames(object, |
| 2223 | 3x |
drop.list.single.group = FALSE) |
| 2224 |
} |
|
| 2225 | ||
| 2226 |
# nblocks |
|
| 2227 | 3x |
nblocks <- length(return.value) |
| 2228 | ||
| 2229 | 3x |
if (nblocks == 1L && drop.list.single.group) {
|
| 2230 | 2x |
return.value <- return.value[[1]] |
| 2231 | ||
| 2232 |
# labels |
|
| 2233 | 2x |
if (add.labels) {
|
| 2234 | 2x |
colnames(return.value) <- rownames(return.value) <- tmp.names[[1]] |
| 2235 |
} |
|
| 2236 | ||
| 2237 |
# class |
|
| 2238 | 2x |
if (add.class) {
|
| 2239 | 2x |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2240 |
} |
|
| 2241 |
} else {
|
|
| 2242 | 1x |
if (object@Data@nlevels == 1L && length(object@Data@group.label) > 0L) {
|
| 2243 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 2244 | ||
| 2245 |
# labels |
|
| 2246 | ! |
if (add.labels) {
|
| 2247 | ! |
for (g in seq_len(object@Data@ngroups)) {
|
| 2248 | ! |
colnames(return.value[[g]]) <- |
| 2249 | ! |
rownames(return.value[[g]]) <- tmp.names[[g]] |
| 2250 |
} |
|
| 2251 |
} |
|
| 2252 | ||
| 2253 |
# class |
|
| 2254 | ! |
if (add.class) {
|
| 2255 | ! |
for (g in seq_len(object@Data@ngroups)) {
|
| 2256 | ! |
class(return.value[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2257 |
} |
|
| 2258 |
} |
|
| 2259 | 1x |
} else if (object@Data@nlevels > 1L && |
| 2260 | 1x |
length(object@Data@group.label) == 0L) {
|
| 2261 | ! |
names(return.value) <- object@Data@level.label |
| 2262 |
} |
|
| 2263 |
} |
|
| 2264 | ||
| 2265 | 3x |
return.value |
| 2266 |
} |
|
| 2267 | ||
| 2268 | ||
| 2269 |
lav_object_inspect_gradient <- function(object, |
|
| 2270 |
add.labels = FALSE, add.class = FALSE, logl = FALSE, |
|
| 2271 |
optim = FALSE) {
|
|
| 2272 | ||
| 2273 | ! |
lavmodel <- object@Model |
| 2274 | ! |
lavdata <- object@Data |
| 2275 | ! |
lavsamplestats <- object@SampleStats |
| 2276 | ||
| 2277 | ! |
if (optim) {
|
| 2278 | ! |
logl <- FALSE |
| 2279 |
} |
|
| 2280 | ||
| 2281 | ! |
if (lavsamplestats@missing.flag || |
| 2282 | ! |
object@Options$estimator == "PML") {
|
| 2283 | ! |
group.weight <- FALSE |
| 2284 |
} else {
|
|
| 2285 | ! |
group.weight <- TRUE |
| 2286 |
} |
|
| 2287 | ! |
current.verbose <- lav_verbose() |
| 2288 | ! |
if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose), TRUE) |
| 2289 | ! |
dx <- lav_model_gradient(lavmodel = lavmodel, |
| 2290 | ! |
GLIST = NULL, |
| 2291 | ! |
lavsamplestats = lavsamplestats, |
| 2292 | ! |
lavdata = object@Data, |
| 2293 | ! |
lavcache = object@Cache, |
| 2294 | ! |
type = "free", |
| 2295 | ! |
group.weight = group.weight) |
| 2296 | ! |
lav_verbose(current.verbose) |
| 2297 |
# if logl, rescale to get gradient wrt the loglikelihood |
|
| 2298 | ! |
if (logl) {
|
| 2299 | ! |
if (lavmodel@estimator %in% c("ML")) {
|
| 2300 | ! |
if (lavdata@nlevels == 1L) {
|
| 2301 |
# currently, this is just a sign switch |
|
| 2302 | ! |
dx <- -1 * dx |
| 2303 |
} else {
|
|
| 2304 | ! |
lavpartable <- object@ParTable |
| 2305 |
# gradient.log = gradient.obj * (2 * tmp.n) / nclusters |
|
| 2306 | ||
| 2307 | ! |
if (lavdata@ngroups == 1L) {
|
| 2308 | ! |
tmp.n <- lavdata@Lp[[1]]$nclusters[[1]] |
| 2309 | ! |
nclusters <- lavdata@Lp[[1]]$nclusters[[2]] |
| 2310 | ! |
dx <- dx * (2 * tmp.n) / nclusters |
| 2311 |
} else {
|
|
| 2312 | ! |
group.values <- lav_partable_group_values(lavpartable) |
| 2313 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 2314 | ! |
tmp.n <- lavdata@Lp[[g]]$nclusters[[1]] |
| 2315 | ! |
nclusters <- lavdata@Lp[[g]]$nclusters[[2]] |
| 2316 | ! |
g.idx <- |
| 2317 | ! |
which((lavpartable$group == |
| 2318 | ! |
group.values[g])[lavpartable$free > 0L]) |
| 2319 | ! |
dx[g.idx] <- dx[g.idx] * (2 * tmp.n) / nclusters |
| 2320 |
} |
|
| 2321 |
} |
|
| 2322 |
} |
|
| 2323 |
} else {
|
|
| 2324 |
# FIXME: |
|
| 2325 |
# non-likelihood: what to do? just switch the sign for now. |
|
| 2326 |
# Note: this is used in lavTestScore() |
|
| 2327 | ! |
dx <- -1 * dx |
| 2328 |
} |
|
| 2329 |
} |
|
| 2330 | ||
| 2331 |
# optim? |
|
| 2332 | ! |
if (optim) {
|
| 2333 |
# 1. scale (note: divide, not multiply!) |
|
| 2334 | ! |
if (!is.null(object@optim$parscale)) {
|
| 2335 | ! |
dx <- dx / object@optim$parscale |
| 2336 |
} |
|
| 2337 | ||
| 2338 |
# 2. pack |
|
| 2339 | ! |
if (lavmodel@eq.constraints) {
|
| 2340 | ! |
dx <- as.numeric(dx %*% lavmodel@eq.constraints.K) |
| 2341 |
} |
|
| 2342 |
# only for PML: divide by tmp.n (to speed up convergence) |
|
| 2343 | ! |
if (lavmodel@estimator == "PML") {
|
| 2344 | ! |
dx <- dx / lavsamplestats@ntotal |
| 2345 |
} |
|
| 2346 |
} |
|
| 2347 | ||
| 2348 |
# labels |
|
| 2349 | ! |
if (add.labels) {
|
| 2350 | ! |
if (optim && lavmodel@eq.constraints) {
|
| 2351 | ! |
tmp.names.all <- lav_partable_labels(object@ParTable, type = "free") |
| 2352 | ! |
tmp.seq <- seq_len(length(tmp.names.all)) |
| 2353 | ! |
pack.seq <- as.numeric((tmp.seq - lavmodel@eq.constraints.k0) %*% |
| 2354 | ! |
+lavmodel@eq.constraints.K) |
| 2355 | ! |
ok.idx <- which(pack.seq %in% tmp.seq) |
| 2356 | ! |
tmp.names <- rep("(eq.con)", length(pack.seq))
|
| 2357 | ! |
tmp.names[ok.idx] <- tmp.names.all[pack.seq[ok.idx]] |
| 2358 | ! |
names(dx) <- tmp.names |
| 2359 |
} else {
|
|
| 2360 | ! |
names(dx) <- lav_partable_labels(object@ParTable, type = "free") |
| 2361 |
} |
|
| 2362 |
} |
|
| 2363 | ||
| 2364 |
# class |
|
| 2365 | ! |
if (add.class) {
|
| 2366 | ! |
class(dx) <- c("lavaan.vector", "numeric")
|
| 2367 |
} |
|
| 2368 | ||
| 2369 | ! |
dx |
| 2370 |
} |
|
| 2371 | ||
| 2372 |
lav_object_inspect_hessian <- function(object, |
|
| 2373 |
add.labels = FALSE, add.class = FALSE) {
|
|
| 2374 | ||
| 2375 | 20x |
return.value <- lav_model_hessian(lavmodel = object@Model, |
| 2376 | 20x |
lavsamplestats = object@SampleStats, |
| 2377 | 20x |
lavdata = object@Data, |
| 2378 | 20x |
lavcache = object@Cache, |
| 2379 | 20x |
lavoptions = object@Options, |
| 2380 | 20x |
group.weight = TRUE) |
| 2381 | ||
| 2382 |
# labels |
|
| 2383 | 20x |
if (add.labels) {
|
| 2384 | 20x |
colnames(return.value) <- rownames(return.value) <- |
| 2385 | 20x |
lav_partable_labels(object@ParTable, type = "free") |
| 2386 |
} |
|
| 2387 | ||
| 2388 |
# class |
|
| 2389 | 20x |
if (add.class) {
|
| 2390 | 20x |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2391 |
} |
|
| 2392 | ||
| 2393 | 20x |
return.value |
| 2394 |
} |
|
| 2395 | ||
| 2396 |
lav_object_inspect_information <- function(object, |
|
| 2397 |
information = "default", augmented = FALSE, inverted = FALSE, |
|
| 2398 |
add.labels = FALSE, add.class = FALSE) {
|
|
| 2399 | ||
| 2400 | 33x |
if (information != "default") {
|
| 2401 |
# override option |
|
| 2402 | 1x |
object@Options$information <- information |
| 2403 |
} |
|
| 2404 | ||
| 2405 | 33x |
return.value <- lav_model_information(lavmodel = object@Model, |
| 2406 | 33x |
lavsamplestats = object@SampleStats, |
| 2407 | 33x |
lavdata = object@Data, |
| 2408 | 33x |
lavcache = object@Cache, |
| 2409 | 33x |
lavimplied = object@implied, |
| 2410 | 33x |
lavh1 = object@h1, |
| 2411 | 33x |
lavoptions = object@Options, |
| 2412 | 33x |
extra = FALSE, |
| 2413 | 33x |
augmented = augmented, |
| 2414 | 33x |
inverted = inverted) |
| 2415 | ||
| 2416 |
# labels |
|
| 2417 | 33x |
if (add.labels) {
|
| 2418 | ! |
tmp.names <- lav_partable_labels(object@ParTable, type = "free") |
| 2419 | ! |
if (augmented) {
|
| 2420 | ! |
n.extra <- nrow(return.value) - length(tmp.names) |
| 2421 | ! |
if (n.extra > 0L) {
|
| 2422 | ! |
tmp.names <- c(tmp.names, paste("aug", 1:n.extra, sep = ""))
|
| 2423 |
} |
|
| 2424 |
} |
|
| 2425 | ! |
colnames(return.value) <- rownames(return.value) <- tmp.names |
| 2426 |
} |
|
| 2427 | ||
| 2428 |
# class |
|
| 2429 | 33x |
if (add.class) {
|
| 2430 | ! |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2431 |
} |
|
| 2432 | ||
| 2433 | 33x |
return.value |
| 2434 |
} |
|
| 2435 | ||
| 2436 |
lav_object_inspect_h1_information <- function(object, # nolint |
|
| 2437 |
information = "default", h1.information = "default", inverted = FALSE, |
|
| 2438 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2439 | ||
| 2440 | ! |
if (information != "default") {
|
| 2441 |
# override option |
|
| 2442 | ! |
object@Options$information <- information |
| 2443 |
} |
|
| 2444 | ! |
if (h1.information != "default") {
|
| 2445 |
# override option |
|
| 2446 | ! |
object@Options$h1.information <- h1.information |
| 2447 |
} |
|
| 2448 | ||
| 2449 | ! |
lavmodel <- object@Model |
| 2450 | ! |
lavdata <- object@Data |
| 2451 | ||
| 2452 |
# list! |
|
| 2453 | ! |
return.value <- lav_model_h1_information(lavmodel = lavmodel, |
| 2454 | ! |
lavsamplestats = object@SampleStats, |
| 2455 | ! |
lavdata = lavdata, |
| 2456 | ! |
lavcache = object@Cache, |
| 2457 | ! |
lavimplied = object@implied, |
| 2458 | ! |
lavh1 = object@h1, |
| 2459 | ! |
lavoptions = object@Options) |
| 2460 | ||
| 2461 |
# inverted? (NOT USED) |
|
| 2462 |
# if(inverted) {
|
|
| 2463 |
# return.value <- lapply(return.value, solve) # FIXME: handle errors... |
|
| 2464 |
# } |
|
| 2465 | ||
| 2466 | ! |
if (add.labels) {
|
| 2467 | ! |
tmp.names <- lav_object_inspect_delta_rownames(object, |
| 2468 | ! |
drop.list.single.group = FALSE) |
| 2469 |
} |
|
| 2470 | ||
| 2471 |
# labels/class per group |
|
| 2472 | ! |
for (g in seq_len(lavmodel@ngroups)) {
|
| 2473 |
# labels |
|
| 2474 | ! |
if (add.labels) {
|
| 2475 | ! |
colnames(return.value[[g]]) <- |
| 2476 | ! |
rownames(return.value[[g]]) <- tmp.names[[g]] |
| 2477 |
} |
|
| 2478 | ||
| 2479 |
# class |
|
| 2480 | ! |
if (add.class) {
|
| 2481 | ! |
class(return.value[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2482 |
} |
|
| 2483 |
} |
|
| 2484 | ||
| 2485 |
# drop list? |
|
| 2486 | ! |
if (lavmodel@ngroups == 1L && drop.list.single.group) {
|
| 2487 | ! |
return.value <- return.value[[1]] |
| 2488 | ! |
} else if (!is.null(lavdata)) {
|
| 2489 | ! |
if (length(lavdata@group.label) > 0L) {
|
| 2490 | ! |
names(return.value) <- unlist(lavdata@group.label) |
| 2491 |
} |
|
| 2492 |
} |
|
| 2493 | ||
| 2494 | ! |
return.value |
| 2495 |
} |
|
| 2496 | ||
| 2497 |
# only to provide a direct function to the old 'getVariability()' function |
|
| 2498 |
lav_object_inspect_firstorder <- function(object, |
|
| 2499 |
add.labels = FALSE, add.class = FALSE) {
|
|
| 2500 | ||
| 2501 | ! |
tmp.b0 <- lav_model_information_firstorder(lavmodel = object@Model, |
| 2502 | ! |
lavsamplestats = object@SampleStats, |
| 2503 | ! |
lavdata = object@Data, |
| 2504 | ! |
lavcache = object@Cache, |
| 2505 | ! |
lavoptions = object@Options, |
| 2506 | ! |
check.pd = FALSE, |
| 2507 | ! |
augmented = FALSE, |
| 2508 | ! |
inverted = FALSE) |
| 2509 | ! |
attr(tmp.b0, "B0.group") <- NULL |
| 2510 | ! |
return.value <- tmp.b0 |
| 2511 | ||
| 2512 |
# labels |
|
| 2513 | ! |
if (add.labels) {
|
| 2514 | ! |
colnames(return.value) <- rownames(return.value) <- |
| 2515 | ! |
lav_partable_labels(object@ParTable, type = "free") |
| 2516 |
} |
|
| 2517 | ||
| 2518 |
# class |
|
| 2519 | ! |
if (add.class) {
|
| 2520 | ! |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2521 |
} |
|
| 2522 | ||
| 2523 | ! |
return.value |
| 2524 |
} |
|
| 2525 | ||
| 2526 |
lav_object_inspect_vcov <- function(object, standardized = FALSE, |
|
| 2527 |
type = "std.all", free.only = TRUE, |
|
| 2528 |
add.labels = FALSE, add.class = FALSE, remove.duplicated = FALSE) {
|
|
| 2529 | ||
| 2530 | 49x |
lavmodel <- object@Model |
| 2531 | 49x |
lavoptions <- object@Options |
| 2532 | ||
| 2533 |
# store partable with pta in object to use cache in called functions |
|
| 2534 | 49x |
if (is.null(attr(object, "vnames"))) {
|
| 2535 | 49x |
object@ParTable <- lav_partable_set_cache(object@ParTable, object@pta) |
| 2536 |
} |
|
| 2537 | ||
| 2538 | 49x |
if (object@optim$npar == 0) {
|
| 2539 | ! |
return.value <- matrix(0, 0, 0) |
| 2540 |
} else {
|
|
| 2541 |
# check if we already have it |
|
| 2542 |
# tmp <- try(slot(object, "vcov"), silent = TRUE) |
|
| 2543 |
# if( !inherits(tmp, "try-error") && !is.null(object@vcov$vcov) |
|
| 2544 |
# && !(rotation && standardized)) {
|
|
| 2545 | 49x |
if (!is.null(object@vcov$vcov)) {
|
| 2546 | 49x |
return.value <- object@vcov$vcov # if this changes, tag @TDJorgensen in commit message |
| 2547 |
} else {
|
|
| 2548 |
# compute it again |
|
| 2549 |
# if(rotation && standardized) {
|
|
| 2550 |
# lavmodel <- lav_model_set_parameters(lavmodel, |
|
| 2551 |
# x = object@optim$x) |
|
| 2552 |
# lavoptions <- object@Options |
|
| 2553 |
# lavoptions$rotation.se <- "delta" |
|
| 2554 |
# } |
|
| 2555 | ! |
return.value <- lav_model_vcov(lavmodel = lavmodel, |
| 2556 | ! |
lavsamplestats = object@SampleStats, |
| 2557 | ! |
lavoptions = lavoptions, |
| 2558 | ! |
lavdata = object@Data, |
| 2559 | ! |
lavcache = object@Cache, |
| 2560 | ! |
lavimplied = object@implied, |
| 2561 | ! |
lavh1 = object@h1 |
| 2562 |
) |
|
| 2563 |
# if(rotation && !standardized) {
|
|
| 2564 |
# # fixme: compute tmp.vcov.rot manually... |
|
| 2565 |
# stop("lavaan ERROR: rerun with store.vcov = TRUE")
|
|
| 2566 |
# } |
|
| 2567 | ||
| 2568 | ! |
if (is.null(return.value)) {
|
| 2569 | ! |
return(return.value) |
| 2570 |
} |
|
| 2571 |
} |
|
| 2572 |
} |
|
| 2573 | ||
| 2574 |
# strip attributes |
|
| 2575 | 49x |
attr(return.value, "E.inv") <- NULL |
| 2576 | 49x |
attr(return.value, "B0") <- NULL |
| 2577 | 49x |
attr(return.value, "B0.group") <- NULL |
| 2578 | 49x |
attr(return.value, "Delta") <- NULL |
| 2579 | 49x |
attr(return.value, "WLS.V") <- NULL |
| 2580 | 49x |
attr(return.value, "tmp.boot.COEF") <- NULL |
| 2581 | 49x |
attr(return.value, "tmp.boot.TEST") <- NULL |
| 2582 | ||
| 2583 |
# standardized? |
|
| 2584 | 49x |
if (standardized) {
|
| 2585 | 29x |
if (type == "std.lv") {
|
| 2586 | ! |
tmp.fun <- lav_standardize_lv_x |
| 2587 | 29x |
} else if (type == "std.all") {
|
| 2588 | 29x |
tmp.fun <- lav_standardize_all_x |
| 2589 | ! |
} else if (type == "std.nox") {
|
| 2590 | ! |
tmp.fun <- lav_standardize_all_nox_x |
| 2591 |
} |
|
| 2592 | ||
| 2593 | 29x |
x.vec <- lav_model_get_parameters(lavmodel) |
| 2594 | 29x |
tmp.jac <- try(lav_func_jacobian_complex(func = tmp.fun, x = x.vec, |
| 2595 | 29x |
lavobject = object), |
| 2596 | 29x |
silent = TRUE) |
| 2597 | 29x |
if (inherits(tmp.jac, "try-error")) { # eg. pnorm()
|
| 2598 | ! |
tmp.jac <- lav_func_jacobian_simple(func = tmp.fun, x = x.vec, |
| 2599 | ! |
lavobject = object) |
| 2600 |
} |
|
| 2601 |
# } |
|
| 2602 | ||
| 2603 |
# tmp.jac contains *all* parameters in the parameter table |
|
| 2604 | 29x |
if (free.only) {
|
| 2605 | ! |
if (object@Model@ceq.simple.only) {
|
| 2606 | ! |
free.idx <- which(object@ParTable$free > 0L & |
| 2607 | ! |
!duplicated(object@ParTable$free)) |
| 2608 |
} else {
|
|
| 2609 | ! |
free.idx <- which(object@ParTable$free > 0L) |
| 2610 |
} |
|
| 2611 | ! |
tmp.jac <- tmp.jac[free.idx, , drop = FALSE] |
| 2612 |
} |
|
| 2613 | ||
| 2614 | 29x |
return.value <- tmp.jac %*% return.value %*% t(tmp.jac) |
| 2615 | ||
| 2616 |
# force return.value to be symmetric and pd |
|
| 2617 | 29x |
return.value <- (return.value + t(return.value)) / 2 |
| 2618 |
# return.value <- lav_matrix_symmetric_force_pd(return.value, |
|
| 2619 |
# tol = 1e-09) # was 1e-06 < 0.6-9 |
|
| 2620 |
} |
|
| 2621 | ||
| 2622 |
# labels |
|
| 2623 | 49x |
if (add.labels) {
|
| 2624 |
# if(rotation && !free.only) {
|
|
| 2625 |
# # todo |
|
| 2626 |
# } else {
|
|
| 2627 | 20x |
colnames(return.value) <- rownames(return.value) <- |
| 2628 | 20x |
lav_partable_labels(object@ParTable, |
| 2629 |
## add "user" labels? |
|
| 2630 | 20x |
type = ifelse(standardized && !free.only, |
| 2631 | 20x |
"user", "free")) |
| 2632 |
# } |
|
| 2633 |
} |
|
| 2634 | ||
| 2635 |
# alias? |
|
| 2636 | 49x |
if (remove.duplicated && lavmodel@eq.constraints) {
|
| 2637 | ! |
simple.flag <- lav_constraints_check_simple(lavmodel) |
| 2638 | ! |
if (simple.flag) {
|
| 2639 | ! |
tmp.lab <- lav_partable_labels(object@ParTable, type = "free") |
| 2640 | ! |
dup.flag <- duplicated(tmp.lab) |
| 2641 | ! |
return.value <- return.value[!dup.flag, !dup.flag, drop = FALSE] |
| 2642 |
} else {
|
|
| 2643 | ! |
lav_msg_warn( |
| 2644 | ! |
gettext("alias is TRUE, but equality constraints do not appear
|
| 2645 | ! |
to be simple; returning full vcov")) |
| 2646 |
} |
|
| 2647 |
} |
|
| 2648 | ||
| 2649 |
# class |
|
| 2650 | 49x |
if (add.class) {
|
| 2651 | 20x |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2652 |
} |
|
| 2653 | ||
| 2654 | 49x |
return.value |
| 2655 |
} |
|
| 2656 | ||
| 2657 |
lav_object_inspect_vcov_def <- function(object, joint = FALSE, |
|
| 2658 |
standardized = FALSE, type = "std.all", |
|
| 2659 |
add.labels = FALSE, add.class = FALSE) {
|
|
| 2660 | ||
| 2661 | ! |
lavmodel <- object@Model |
| 2662 | ! |
lavpartable <- object@ParTable |
| 2663 | ! |
free.idx <- which(lavpartable$free > 0L) |
| 2664 | ! |
def.idx <- which(lavpartable$op == ":=") |
| 2665 | ! |
joint.idx <- c(free.idx, def.idx) |
| 2666 | ||
| 2667 | ! |
if (!joint && length(def.idx) == 0L) {
|
| 2668 | ! |
return(matrix(0, 0, 0)) |
| 2669 | ! |
} else if (joint && length(joint.idx) == 0L) {
|
| 2670 | ! |
return(matrix(0, 0, 0)) |
| 2671 |
} |
|
| 2672 | ||
| 2673 | ! |
if (standardized) {
|
| 2674 |
# compute tmp.vcov for "free" parameters only |
|
| 2675 | ! |
tmp.vcov <- lav_object_inspect_vcov(object, |
| 2676 | ! |
standardized = TRUE, |
| 2677 | ! |
type = type, free.only = FALSE, |
| 2678 | ! |
add.labels = FALSE, add.class = FALSE) |
| 2679 | ! |
if (joint) {
|
| 2680 | ! |
return.value <- tmp.vcov[joint.idx, joint.idx, drop = FALSE] |
| 2681 |
} else {
|
|
| 2682 | ! |
return.value <- tmp.vcov[def.idx, def.idx, drop = FALSE] |
| 2683 |
} |
|
| 2684 |
} else {
|
|
| 2685 |
# get free parameters |
|
| 2686 | ! |
x <- lav_model_get_parameters(lavmodel, type = "free") |
| 2687 | ||
| 2688 |
# bootstrap or not? |
|
| 2689 | ! |
if (!is.null(object@boot$coef)) {
|
| 2690 | ! |
tmp.boot <- object@boot$coef |
| 2691 |
# remove NA rows |
|
| 2692 | ! |
error.idx <- attr(tmp.boot, "error.idx") |
| 2693 | ! |
if (length(error.idx) > 0L) {
|
| 2694 | ! |
tmp.boot <- tmp.boot[-error.idx, , drop = FALSE] # drops attributes |
| 2695 |
} |
|
| 2696 | ! |
tmp.boot.def <- apply(tmp.boot, 1L, lavmodel@def.function) |
| 2697 | ! |
if (length(def.idx) == 1L) {
|
| 2698 | ! |
tmp.boot.def <- as.matrix(tmp.boot.def) |
| 2699 |
} else {
|
|
| 2700 | ! |
tmp.boot.def <- t(tmp.boot.def) |
| 2701 |
} |
|
| 2702 | ! |
return.value <- cov(tmp.boot.def) |
| 2703 |
} else {
|
|
| 2704 |
# tmp.vcov |
|
| 2705 | ! |
tmp.vcov <- lav_object_inspect_vcov(object, |
| 2706 | ! |
standardized = FALSE, |
| 2707 | ! |
type = type, free.only = TRUE, |
| 2708 | ! |
add.labels = FALSE, |
| 2709 | ! |
add.class = FALSE) |
| 2710 | ||
| 2711 |
# regular delta method |
|
| 2712 | ! |
tmp.jac <- try(lav_func_jacobian_complex(func = lavmodel@def.function, |
| 2713 | ! |
x = x), silent = TRUE) |
| 2714 | ! |
if (inherits(tmp.jac, "try-error")) { # eg. pnorm()
|
| 2715 | ! |
tmp.jac <- lav_func_jacobian_simple(func = lavmodel@def.function, |
| 2716 | ! |
x = x) |
| 2717 |
} |
|
| 2718 | ! |
if (joint) {
|
| 2719 | ! |
tmp.jac2 <- rbind(diag(nrow = ncol(tmp.jac)), tmp.jac) |
| 2720 | ! |
return.value <- tmp.jac2 %*% tmp.vcov %*% t(tmp.jac2) |
| 2721 |
} else {
|
|
| 2722 | ! |
return.value <- tmp.jac %*% tmp.vcov %*% t(tmp.jac) |
| 2723 |
} |
|
| 2724 |
} |
|
| 2725 |
} |
|
| 2726 | ||
| 2727 |
# labels |
|
| 2728 | ! |
if (add.labels) {
|
| 2729 | ! |
if (joint) {
|
| 2730 | ! |
lhs.names <- lavpartable$lhs[joint.idx] |
| 2731 |
} else {
|
|
| 2732 | ! |
lhs.names <- lavpartable$lhs[def.idx] |
| 2733 |
} |
|
| 2734 | ! |
colnames(return.value) <- rownames(return.value) <- lhs.names |
| 2735 |
} |
|
| 2736 | ||
| 2737 |
# class |
|
| 2738 | ! |
if (add.class) {
|
| 2739 | ! |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2740 |
} |
|
| 2741 | ||
| 2742 | ! |
return.value |
| 2743 |
} |
|
| 2744 | ||
| 2745 |
lav_object_inspect_UGamma <- function(object, # nolint |
|
| 2746 |
add.labels = FALSE, add.class = FALSE) {
|
|
| 2747 | ||
| 2748 | ! |
out <- lav_test_satorra_bentler(lavobject = object, |
| 2749 | ! |
method = "original", |
| 2750 | ! |
return.ugamma = TRUE) |
| 2751 | ! |
return.value <- out$UGamma |
| 2752 | ||
| 2753 |
# labels |
|
| 2754 |
# if(add.labels) {
|
|
| 2755 |
# colnames(return.value) <- rownames(return.value) <- |
|
| 2756 |
# } |
|
| 2757 | ||
| 2758 |
# class |
|
| 2759 | ! |
if (add.class) {
|
| 2760 | ! |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2761 |
} |
|
| 2762 | ||
| 2763 | ! |
return.value |
| 2764 |
} |
|
| 2765 | ||
| 2766 |
lav_object_inspect_UfromUGamma <- function(object, # nolint |
|
| 2767 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2768 | ||
| 2769 | ! |
out <- lav_test_satorra_bentler(lavobject = object, |
| 2770 | ! |
method = "original", |
| 2771 | ! |
return.u = TRUE) |
| 2772 | ! |
return.value <- out$UfromUGamma |
| 2773 | ||
| 2774 |
# labels |
|
| 2775 |
# if(add.labels) {
|
|
| 2776 |
# colnames(return.value) <- rownames(return.value) <- |
|
| 2777 |
# } |
|
| 2778 | ||
| 2779 |
# class |
|
| 2780 | ! |
if (add.class) {
|
| 2781 | ! |
class(return.value) <- c("lavaan.matrix.symmetric", "matrix")
|
| 2782 |
} |
|
| 2783 | ||
| 2784 | ! |
return.value |
| 2785 |
} |
|
| 2786 | ||
| 2787 | ||
| 2788 |
# Delta (jacobian: d samplestats / d free_parameters) |
|
| 2789 |
lav_object_inspect_delta <- function(object, |
|
| 2790 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2791 | ||
| 2792 | 32x |
lavmodel <- object@Model |
| 2793 | 32x |
lavdata <- object@Data |
| 2794 | 32x |
lavpartable <- object@ParTable |
| 2795 | 32x |
lavpta <- object@pta |
| 2796 | ||
| 2797 | 32x |
return.value <- lav_object_inspect_delta_internal(lavmodel = lavmodel, |
| 2798 | 32x |
lavdata = lavdata, lavpartable = lavpartable, |
| 2799 | 32x |
add.labels = add.labels, add.class = add.class, |
| 2800 | 32x |
drop.list.single.group = drop.list.single.group) |
| 2801 | ||
| 2802 | 32x |
return.value |
| 2803 |
} |
|
| 2804 | ||
| 2805 |
lav_object_inspect_delta_rownames <- function( # nolint |
|
| 2806 |
object, |
|
| 2807 |
lavmodel = NULL, |
|
| 2808 |
lavpartable = NULL, |
|
| 2809 |
drop.list.single.group = FALSE) {
|
|
| 2810 | 63x |
if (!is.null(object)) {
|
| 2811 | 63x |
lavmodel <- object@Model |
| 2812 | 63x |
lavpartable <- object@ParTable |
| 2813 | 63x |
lavpta <- object@pta |
| 2814 | 63x |
lavdata <- object@Data |
| 2815 |
} else {
|
|
| 2816 | ! |
lavdata <- NULL |
| 2817 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 2818 |
} |
|
| 2819 | ||
| 2820 | 63x |
categorical <- lavmodel@categorical |
| 2821 | 63x |
correlation <- lavmodel@correlation |
| 2822 | 63x |
conditional.x <- lavmodel@conditional.x |
| 2823 | 63x |
group.w.free <- lavmodel@group.w.free |
| 2824 | 63x |
nvar <- lavmodel@nvar |
| 2825 | 63x |
num.idx <- lavmodel@num.idx |
| 2826 | 63x |
th.idx <- lavmodel@th.idx |
| 2827 | 63x |
nblocks <- lavmodel@nblocks |
| 2828 | ||
| 2829 |
# store names per block, rbind later |
|
| 2830 | 63x |
tmp.names <- vector("list", length = nblocks)
|
| 2831 | ||
| 2832 |
# output is per group |
|
| 2833 | 63x |
return.value <- vector("list", lavmodel@ngroups)
|
| 2834 | ||
| 2835 | 63x |
for (g in 1:nblocks) {
|
| 2836 | ||
| 2837 | 78x |
if (conditional.x) {
|
| 2838 | 3x |
ov.names <- lavpta$vnames$ov.nox[[g]] |
| 2839 |
} else {
|
|
| 2840 | 75x |
ov.names <- lavpta$vnames$ov[[g]] |
| 2841 |
} |
|
| 2842 | 78x |
ov.names.x <- lavpta$vnames$ov.x[[g]] |
| 2843 | 78x |
nvar <- length(ov.names) |
| 2844 | ||
| 2845 | ||
| 2846 | 78x |
names.cov <- names.cor <- names.var <- character(0L) |
| 2847 | 78x |
names.mu <- names.pi <- names.th <- character(0L) |
| 2848 | 78x |
names.gw <- character(0L) |
| 2849 | ||
| 2850 |
# Sigma |
|
| 2851 |
# - if continuous: vech(Sigma) |
|
| 2852 |
# - if categorical: first numeric variances, then |
|
| 2853 |
# tmp <- apply(expand.grid(ov.names, ov.names), 1L, |
|
| 2854 |
# paste, collapse = "~~") |
|
| 2855 | ||
| 2856 |
# if(categorical) {
|
|
| 2857 |
# names.cor <- tmp[lav_matrix_vech_idx(nvar, diagonal = FALSE)] |
|
| 2858 |
# names.var <- tmp[lav_matrix_diag_idx(nvar)[num.idx[[g]]]] |
|
| 2859 |
# } else {
|
|
| 2860 |
# names.cov <- tmp[lav_matrix_vech_idx(nvar, diagonal = TRUE)] |
|
| 2861 |
# } |
|
| 2862 | ||
| 2863 |
# NOTE: in 0.6-1, we use the same order, but 'label' in row-wise |
|
| 2864 |
# format (eg x1 ~~ x2 instead of x2 ~~ x1) |
|
| 2865 | 78x |
tmp <- matrix(apply(expand.grid(ov.names, ov.names), 1L, |
| 2866 | 78x |
paste, collapse = "~~"), nrow = nvar) |
| 2867 | 78x |
if (categorical) {
|
| 2868 | 3x |
names.cor <- lav_matrix_vechru(tmp, diagonal = FALSE) |
| 2869 | 3x |
names.var <- diag(tmp)[num.idx[[g]]] |
| 2870 | 75x |
} else if (correlation) {
|
| 2871 | ! |
names.cor <- lav_matrix_vechru(tmp, diagonal = FALSE) |
| 2872 |
} else {
|
|
| 2873 | 75x |
names.cov <- lav_matrix_vechru(tmp, diagonal = TRUE) |
| 2874 |
} |
|
| 2875 | ||
| 2876 | ||
| 2877 |
# Mu |
|
| 2878 | 78x |
if (!categorical && lavmodel@meanstructure) {
|
| 2879 | 48x |
names.mu <- paste(ov.names, "~1", sep = "") |
| 2880 |
} |
|
| 2881 | ||
| 2882 |
# Pi |
|
| 2883 | 78x |
if (conditional.x && lavmodel@nexo[g] > 0L) {
|
| 2884 | 3x |
names.pi <- apply(expand.grid(ov.names, ov.names.x), 1L, |
| 2885 | 3x |
paste, collapse = "~") |
| 2886 |
} |
|
| 2887 | ||
| 2888 |
# th |
|
| 2889 | 78x |
if (categorical) {
|
| 2890 | 3x |
names.th <- lavpta$vnames$th[[g]] |
| 2891 |
# interweave numeric intercepts, if any |
|
| 2892 | 3x |
if (length(num.idx[[g]]) > 0L) {
|
| 2893 | 3x |
tmp <- character(length(th.idx[[g]])) |
| 2894 | 3x |
tmp[th.idx[[g]] > 0] <- names.th |
| 2895 | 3x |
tmp[th.idx[[g]] == 0] <- paste(ov.names[num.idx[[g]]], |
| 2896 | 3x |
"~1", sep = "") |
| 2897 | 3x |
names.th <- tmp |
| 2898 |
} |
|
| 2899 |
} |
|
| 2900 | ||
| 2901 |
# gw |
|
| 2902 | 78x |
if (group.w.free) {
|
| 2903 | ! |
names.gw <- "w" |
| 2904 |
} |
|
| 2905 | ||
| 2906 | 78x |
tmp.names[[g]] <- c(names.gw, |
| 2907 | 78x |
names.th, names.mu, |
| 2908 | 78x |
names.pi, |
| 2909 | 78x |
names.cov, names.var, names.cor) |
| 2910 | ||
| 2911 |
} # blocks |
|
| 2912 | ||
| 2913 |
# multilevel? |
|
| 2914 | 63x |
if (lavmodel@multilevel) {
|
| 2915 | 4x |
for (g in 1:lavmodel@ngroups) {
|
| 2916 | 8x |
return.value[[g]] <- c(tmp.names[[(g - 1) * 2 + 1]], |
| 2917 | 8x |
tmp.names[[(g - 1) * 2 + 2]]) |
| 2918 |
} |
|
| 2919 |
} else {
|
|
| 2920 | 59x |
return.value <- tmp.names |
| 2921 |
} |
|
| 2922 | ||
| 2923 |
# drop list? |
|
| 2924 | 63x |
if (lavmodel@ngroups == 1L && drop.list.single.group) {
|
| 2925 | ! |
return.value <- return.value[[1]] |
| 2926 | 63x |
} else if (!is.null(lavdata)) {
|
| 2927 | 63x |
if (length(lavdata@group.label) > 0L) {
|
| 2928 | 7x |
names(return.value) <- unlist(lavdata@group.label) |
| 2929 |
} |
|
| 2930 |
} |
|
| 2931 | ||
| 2932 | 63x |
return.value |
| 2933 |
} |
|
| 2934 | ||
| 2935 |
lav_object_inspect_delta_internal <- function( # nolint |
|
| 2936 |
lavmodel = NULL, lavdata = NULL, |
|
| 2937 |
lavpartable = NULL, |
|
| 2938 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 2939 | ||
| 2940 | 32x |
return.value <- lav_model_delta(lavmodel) |
| 2941 | ||
| 2942 | 32x |
if (add.labels) {
|
| 2943 | ! |
tmp.pnames <- lav_partable_labels(lavpartable, type = "free") |
| 2944 | ! |
tmp.rownames <- lav_object_inspect_delta_rownames(object = NULL, |
| 2945 | ! |
lavmodel = lavmodel, lavpartable = lavpartable, |
| 2946 | ! |
drop.list.single.group = FALSE) |
| 2947 |
} |
|
| 2948 | ||
| 2949 | 32x |
for (g in seq_len(lavmodel@ngroups)) {
|
| 2950 |
# add labels |
|
| 2951 | 32x |
if (add.labels) {
|
| 2952 | ! |
colnames(return.value[[g]]) <- tmp.pnames |
| 2953 | ! |
rownames(return.value[[g]]) <- tmp.rownames[[g]] |
| 2954 |
} |
|
| 2955 | ||
| 2956 |
# add class |
|
| 2957 | 32x |
if (add.class) {
|
| 2958 | ! |
class(return.value[[g]]) <- c("lavaan.matrix", "matrix")
|
| 2959 |
} |
|
| 2960 | ||
| 2961 |
} # ngroups |
|
| 2962 | ||
| 2963 |
# drop list? |
|
| 2964 | 32x |
if (lavmodel@ngroups == 1L && drop.list.single.group) {
|
| 2965 | ! |
return.value <- return.value[[1]] |
| 2966 |
} else {
|
|
| 2967 | 32x |
if (length(lavdata@group.label) > 0L) {
|
| 2968 | ! |
names(return.value) <- unlist(lavdata@group.label) |
| 2969 |
} |
|
| 2970 |
} |
|
| 2971 | ||
| 2972 | 32x |
return.value |
| 2973 |
} |
|
| 2974 | ||
| 2975 |
lav_object_inspect_zero_cell_tables <- # nolint |
|
| 2976 |
function(object, add.labels = FALSE, add.class = FALSE, |
|
| 2977 |
drop.list.single.group = FALSE) {
|
|
| 2978 |
# categorical? |
|
| 2979 | ! |
if (!object@Model@categorical) {
|
| 2980 | ! |
lav_msg_warn(gettext("no categorical variables in fitted model"))
|
| 2981 | ! |
return(invisible(list())) |
| 2982 |
} |
|
| 2983 | ||
| 2984 | ! |
lavdata <- object@Data |
| 2985 | ||
| 2986 |
# create 2-way tables |
|
| 2987 | ! |
tmp.table <- lavTables(object, dimension = 2L, output = "data.frame", |
| 2988 | ! |
statistic = NULL) |
| 2989 | ||
| 2990 |
# select tables with empty cells |
|
| 2991 | ! |
empty.id <- tmp.table$id[which(tmp.table$obs.freq == 0)] |
| 2992 | ||
| 2993 | ||
| 2994 | ! |
if (length(empty.id) == 0L) {
|
| 2995 |
# only when lavInspect() is used, give message |
|
| 2996 | ! |
if (add.class) {
|
| 2997 | ! |
cat("(There are no tables with empty cells for this fitted model)\n")
|
| 2998 |
} |
|
| 2999 | ! |
return(invisible(list())) |
| 3000 |
} else {
|
|
| 3001 | ! |
return.value <- lav_tables_cells_format( |
| 3002 | ! |
tmp.table[tmp.table$id %in% empty.id, ], |
| 3003 | ! |
lavdata = lavdata, |
| 3004 | ! |
drop.list.single.group = drop.list.single.group) |
| 3005 |
} |
|
| 3006 | ||
| 3007 | ! |
return.value |
| 3008 |
} |
|
| 3009 | ||
| 3010 |
lav_object_inspect_coef <- function(object, type = "free", |
|
| 3011 |
add.labels = FALSE, add.class = FALSE) {
|
|
| 3012 | ||
| 3013 | 42x |
if (type == "user" || type == "all") {
|
| 3014 | ! |
type <- "user" |
| 3015 | ! |
idx <- seq_along(object@ParTable$lhs) |
| 3016 | 42x |
} else if (type == "free") {
|
| 3017 |
#idx <- which(object@ParTable$free > 0L & !duplicated(object@ParTable$free)) |
|
| 3018 | 42x |
idx <- which(object@ParTable$free > 0L) |
| 3019 |
} else {
|
|
| 3020 | ! |
lav_msg_stop(gettextf( |
| 3021 | ! |
"%1$s argument must be either %2$s or %3$s", |
| 3022 | ! |
"type", "free", "user")) |
| 3023 |
} |
|
| 3024 | 42x |
tmp.est <- lav_object_inspect_est(object) |
| 3025 | 42x |
cof <- tmp.est[idx] |
| 3026 | ||
| 3027 |
# labels? |
|
| 3028 | 42x |
if (add.labels) {
|
| 3029 | 42x |
names(cof) <- lav_partable_labels(object@ParTable, type = type) |
| 3030 |
} |
|
| 3031 | ||
| 3032 |
# class |
|
| 3033 | 42x |
if (add.class) {
|
| 3034 | 40x |
class(cof) <- c("lavaan.vector", "numeric")
|
| 3035 |
} |
|
| 3036 | ||
| 3037 | 42x |
cof |
| 3038 |
} |
|
| 3039 | ||
| 3040 |
lav_object_inspect_npar <- function(object, ceq = FALSE) {
|
|
| 3041 | ||
| 3042 |
# free parameters (going to the optimizer) |
|
| 3043 | 67x |
npar <- object@Model@nx.free |
| 3044 | ||
| 3045 |
# account for equality constraints? |
|
| 3046 | 67x |
if (ceq && nrow(object@Model@con.jac) > 0L) {
|
| 3047 | 22x |
ceq.idx <- attr(object@Model@con.jac, "ceq.idx") |
| 3048 | 22x |
if (length(ceq.idx) > 0L) {
|
| 3049 | 19x |
neq <- qr(object@Model@con.jac[ceq.idx, , drop = FALSE])$rank |
| 3050 | 19x |
npar <- npar - neq |
| 3051 |
} |
|
| 3052 |
} |
|
| 3053 | ||
| 3054 | 67x |
npar |
| 3055 |
} |
|
| 3056 | ||
| 3057 |
lav_object_inspect_icc <- function(object, add.labels = FALSE, |
|
| 3058 |
add.class = FALSE, |
|
| 3059 |
drop.list.single.group = FALSE) {
|
|
| 3060 | ||
| 3061 | ! |
lavdata <- object@Data |
| 3062 | ! |
n.g <- lavdata@ngroups |
| 3063 | ! |
return.value <- vector("list", n.g)
|
| 3064 | ||
| 3065 |
# clustered data? |
|
| 3066 | ! |
if (length(lavdata@cluster) == 0L) {
|
| 3067 | ! |
lav_msg_stop(gettext( |
| 3068 | ! |
"intraclass correlation only available for clustered data")) |
| 3069 | ! |
} else if (lavdata@nlevels == 1L) {
|
| 3070 | ! |
lav_msg_stop(gettext( |
| 3071 | ! |
"intraclass correlation only available if the model syntax |
| 3072 | ! |
contains levels")) |
| 3073 |
} |
|
| 3074 | ||
| 3075 | ! |
if (length(object@h1) == 0L) {
|
| 3076 | ! |
lav_msg_stop(gettext("h1 slot is not available; refit with h1 = TRUE"))
|
| 3077 |
} |
|
| 3078 | ||
| 3079 |
# implied statistics |
|
| 3080 | ! |
implied <- object@h1$implied |
| 3081 | ||
| 3082 | ! |
for (g in 1:n.g) {
|
| 3083 | ! |
sigma.w <- implied$cov[[(g - 1) * lavdata@nlevels + 1]] |
| 3084 | ! |
sigma.b <- implied$cov[[(g - 1) * lavdata@nlevels + 2]] |
| 3085 | ||
| 3086 | ! |
w.diag <- diag(sigma.w) |
| 3087 | ! |
b.diag <- diag(sigma.b) |
| 3088 | ||
| 3089 | ! |
return.value[[g]] <- numeric(length(w.diag)) |
| 3090 | ||
| 3091 | ! |
ov.names.l <- lavdata@ov.names.l[[g]] |
| 3092 | ! |
w.idx <- which(ov.names.l[[1]] %in% ov.names.l[[2]]) |
| 3093 | ! |
w.names <- ov.names.l[[1]][w.idx] |
| 3094 | ! |
b.idx <- match(w.names, ov.names.l[[2]]) |
| 3095 | ||
| 3096 | ! |
return.value[[g]][w.idx] <- b.diag[b.idx] / (w.diag[w.idx] + b.diag[b.idx]) |
| 3097 | ||
| 3098 |
# label |
|
| 3099 | ! |
if (add.labels) {
|
| 3100 | ! |
names(return.value[[g]]) <- ov.names.l[[1]] |
| 3101 |
} |
|
| 3102 | ||
| 3103 |
# class |
|
| 3104 | ! |
if (add.class) {
|
| 3105 | ! |
class(return.value[[g]]) <- c("lavaan.vector", "numeric")
|
| 3106 |
} |
|
| 3107 |
} # g |
|
| 3108 | ||
| 3109 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 3110 | ! |
return.value <- return.value[[1]] |
| 3111 |
} else {
|
|
| 3112 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 3113 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 3114 |
} |
|
| 3115 |
} |
|
| 3116 | ||
| 3117 | ! |
return.value |
| 3118 |
} |
|
| 3119 | ||
| 3120 |
lav_object_inspect_ranef <- function(object, add.labels = FALSE, |
|
| 3121 |
add.class = FALSE, |
|
| 3122 |
drop.list.single.group = FALSE) {
|
|
| 3123 | ||
| 3124 | ! |
lavdata <- object@Data |
| 3125 | ! |
lavsamplestats <- object@SampleStats |
| 3126 | ||
| 3127 | ! |
n.g <- lavdata@ngroups |
| 3128 | ! |
return.value <- vector("list", n.g)
|
| 3129 | ||
| 3130 |
# multilevel? |
|
| 3131 | ! |
if (lavdata@nlevels == 1L) {
|
| 3132 | ! |
lav_msg_stop(gettext( |
| 3133 | ! |
"random effects only available for clustered data (in the long format)")) |
| 3134 |
} |
|
| 3135 | ||
| 3136 |
# implied statistics |
|
| 3137 | ! |
lavimplied <- object@implied |
| 3138 | ||
| 3139 | ! |
for (g in 1:n.g) {
|
| 3140 | ||
| 3141 | ! |
tmp.lp <- lavdata@Lp[[g]] |
| 3142 | ! |
tmp.ylp <- lavsamplestats@YLp[[g]] |
| 3143 | ||
| 3144 |
# implied for this group |
|
| 3145 | ! |
group.idx <- (g - 1) * lavdata@nlevels + seq_len(lavdata@nlevels) |
| 3146 | ! |
implied.group <- lapply(lavimplied, function(x) x[group.idx]) |
| 3147 | ||
| 3148 |
# random effects (=random intercepts or cluster means) |
|
| 3149 | ! |
out <- lav_mvnorm_cluster_implied22l(Lp = tmp.lp, implied = implied.group) |
| 3150 | ! |
mb.j <- lav_mvnorm_cluster_em_estep_ranef(YLp = tmp.ylp, Lp = tmp.lp, |
| 3151 | ! |
sigma.w = out$sigma.w, sigma.b = out$sigma.b, |
| 3152 | ! |
sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz, |
| 3153 | ! |
mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b, |
| 3154 | ! |
se = FALSE) |
| 3155 | ! |
return.value[[g]] <- mb.j |
| 3156 | ||
| 3157 | ! |
ov.names.l <- lavdata@ov.names.l[[g]] |
| 3158 | ||
| 3159 |
# label |
|
| 3160 | ! |
if (add.labels) {
|
| 3161 | ! |
colnames(return.value[[g]]) <- ov.names.l[[1]] |
| 3162 |
} |
|
| 3163 | ||
| 3164 |
# class |
|
| 3165 | ! |
if (add.class) {
|
| 3166 | ! |
class(return.value[[g]]) <- c("lavaan.matrix", "matrix")
|
| 3167 | ||
| 3168 |
} |
|
| 3169 |
} # g |
|
| 3170 | ||
| 3171 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 3172 | ! |
return.value <- return.value[[1]] |
| 3173 |
} else {
|
|
| 3174 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 3175 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 3176 |
} |
|
| 3177 |
} |
|
| 3178 | ||
| 3179 | ! |
return.value |
| 3180 |
} |
|
| 3181 | ||
| 3182 |
# casewise loglikelihood contributions |
|
| 3183 |
lav_object_inspect_loglik_casewise <- function(object, log. = TRUE, # nolint |
|
| 3184 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 3185 | ||
| 3186 | ! |
lavdata <- object@Data |
| 3187 | ! |
lavsamplestats <- object@SampleStats |
| 3188 | ! |
lavimplied <- object@implied |
| 3189 | ! |
lavoptions <- object@Options |
| 3190 | ||
| 3191 | ! |
n.g <- lavdata@ngroups |
| 3192 | ! |
return.value <- vector("list", n.g)
|
| 3193 | ||
| 3194 |
# multilevel? |
|
| 3195 | ! |
if (lavdata@nlevels > 1L) {
|
| 3196 | ! |
lav_msg_stop(gettext( |
| 3197 | ! |
"casewise (log)likeloods contributions not yet available for clustered data")) |
| 3198 |
} |
|
| 3199 | ||
| 3200 |
# estimator ML? |
|
| 3201 | ! |
if (object@Options$estimator != "ML") {
|
| 3202 | ! |
lav_msg_stop(gettextf( |
| 3203 | ! |
"casewise (log)likeloods contributions only available for estimator = %s", |
| 3204 | ! |
dQuote("ML")))
|
| 3205 |
} |
|
| 3206 | ||
| 3207 | ! |
for (g in 1:n.g) {
|
| 3208 | ||
| 3209 | ! |
if (lavsamplestats@missing.flag) {
|
| 3210 | ! |
return.value[[g]] <- |
| 3211 | ! |
lav_mvnorm_missing_llik_casewise(Y = lavdata@X[[g]], |
| 3212 | ! |
wt = lavdata@weights[[g]], |
| 3213 | ! |
Mu = lavimplied$mean[[g]], |
| 3214 | ! |
Sigma = lavimplied$cov[[g]], |
| 3215 | ! |
x.idx = lavsamplestats@x.idx[[g]]) |
| 3216 |
} else { # single-level, complete data
|
|
| 3217 | ! |
if (lavoptions$conditional.x) {
|
| 3218 | ! |
if (!is.null(lavdata@weights[[g]])) {
|
| 3219 | ! |
lav_msg_stop(gettext("no support (yet) if weights are used."))
|
| 3220 |
} |
|
| 3221 | ! |
return.value[[g]] <- lav_mvreg_loglik_data( |
| 3222 | ! |
Y = lavdata@X[[g]], |
| 3223 | ! |
eXo = lavdata@eXo[[g]], |
| 3224 | ! |
res.int = lavimplied$res.int[[g]], |
| 3225 | ! |
res.slopes = lavimplied$res.slopes[[g]], |
| 3226 | ! |
res.cov = lavimplied$res.cov[[g]], |
| 3227 | ! |
casewise = TRUE) |
| 3228 | ||
| 3229 |
} else {
|
|
| 3230 | ||
| 3231 | ! |
if (object@Model@meanstructure) {
|
| 3232 | ! |
tmp.mean <- lavimplied$mean[[g]] |
| 3233 |
} else {
|
|
| 3234 | ! |
tmp.mean <- lavsamplestats@mean[[g]] |
| 3235 |
} |
|
| 3236 | ! |
return.value[[g]] <- |
| 3237 | ! |
lav_mvnorm_loglik_data(Y = lavdata@X[[g]], |
| 3238 | ! |
wt = lavdata@weights[[g]], |
| 3239 | ! |
Mu = tmp.mean, |
| 3240 | ! |
Sigma = lavimplied$cov[[g]], |
| 3241 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 3242 | ! |
casewise = TRUE) |
| 3243 |
} |
|
| 3244 |
} # single-level, complete data |
|
| 3245 | ||
| 3246 |
# log. = FALSE? |
|
| 3247 | ! |
if (!log.) {
|
| 3248 | ! |
return.value[[g]] <- exp(return.value[[g]]) |
| 3249 |
} |
|
| 3250 | ||
| 3251 |
# label |
|
| 3252 |
# if(add.labels) {
|
|
| 3253 |
# } |
|
| 3254 | ||
| 3255 |
# class |
|
| 3256 | ! |
if (add.class) {
|
| 3257 | ! |
class(return.value[[g]]) <- c("lavaan.vector", "numeric")
|
| 3258 | ||
| 3259 |
} |
|
| 3260 | ||
| 3261 |
} # g |
|
| 3262 | ||
| 3263 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 3264 | ! |
return.value <- return.value[[1]] |
| 3265 |
} else {
|
|
| 3266 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 3267 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 3268 |
} |
|
| 3269 |
} |
|
| 3270 | ||
| 3271 | ! |
return.value |
| 3272 |
} |
|
| 3273 | ||
| 3274 |
# Mahalanobis distances for factor scores or casewise residuals |
|
| 3275 |
# type = "lv" -> factor scores |
|
| 3276 |
# type = "resid" -> casewise residuals |
|
| 3277 |
# |
|
| 3278 |
# we always use Bartlett factor scores (see Yuan & Hayashi 2010) |
|
| 3279 |
# (this has no impact on the m-distances for the factor scores, |
|
| 3280 |
# and only a very slight impact on the m-distances for the casewise |
|
| 3281 |
# residuals; but asymptotically, only when we use Bartlett factor |
|
| 3282 |
# scores are the 'true scores' (=LAMBDA %*% FS) orthogonal to the |
|
| 3283 |
# casewise residuals) |
|
| 3284 |
lav_object_inspect_mdist2 <- function(object, type = "resid", squared = TRUE, |
|
| 3285 |
add.labels = FALSE, add.class = FALSE, |
|
| 3286 |
drop.list.single.group = FALSE) {
|
|
| 3287 | ||
| 3288 | ! |
lavdata <- object@Data |
| 3289 | ! |
n.g <- lavdata@ngroups |
| 3290 | ||
| 3291 |
# lavPredict() |
|
| 3292 | ! |
out <- lavPredict(object, type = type, method = "ML", # = Bartlett |
| 3293 | ! |
label = FALSE, fsm = TRUE, mdist = TRUE, |
| 3294 | ! |
se = "none", acov = "none") |
| 3295 | ! |
return.value <- attr(out, "mdist") |
| 3296 | ||
| 3297 | ! |
for (g in seq_len(n.g)) {
|
| 3298 |
# squared? |
|
| 3299 | ! |
if (!squared) {
|
| 3300 | ! |
return.value[[g]] <- sqrt(return.value[[g]]) |
| 3301 |
} |
|
| 3302 | ||
| 3303 |
# labels? |
|
| 3304 |
# if(add.labels) {
|
|
| 3305 |
# } |
|
| 3306 | ||
| 3307 |
# class |
|
| 3308 | ! |
if (add.class) {
|
| 3309 | ! |
class(return.value[[g]]) <- c("lavaan.vector", "numeric")
|
| 3310 |
} |
|
| 3311 |
} # g |
|
| 3312 | ||
| 3313 | ! |
if (n.g == 1L && drop.list.single.group) {
|
| 3314 | ! |
return.value <- return.value[[1]] |
| 3315 |
} else {
|
|
| 3316 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 3317 | ! |
names(return.value) <- unlist(object@Data@group.label) |
| 3318 |
} |
|
| 3319 |
} |
|
| 3320 | ||
| 3321 | ! |
return.value |
| 3322 |
} |
|
| 3323 | ||
| 3324 |
# N versus N-1 (or N versus N-G in the multiple group setting) |
|
| 3325 |
# Changed 0.5-15: suggestion by Mark Seeto |
|
| 3326 |
lav_object_inspect_ntotal <- function(object) {
|
|
| 3327 | 152x |
if (object@Options$estimator %in% c("ML", "PML", "FML", "catML") &&
|
| 3328 | 152x |
object@Options$likelihood %in% c("default", "normal")) {
|
| 3329 | 103x |
N <- object@SampleStats@ntotal |
| 3330 |
} else {
|
|
| 3331 | 49x |
N <- object@SampleStats@ntotal - object@SampleStats@ngroups |
| 3332 |
} |
|
| 3333 | ||
| 3334 | 152x |
N |
| 3335 |
} |
|
| 3336 | ||
| 3337 |
lav_object_inspect_iv <- function(object, drop.list.single.group = FALSE) {
|
|
| 3338 |
|
|
| 3339 | ! |
if (is.null(object@internal$eqs)) {
|
| 3340 | ! |
lav_msg_stop(gettext("no equations/ivs found"))
|
| 3341 |
} |
|
| 3342 | ! |
lavmodel <- object@Model |
| 3343 | ! |
lavdata <- object@Data |
| 3344 |
|
|
| 3345 |
# grab equations |
|
| 3346 | ! |
iv_list <- object@internal$eqs |
| 3347 | ||
| 3348 |
# nblocks |
|
| 3349 | ! |
nblocks <- object@pta$nblocks |
| 3350 | ||
| 3351 | ! |
table <- vector("list", length = nblocks)
|
| 3352 | ! |
for (b in seq_len(nblocks)) {
|
| 3353 | ! |
eqs <- iv_list[[b]] |
| 3354 | ! |
lhs <- sapply(eqs, "[[", "lhs") |
| 3355 | ! |
rhs <- sapply(lapply(eqs, "[[", "rhs"), paste, collapse = " + ") |
| 3356 | ! |
lhs_new <- sapply(eqs, "[[", "lhs_new") |
| 3357 | ! |
rhs_new <- sapply(lapply(eqs, "[[", "rhs_new"), paste, collapse = " + ") |
| 3358 | ! |
miiv <- sapply(lapply(eqs, "[[", "miiv"), paste, collapse = ", ") |
| 3359 | ! |
table[[b]] <- data.frame( |
| 3360 | ! |
lhs = lhs, rhs = rhs, |
| 3361 | ! |
lhs.new = lhs_new, rhs.new = rhs_new, instruments = miiv |
| 3362 |
) |
|
| 3363 | ! |
class(table[[b]]) <- c("lavaan.data.frame", "data.frame")
|
| 3364 |
} |
|
| 3365 | ||
| 3366 |
# return value |
|
| 3367 | ! |
return.value <- table |
| 3368 | ||
| 3369 |
# drop list? |
|
| 3370 | ! |
if (lavmodel@ngroups == 1L && drop.list.single.group) {
|
| 3371 | ! |
return.value <- return.value[[1]] |
| 3372 | ! |
} else if (!is.null(lavdata)) {
|
| 3373 | ! |
if (length(lavdata@group.label) > 0L) {
|
| 3374 | ! |
names(return.value) <- unlist(lavdata@group.label) |
| 3375 |
} |
|
| 3376 |
} |
|
| 3377 | ||
| 3378 | ! |
return.value |
| 3379 |
} |
|
| 3380 | ||
| 3381 |
lav_object_inspect_eqs <- function(object, drop.list.single.group = FALSE) {
|
|
| 3382 |
|
|
| 3383 | ! |
if (is.null(object@internal$eqs)) {
|
| 3384 | ! |
lav_msg_stop(gettext("no equations/ivs found"))
|
| 3385 |
} |
|
| 3386 | ! |
lavmodel <- object@Model |
| 3387 | ! |
lavdata <- object@Data |
| 3388 |
|
|
| 3389 |
# grab equations |
|
| 3390 | ! |
eqs <- object@internal$eqs |
| 3391 | ||
| 3392 |
# return value |
|
| 3393 | ! |
return.value <- eqs |
| 3394 | ||
| 3395 |
# drop list? |
|
| 3396 | ! |
if (lavmodel@ngroups == 1L && drop.list.single.group) {
|
| 3397 | ! |
return.value <- return.value[[1]] |
| 3398 | ! |
} else if (!is.null(lavdata)) {
|
| 3399 | ! |
if (length(lavdata@group.label) > 0L) {
|
| 3400 | ! |
names(return.value) <- unlist(lavdata@group.label) |
| 3401 |
} |
|
| 3402 |
} |
|
| 3403 | ||
| 3404 | ! |
return.value |
| 3405 |
} |
|
| 3406 | ||
| 3407 |
lav_object_inspect_sargan <- function(object, drop.list.single.group = FALSE) {
|
|
| 3408 | ||
| 3409 | ! |
if (is.null(object@internal$eqs)) {
|
| 3410 | ! |
lav_msg_stop(gettext("no equations/ivs found"))
|
| 3411 |
} |
|
| 3412 | ! |
lavmodel <- object@Model |
| 3413 | ! |
lavdata <- object@Data |
| 3414 | ||
| 3415 |
# grab equations |
|
| 3416 | ! |
iv_list <- object@internal$eqs |
| 3417 | ||
| 3418 |
# nblocks |
|
| 3419 | ! |
nblocks <- object@pta$nblocks |
| 3420 | ||
| 3421 | ! |
table <- vector("list", length = nblocks)
|
| 3422 | ! |
for (b in seq_len(nblocks)) {
|
| 3423 | ! |
eqs <- iv_list[[b]] |
| 3424 | ! |
lhs <- sapply(eqs, "[[", "lhs") |
| 3425 | ! |
rhs <- sapply(lapply(eqs, "[[", "rhs"), paste, collapse = " + ") |
| 3426 | ! |
miiv <- sapply(lapply(eqs, "[[", "miiv"), paste, collapse = ", ") |
| 3427 | ! |
sargan.stat <- sapply(seq_along(eqs), |
| 3428 | ! |
function(x) eqs[[x]][["sargan"]]["stat"]) |
| 3429 | ! |
sargan.df <- sapply(seq_along(eqs), |
| 3430 | ! |
function(x) eqs[[x]][["sargan"]]["df"]) |
| 3431 | ! |
sargan.pvalue <- sapply(seq_along(eqs), |
| 3432 | ! |
function(x) eqs[[x]][["sargan"]]["pvalue"]) |
| 3433 | ! |
table[[b]] <- data.frame( |
| 3434 | ! |
lhs = lhs, rhs = rhs, instruments = miiv, |
| 3435 | ! |
sargan.stat = sargan.stat, df = sargan.df, pvalue = sargan.pvalue |
| 3436 |
) |
|
| 3437 | ||
| 3438 |
# remove rows for which the Sargan statistic is NA |
|
| 3439 | ! |
na.idx <- which(is.na(sargan.stat)) |
| 3440 | ! |
if (length(na.idx) > 0L) {
|
| 3441 | ! |
table[[b]] <- table[[b]][-na.idx, , drop = FALSE] |
| 3442 |
} |
|
| 3443 | ||
| 3444 | ! |
class(table[[b]]) <- c("lavaan.data.frame", "data.frame")
|
| 3445 |
} |
|
| 3446 | ||
| 3447 |
# return value |
|
| 3448 | ! |
return.value <- table |
| 3449 | ||
| 3450 |
# drop list? |
|
| 3451 | ! |
if (lavmodel@ngroups == 1L && drop.list.single.group) {
|
| 3452 | ! |
return.value <- return.value[[1]] |
| 3453 | ! |
} else if (!is.null(lavdata)) {
|
| 3454 | ! |
if (length(lavdata@group.label) > 0L) {
|
| 3455 | ! |
names(return.value) <- unlist(lavdata@group.label) |
| 3456 |
} |
|
| 3457 |
} |
|
| 3458 | ||
| 3459 | ! |
return.value |
| 3460 |
} |
|
| 3461 | ||
| 3462 |
| 1 |
# New version of parser, written by Luc De Wilde in september/october 2023 |
|
| 2 | ||
| 3 |
# ----------------------- lav_create_enum ------------------------------------ # |
|
| 4 |
# function to create an Enumerable like structure in R |
|
| 5 |
# usage example mycolors <- lav_create_enum(c("black", "white",
|
|
| 6 |
# "orange", "green", "red", "blue")) |
|
| 7 |
# xyz <- mycolors$red |
|
| 8 |
# values are default 1L, ..., number of names, but can be user specified |
|
| 9 |
# ---------------------------------------------------------------------------- # |
|
| 10 |
lav_create_enum <- function(names, values = seq_along(names)) {
|
|
| 11 | 87x |
stopifnot(identical(unique(names), names), is.character(names)) |
| 12 | 87x |
stopifnot(length(names) == length(values)) |
| 13 | 87x |
res <- as.list(setNames(values, names)) |
| 14 | 87x |
res$enum.names <- names |
| 15 | 87x |
res$enum.values <- values |
| 16 | 87x |
res$enum.size <- length(values) |
| 17 | 87x |
res <- as.environment(res) |
| 18 | 87x |
lockEnvironment(res, bindings = TRUE) |
| 19 | 87x |
res |
| 20 |
} |
|
| 21 | ||
| 22 |
# ------------------------ lav_parse_sublist --------------------------------- # |
|
| 23 |
# function to create a list with only some indexes for all members |
|
| 24 |
# ---------------------------------------------------------------------------- # |
|
| 25 |
lav_parse_sublist <- function(inlist, indexes) {
|
|
| 26 | 2174x |
for (j in seq_along(inlist)) {
|
| 27 | 6522x |
inlist[[j]] <- inlist[[j]][indexes] |
| 28 |
} |
|
| 29 | 2174x |
inlist |
| 30 |
} |
|
| 31 | ||
| 32 |
# ------------------------ lav_parse_eval_r_expression ------------------- # |
|
| 33 |
# help function to evaluate the value of an r expression formed by the elements |
|
| 34 |
# with index 'from' to 'to' of a formula 'formul1' |
|
| 35 |
# returns "_error_" if evaluation failed |
|
| 36 |
# used only in lav_parse_modifier |
|
| 37 |
# ---------------------------------------------------------------------------- # |
|
| 38 |
lav_parse_eval_r_expression <- function(formul1, from, to, types) {
|
|
| 39 | 200x |
strings <- vapply(seq.int(from, to), function(x) {
|
| 40 | 200x |
if (formul1$elem.type[x] == types$stringliteral) {
|
| 41 | 200x |
paste0('"', formul1$elem.text[x], '"')
|
| 42 |
} else {
|
|
| 43 | ! |
formul1$elem.text[x] |
| 44 |
} |
|
| 45 |
}, "") |
|
| 46 | 200x |
txt <- paste(strings, collapse = "") |
| 47 | 200x |
result <- try(eval(parse(text = txt), |
| 48 | 200x |
envir = NULL, |
| 49 | 200x |
enclos = baseenv() |
| 50 | 200x |
), silent = TRUE) |
| 51 | 200x |
if (inherits(result, "try-error")) {
|
| 52 | ! |
return("_error_")
|
| 53 |
} |
|
| 54 | 200x |
result |
| 55 |
} |
|
| 56 |
# ------------------------ lav_parse_txtloc --------------------------------- # |
|
| 57 |
# function which translates a position in the model source string to a |
|
| 58 |
# user friendly locator (=[1L]) and the line with position (=[2L]) |
|
| 59 |
# ---------------------------------------------------------------------------- # |
|
| 60 |
lav_parse_txtloc <- function(modelsrc, position) {
|
|
| 61 | 36x |
txt <- c("", "")
|
| 62 | 36x |
if (nchar(modelsrc) >= position && position > 0) {
|
| 63 | 36x |
newlines <- gregexpr("\n", paste0(modelsrc, "\n"), fixed = TRUE)[[1]]
|
| 64 | 36x |
lijn <- which(newlines >= position)[1] |
| 65 | 36x |
if (lijn == 1L) {
|
| 66 | ! |
pos <- position |
| 67 | ! |
lijnchar <- substr(modelsrc, 1L, newlines[1]) |
| 68 |
} else {
|
|
| 69 | 36x |
pos <- position - newlines[lijn - 1L] |
| 70 | 36x |
lijnchar <- substr(modelsrc, newlines[lijn - 1L] + 1L, newlines[lijn]) |
| 71 |
} |
|
| 72 | 36x |
if (nchar(lijnchar) == 1L) {
|
| 73 | ! |
lijnchar <- "" |
| 74 |
} else {
|
|
| 75 | 36x |
lijnchar <- substr(lijnchar, 1L, nchar(lijnchar) - 1) |
| 76 |
} |
|
| 77 |
# adapt line number when first line blank : |
|
| 78 | 36x |
if (grepl("^[ \t]*\n", modelsrc)) lijn <- lijn - 1L
|
| 79 | 36x |
txt <- c( |
| 80 | 36x |
gettextf(" at line %1$s, pos %2$s", lijn, pos),
|
| 81 | 36x |
paste(lijnchar, "\n", strrep(" ", pos - 1L), "^\n", sep = "")
|
| 82 |
) |
|
| 83 |
} |
|
| 84 | 36x |
txt |
| 85 |
} |
|
| 86 | ||
| 87 |
# ------------------------ lav_parse_text_tokens ----------------------------- # |
|
| 88 |
# function to split the model source in tokens. |
|
| 89 |
# Returns a list with tokens with their attributes |
|
| 90 |
# elem.pos : position in source |
|
| 91 |
# elem.type : type of token (cf. definition of types |
|
| 92 |
# in lav_parse_model_string) |
|
| 93 |
# elem.text : the text of the token |
|
| 94 |
# elem.formule.number : sequence number of the 'logical' |
|
| 95 |
# formula where the token occurs |
|
| 96 |
# the function returns the stored tokens in a list |
|
| 97 |
# ---------------------------------------------------------------------------- # |
|
| 98 |
lav_parse_text_tokens <- function(modelsrc, types) {
|
|
| 99 | 87x |
nmax <- nchar(modelsrc) |
| 100 | 87x |
elem.pos <- vector("integer", nmax)
|
| 101 | 87x |
elem.type <- elem.pos |
| 102 | 87x |
elem.text <- vector("character", nmax)
|
| 103 | 87x |
elem.i <- 1L |
| 104 | 87x |
modelsrcw <- paste0(modelsrc, "\n") # working model, must end |
| 105 |
# with a newline for tests via regexpr |
|
| 106 | 87x |
stringliterals <- gregexpr("\"[^\"]*?[\"\n]", modelsrcw)[[1L]]
|
| 107 | 87x |
if (stringliterals[1L] > -1L) {
|
| 108 | 21x |
stringliteral.lengths <- attr(stringliterals, "match.length") |
| 109 | 21x |
for (i in seq_along(stringliterals)) {
|
| 110 | 57x |
pfpos <- stringliterals[i] |
| 111 | 57x |
pflen <- stringliteral.lengths[i] |
| 112 | 57x |
substr(modelsrcw, pfpos + 1L, pfpos + pflen - 2L) <- |
| 113 | 57x |
strrep(" ", pflen - 2L)
|
| 114 | 57x |
elem.pos[elem.i] <- pfpos |
| 115 | 57x |
elem.text[elem.i] <- substr(modelsrc, pfpos + 1L, pfpos + pflen - 2L) |
| 116 | 57x |
elem.type[elem.i] <- types$stringliteral |
| 117 | 57x |
elem.i <- elem.i + 1L |
| 118 |
} |
|
| 119 |
} |
|
| 120 | 87x |
comments <- gregexpr("[#!].*?\n", modelsrcw)[[1L]]
|
| 121 | 87x |
if (comments[1] > -1L) {
|
| 122 | 28x |
comment.lengths <- attr(comments, "match.length") |
| 123 | 28x |
for (i in seq_along(comments)) {
|
| 124 | 103x |
substr(modelsrcw, comments[i], comments[i] + comment.lengths[i] - 1L) <- |
| 125 | 103x |
strrep(" ", comment.lengths[i] - 1L)
|
| 126 |
# check for stringliterals in comment |
|
| 127 | 103x |
str.in.comment <- (elem.pos > comments[i] & |
| 128 | 103x |
elem.pos < comments[i] + comment.lengths[i]) |
| 129 | 103x |
if (any(str.in.comment)) {
|
| 130 | 2x |
elem.type[str.in.comment] <- 0 |
| 131 |
} |
|
| 132 |
} |
|
| 133 |
} |
|
| 134 | 87x |
modelsrcw <- gsub("\t", " ", modelsrcw)
|
| 135 | 87x |
newlines <- gregexpr("[;\n]", modelsrcw)[[1L]]
|
| 136 | 87x |
if (newlines[1L] > -1L) {
|
| 137 | 87x |
for (i in seq_along(newlines)) {
|
| 138 | 1430x |
pfpos <- newlines[i] |
| 139 | 1430x |
substr(modelsrcw, pfpos, pfpos) <- "\n" |
| 140 | 1430x |
elem.pos[elem.i] <- pfpos |
| 141 | 1430x |
elem.text[elem.i] <- "\n" |
| 142 | 1430x |
elem.type[elem.i] <- types$newline |
| 143 | 1430x |
elem.i <- elem.i + 1L |
| 144 |
} |
|
| 145 |
} |
|
| 146 |
# --------------------- handling spaces in operators ----------------------- # |
|
| 147 | 87x |
if (grepl("= +~", modelsrcw)) {
|
| 148 | 3x |
waar <- regexpr("= +~", modelsrcw)[1]
|
| 149 | 3x |
modelsrcw <- gsub("=( +)~", "=~\\1", modelsrcw)
|
| 150 | 3x |
tl <- lav_parse_txtloc(modelsrc, waar) |
| 151 | 3x |
lav_msg_warn(gettext("splitting of '=~' deprecated"),
|
| 152 | 3x |
tl[1L], |
| 153 | 3x |
footer = tl[2L] |
| 154 |
) |
|
| 155 |
} |
|
| 156 | 87x |
if (grepl("[^=~]~ +~", modelsrcw)) {
|
| 157 | 1x |
waar <- regexpr("[^=~]~ +~", modelsrcw)[1]
|
| 158 | 1x |
modelsrcw <- gsub("([^=~])~( +)~", "\\1~~\\2", modelsrcw)
|
| 159 | 1x |
tl <- lav_parse_txtloc(modelsrc, waar + 1L) |
| 160 | 1x |
lav_msg_warn(gettext("splitting of '~~' deprecated"),
|
| 161 | 1x |
tl[1L], |
| 162 | 1x |
footer = tl[2L] |
| 163 |
) |
|
| 164 |
} |
|
| 165 |
# -------------------------------------------------------------------------- # |
|
| 166 | 87x |
lavops <- gregexpr("=~|<~|~\\*~|~~|~|\\|~|==|<|>|:=|:|\\||%", modelsrcw)[[1]]
|
| 167 | 87x |
if (lavops[1L] > -1L) {
|
| 168 | 87x |
lavop.lengths <- attr(lavops, "match.length") |
| 169 | 87x |
for (i in seq_along(lavops)) {
|
| 170 | 1030x |
pfpos <- lavops[i] |
| 171 | 1030x |
pflen <- lavop.lengths[i] |
| 172 | 1030x |
elem.pos[elem.i] <- pfpos |
| 173 | 1030x |
elem.text[elem.i] <- substr(modelsrcw, pfpos, pfpos + pflen - 1L) |
| 174 | 1030x |
elem.type[elem.i] <- types$lavaanoperator |
| 175 | 1030x |
substr(modelsrcw, pfpos, pfpos + pflen - 1L) <- strrep(" ", pflen)
|
| 176 | 1030x |
elem.i <- elem.i + 1L |
| 177 |
} |
|
| 178 |
} |
|
| 179 | 87x |
symbols <- gregexpr("[,()/*?^']", modelsrcw)[[1L]] # f1=~x2 + 0.5 ? x3
|
| 180 | 87x |
symbols1 <- gregexpr("[-+][^.0-9]", modelsrcw)[[1L]] # f1=~x2+x3
|
| 181 | 87x |
symbols2 <- gregexpr("[._0-9a-df-zA-DF-Z)] *[-+][.0-9]", modelsrcw)[[1L]]
|
| 182 |
# f1=~x2+2*x3, len-2 ! |
|
| 183 | 87x |
symbols3 <- gregexpr("[^.0-9][eE] *[-+][.0-9]", modelsrcw)[[1L]]
|
| 184 |
# f1=~xe+2*x3, len-2 ! |
|
| 185 | 87x |
if (symbols1[1L] > -1L) {
|
| 186 | 75x |
if (symbols[1L] == -1L) {
|
| 187 | 13x |
symbols <- symbols1 |
| 188 |
} else {
|
|
| 189 | 62x |
symbols <- c(symbols, symbols1) |
| 190 |
} |
|
| 191 |
} |
|
| 192 | 87x |
if (symbols2[1L] > -1L) {
|
| 193 | 5x |
symbols2.lengths <- attr(symbols2, "match.length") |
| 194 | 5x |
symbols2 <- symbols2 + symbols2.lengths - 2L |
| 195 | 5x |
if (symbols[1L] == -1L) {
|
| 196 | 1x |
symbols <- symbols2 |
| 197 |
} else {
|
|
| 198 | 4x |
symbols <- c(symbols, symbols2) |
| 199 |
} |
|
| 200 |
} |
|
| 201 | 87x |
if (symbols3[1L] > -1L) {
|
| 202 | ! |
symbols3.lengths <- attr(symbols3, "match.length") |
| 203 | ! |
symbols3 <- symbols3 + symbols3.lengths - 2L |
| 204 | ! |
if (symbols[1L] == -1L) {
|
| 205 | ! |
symbols <- symbols3 |
| 206 |
} else {
|
|
| 207 | ! |
symbols <- c(symbols, symbols3) |
| 208 |
} |
|
| 209 |
} |
|
| 210 | 87x |
if (symbols[1L] > -1L) {
|
| 211 | 83x |
for (i in seq_along(symbols)) {
|
| 212 | 2977x |
pfpos <- symbols[i] |
| 213 | 2977x |
substr(modelsrcw, pfpos, pfpos) <- " " |
| 214 | 2977x |
elem.pos[elem.i] <- pfpos |
| 215 | 2977x |
elem.text[elem.i] <- substr(modelsrc, pfpos, pfpos) |
| 216 | 2977x |
elem.type[elem.i] <- types$symbol |
| 217 | 2977x |
elem.i <- elem.i + 1L |
| 218 |
} |
|
| 219 |
} |
|
| 220 | ||
| 221 | 87x |
numliterals <- gregexpr( |
| 222 | 87x |
"([ \n][-+][.0-9]|[ \n]\\.[0-9]|[ \n][0-9])[-+\\.0-9eE]*", |
| 223 | 87x |
paste0(" ", modelsrcw)
|
| 224 | 87x |
)[[1]] |
| 225 | 87x |
if (numliterals[1L] > -1L) {
|
| 226 | 57x |
numliteral.lengths <- attr(numliterals, "match.length") - 1L |
| 227 | 57x |
for (i in seq_along(numliterals)) {
|
| 228 | 923x |
pfpos <- numliterals[i] |
| 229 | 923x |
pflen <- numliteral.lengths[i] |
| 230 | 923x |
substr(modelsrcw, pfpos, pfpos + pflen - 1L) <- strrep(" ", pflen)
|
| 231 | 923x |
elem.pos[elem.i] <- pfpos |
| 232 | 923x |
elem.text[elem.i] <- substr(modelsrc, pfpos, pfpos + pflen - 1L) |
| 233 | 923x |
elem.type[elem.i] <- types$numliteral |
| 234 | 923x |
elem.i <- elem.i + 1L |
| 235 |
} |
|
| 236 |
} |
|
| 237 | 87x |
identifiers <- gregexpr("[ \n][_.[:alpha:]][_.[:alnum:]]*",
|
| 238 | 87x |
paste0(" ", modelsrcw)
|
| 239 | 87x |
)[[1]] |
| 240 | 87x |
identifier.lengths <- attr(identifiers, "match.length") - 1L |
| 241 | 87x |
for (i in seq_along(identifiers)) {
|
| 242 | 3689x |
pfpos <- identifiers[i] |
| 243 | 3689x |
pflen <- identifier.lengths[i] |
| 244 | 3689x |
substr(modelsrcw, pfpos, pfpos + pflen - 1L) <- strrep(" ", pflen)
|
| 245 | 3689x |
elem.pos[elem.i] <- pfpos |
| 246 | 3689x |
elem.text[elem.i] <- substr(modelsrc, pfpos, pfpos + pflen - 1L) |
| 247 | 3689x |
elem.type[elem.i] <- types$identifier |
| 248 | 3689x |
elem.i <- elem.i + 1L |
| 249 |
} |
|
| 250 |
# check for uninterpreted chars |
|
| 251 | 87x |
wrong <- regexpr("[^\"\n ]", modelsrcw)
|
| 252 | 87x |
if (wrong != -1L) {
|
| 253 | ! |
tl <- lav_parse_txtloc(modelsrc, wrong) |
| 254 | ! |
lav_msg_stop(gettext("unexpected character"),
|
| 255 | ! |
tl[1L], |
| 256 | ! |
footer = tl[2L] |
| 257 |
) |
|
| 258 |
} |
|
| 259 |
# remove unused elements from vectors |
|
| 260 | 87x |
elements <- which(elem.type > 0L) |
| 261 | 87x |
elem.pos <- elem.pos[elements] |
| 262 | 87x |
elem.type <- elem.type[elements] |
| 263 | 87x |
elem.text <- elem.text[elements] |
| 264 |
# order tokens |
|
| 265 | 87x |
token.order <- order(elem.pos) |
| 266 | 87x |
elem.pos <- elem.pos[token.order] |
| 267 | 87x |
elem.type <- elem.type[token.order] |
| 268 | 87x |
elem.text <- elem.text[token.order] |
| 269 | ||
| 270 |
# concatenate identifiers with only spaces in between - LDW 22/4/2024 |
|
| 271 | 87x |
elem.i <- length(elem.pos) |
| 272 | 87x |
concatenated <- FALSE |
| 273 | 87x |
while (elem.i > 1L) {
|
| 274 | 10017x |
if (any(elem.type[elem.i] == c(types$identifier, types$numliteral)) && |
| 275 | 10017x |
elem.type[elem.i - 1L] == types$identifier) {
|
| 276 | 15x |
spaces.between <- elem.pos[elem.i] - elem.pos[elem.i - 1L] - |
| 277 | 15x |
length(elem.text[elem.i - 1L]) |
| 278 | 15x |
elem.text[elem.i - 1L] <- paste0( |
| 279 | 15x |
elem.text[elem.i - 1L], |
| 280 | 15x |
strrep(" ", spaces.between),
|
| 281 | 15x |
elem.text[elem.i] |
| 282 |
) |
|
| 283 | 15x |
elem.type[elem.i] <- 0L |
| 284 | 15x |
concatenated <- TRUE |
| 285 |
} |
|
| 286 | 10017x |
elem.i <- elem.i - 1L |
| 287 |
} |
|
| 288 | 87x |
if (concatenated) { # remove items with type 0
|
| 289 | 7x |
elements <- which(elem.type > 0L) |
| 290 | 7x |
elem.pos <- elem.pos[elements] |
| 291 | 7x |
elem.type <- elem.type[elements] |
| 292 | 7x |
elem.text <- elem.text[elements] |
| 293 |
} |
|
| 294 | ||
| 295 |
# to set formula number |
|
| 296 | 87x |
elem.formula.number <- rep(0L, length(elem.type)) |
| 297 | 87x |
frm.number <- 1L |
| 298 | 87x |
frm.hasefa <- FALSE |
| 299 | 87x |
frm.lastplus <- FALSE |
| 300 | 87x |
frm.incremented <- FALSE |
| 301 | 87x |
for (i in seq_along(elem.type)) {
|
| 302 | 10089x |
elem.formula.number[i] <- frm.number |
| 303 | 10089x |
if (elem.type[i] == types$identifier && elem.text[i] == "efa") {
|
| 304 | 24x |
frm.hasefa <- TRUE |
| 305 |
} |
|
| 306 | 10089x |
if (any(elem.text[i] == |
| 307 | 10089x |
c("+", "*", "=~", "-", "<~", "~*~", "~~", "~", "|~", "|", "%"))) {
|
| 308 | 2926x |
if (frm.incremented) {
|
| 309 | 7x |
frm.number <- frm.number - 1L |
| 310 | 7x |
elem.formula.number[i] <- frm.number |
| 311 | 7x |
frm.incremented <- FALSE |
| 312 |
} |
|
| 313 | 2926x |
frm.lastplus <- TRUE |
| 314 |
} else {
|
|
| 315 | 7163x |
if (any(elem.type[i] == c( |
| 316 | 7163x |
types$stringliteral, types$identifier, types$numliteral, |
| 317 | 7163x |
types$stringliteral, types$symbol |
| 318 |
))) {
|
|
| 319 | 5668x |
frm.lastplus <- FALSE |
| 320 |
} |
|
| 321 | 7163x |
if (i > 1 && elem.type[i] != types$newline && |
| 322 | 7163x |
elem.type[i - 1L] == types$lavaanoperator) {
|
| 323 | 1022x |
frm.hasefa <- FALSE |
| 324 |
} |
|
| 325 |
} |
|
| 326 | 10089x |
if (elem.type[i] == types$newline) {
|
| 327 | 1430x |
if (i > 1 && elem.type[i - 1L] != types$newline) { # ignore multiple nl's
|
| 328 | 1050x |
if (!frm.hasefa && !frm.lastplus) {
|
| 329 | 1034x |
frm.number <- frm.number + 1L |
| 330 | 1034x |
frm.incremented <- TRUE |
| 331 |
} else {
|
|
| 332 | 16x |
frm.hasefa <- FALSE |
| 333 |
} |
|
| 334 |
} |
|
| 335 |
} else {
|
|
| 336 | 8659x |
frm.incremented <- FALSE |
| 337 |
} |
|
| 338 |
} |
|
| 339 | 87x |
list( |
| 340 | 87x |
elem.pos = elem.pos, elem.type = elem.type, |
| 341 | 87x |
elem.text = elem.text, elem.formula.number = elem.formula.number |
| 342 |
) |
|
| 343 |
} |
|
| 344 | ||
| 345 |
# ------------------------ lav_parse_tokens_formulas ------------------------- # |
|
| 346 |
# function to group the modellist tokens in 'mono' formulas. |
|
| 347 |
# mono means that the terms (for formulas other then blocks and constraints) |
|
| 348 |
# are split in seperate formula's, e.g. |
|
| 349 |
# a1 + a2 =~ b1 + b2 becomes |
|
| 350 |
# / a1 =~ b1 |
|
| 351 |
# | a1 =~ b2 |
|
| 352 |
# | a2 =~ b1 |
|
| 353 |
# \ a2 =~ b2 |
|
| 354 |
# newlines are removed |
|
| 355 |
# the function returns a list of formulas |
|
| 356 |
# ---------------------------------------------------------------------------- # |
|
| 357 |
lav_parse_tokens_formulas <- function(modellist, modelsrc, types) {
|
|
| 358 | 87x |
real.operators <- c("=~", "<~", "~*~", "~~", "~", "|~", "|", "%")
|
| 359 | 87x |
welke <- modellist$elem.type != types$newline |
| 360 | 87x |
formula.numbers <- unique(modellist$elem.formula.number[welke]) |
| 361 | 87x |
formulas <- lapply(formula.numbers, function(s) {
|
| 362 | 1027x |
welkenu <- modellist$elem.formula.number == s & welke |
| 363 | 1027x |
list( |
| 364 | 1027x |
elem.pos = modellist$elem.pos[welkenu], |
| 365 | 1027x |
elem.type = modellist$elem.type[welkenu], |
| 366 | 1027x |
elem.text = modellist$elem.text[welkenu] |
| 367 |
) |
|
| 368 |
}) |
|
| 369 | 87x |
maxnum <- length(formula.numbers) + sum(modellist$elem.text == "+") |
| 370 | 87x |
outval <- vector(mode = "list", length = maxnum) |
| 371 | 87x |
realnum <- 0L |
| 372 | 87x |
for (i in seq_along(formulas)) {
|
| 373 | 1022x |
formul1 <- formulas[[i]] |
| 374 | 1022x |
opi <- which(formul1$elem.type == types$lavaanoperator) |
| 375 | 1022x |
nelem <- length(formul1$elem.type) |
| 376 | 1022x |
if (length(opi) == 0L) {
|
| 377 | 2x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1]) |
| 378 | 2x |
lav_msg_stop(gettext("formula without valid operator"),
|
| 379 | 2x |
tl[1L], |
| 380 | 2x |
footer = tl[2L] |
| 381 |
) |
|
| 382 |
} |
|
| 383 | 5x |
if (length(opi) > 1L) opi <- opi[1] # only first operator taken |
| 384 | 1020x |
if (any(formul1$elem.text[opi] == real.operators) && |
| 385 | 1020x |
sum(formul1$elem.text == "+") > 0) {
|
| 386 |
# check + symbols outside parentheses in left and right hand side |
|
| 387 | 231x |
lhplusjes <- integer(0) |
| 388 | 231x |
openparentheses <- 0L |
| 389 | 231x |
for (jj in seq.int(1L, opi - 1L)) {
|
| 390 | 385x |
if (formul1$elem.text[jj] == "(") {
|
| 391 | 24x |
openparentheses <- openparentheses + 1L |
| 392 | 24x |
next |
| 393 |
} |
|
| 394 | 361x |
if (formul1$elem.text[jj] == ")") {
|
| 395 | 24x |
openparentheses <- openparentheses - 1L |
| 396 | 24x |
next |
| 397 |
} |
|
| 398 | 337x |
if (formul1$elem.text[jj] == "+" && openparentheses == 0L) {
|
| 399 | 17x |
lhplusjes <- c(lhplusjes, jj) |
| 400 |
} |
|
| 401 |
} |
|
| 402 | 231x |
lhplusjes <- c(lhplusjes, opi) |
| 403 | 231x |
plusjes <- integer(0) |
| 404 | 231x |
openparentheses <- 0L |
| 405 | 231x |
for (jj in seq.int(opi + 1L, nelem)) {
|
| 406 | 3285x |
if (formul1$elem.text[jj] == "(") {
|
| 407 | 107x |
openparentheses <- openparentheses + 1L |
| 408 | 107x |
next |
| 409 |
} |
|
| 410 | 3178x |
if (formul1$elem.text[jj] == ")") {
|
| 411 | 107x |
openparentheses <- openparentheses - 1L |
| 412 | 107x |
next |
| 413 |
} |
|
| 414 | 3071x |
if (formul1$elem.text[jj] == "+" && openparentheses == 0L) {
|
| 415 | 772x |
plusjes <- c(plusjes, jj) |
| 416 |
} |
|
| 417 |
} |
|
| 418 | 231x |
plusjes <- c(plusjes, nelem + 1) |
| 419 |
# splitting lhs and rhs on '+' signs |
|
| 420 | 231x |
for (j in seq_along(lhplusjes)) {
|
| 421 | 248x |
j0 <- 1L |
| 422 | 17x |
if (j > 1L) j0 <- lhplusjes[j - 1L] + 1L |
| 423 | 248x |
j1 <- lhplusjes[j] - 1L |
| 424 | ! |
if (j1 < j0) next # skip empty parts |
| 425 | 248x |
for (k in seq_along(plusjes)) {
|
| 426 | 1050x |
k0 <- opi + 1L |
| 427 | 1050x |
k1 <- plusjes[k] - 1L |
| 428 | 802x |
if (k > 1L) k0 <- plusjes[k - 1L] + 1L |
| 429 | ! |
if (k1 < k0) next # skip empty parts |
| 430 | 1050x |
welke <- c(seq.int(j0, j1), opi, seq.int(k0, k1)) |
| 431 | 1050x |
realnum <- realnum + 1L |
| 432 | 1050x |
outval[[realnum]] <- lav_parse_sublist(formul1, welke) |
| 433 |
} |
|
| 434 |
} |
|
| 435 |
} else {
|
|
| 436 | 789x |
realnum <- realnum + 1L |
| 437 | 789x |
outval[[realnum]] <- formul1 |
| 438 |
} |
|
| 439 |
} |
|
| 440 | 85x |
outval[seq_len(realnum)] |
| 441 |
} |
|
| 442 |
# ------------------------ lav_parse_check_name ------------------------ # |
|
| 443 |
# checks if an element of the elem.text member in a list is a valid r-name |
|
| 444 |
# ---------------------------------------------------------------------------- # |
|
| 445 |
lav_parse_check_name <- function(formul1, ind, modelsrc) {
|
|
| 446 |
# allow spaces, LDW 22/4/2024 |
|
| 447 | 4300x |
testitem <- gsub(" ", "_", formul1$elem.text[ind], fixed = TRUE)
|
| 448 | ||
| 449 | 4300x |
if (make.names(testitem) != testitem) {
|
| 450 | 2x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[ind]) |
| 451 | 2x |
lav_msg_stop( |
| 452 | 2x |
gettext("identifier is either a reserved word (in R) or
|
| 453 | 2x |
contains an illegal character"), |
| 454 | 2x |
tl[1L], |
| 455 | 2x |
footer = tl[2L] |
| 456 |
) |
|
| 457 |
} |
|
| 458 | 4298x |
invisible(NULL) |
| 459 |
} |
|
| 460 |
# ------------------------ lav_parse_modifier ---------------------------- # |
|
| 461 |
# The function takes a list with tokens belonging to a single 'mono' lavaan |
|
| 462 |
# formula as input. The other arguments are: |
|
| 463 |
# lhs : check for lhs or rhs modifier |
|
| 464 |
# opi : index of the lavaan operator in the list-items |
|
| 465 |
# modelsrc : the model source string (for error messages and warnings) |
|
| 466 |
# types : the types of tokens |
|
| 467 |
# rme : index of last element of modifier in formula (*) |
|
| 468 |
# rmeprev : index of first element of modifier in formula - 1L (*) |
|
| 469 |
# The function return the modifier detected as element of a list |
|
| 470 |
# with name the modifier type (efa, fixed, start, label, lower, upper, prior or |
|
| 471 |
# rv) and value an array of values (length > 1 if vector via c(...)) for the |
|
| 472 |
# modifier value. |
|
| 473 |
# (*) if rme > remprev the rhs is limited to the elements with index |
|
| 474 |
# rmeprev+1:rme, this is to support multiple modifiers for the same element. |
|
| 475 |
# An error message is produced when no modifier can be determined. |
|
| 476 |
# ---------------------------------------------------------------------------- # |
|
| 477 |
lav_parse_modifier <- function(formul1, lhs, opi, modelsrc, types, |
|
| 478 |
rme = 0L, rmeprev = 0L, modenv) {
|
|
| 479 | 1310x |
if (rme > rmeprev) {
|
| 480 | 1110x |
welke <- c(seq.int(1L, opi), seq.int(rmeprev + 1L, rme), |
| 481 | 1110x |
length(formul1$elem.type)) |
| 482 | 1110x |
formul1 <- lav_parse_sublist(formul1, welke) |
| 483 |
} |
|
| 484 | 1310x |
nelem <- length(formul1$elem.type) |
| 485 |
# remove unnecessary parentheses (one element between parentheses, previous |
|
| 486 |
# no identifier) |
|
| 487 | 1310x |
check.more <- TRUE |
| 488 | 1310x |
while (check.more && nelem > 4L) {
|
| 489 | 1318x |
check.more <- FALSE |
| 490 | 1318x |
for (par.i in seq.int(3L, nelem - 1L)) {
|
| 491 | 4967x |
if (formul1$elem.text[par.i - 1L] == "(" &&
|
| 492 | 4967x |
formul1$elem.text[par.i + 1L] == ")" && |
| 493 | 4967x |
formul1$elem.type[par.i - 2L] != types$identifier) {
|
| 494 | 8x |
formul1$elem.type[par.i - 1L] <- 0L |
| 495 | 8x |
formul1$elem.type[par.i + 1L] <- 0L |
| 496 | 8x |
check.more <- TRUE |
| 497 |
} |
|
| 498 |
} |
|
| 499 | 1318x |
if (check.more) {
|
| 500 | 8x |
formul1 <- lav_parse_sublist(formul1, which(formul1$elem.type > 0)) |
| 501 | 8x |
nelem <- length(formul1$elem.type) |
| 502 |
} |
|
| 503 |
} |
|
| 504 | 1310x |
if (lhs) {
|
| 505 |
# modifier on left hand side |
|
| 506 |
# only 1 possibility : efa ( expression-resulting-in-char ) * |
|
| 507 |
# identifier operator ... (rhs) ... |
|
| 508 | 200x |
if (formul1$elem.text[1L] == "efa" && |
| 509 | 200x |
formul1$elem.text[2L] == "(" &&
|
| 510 | 200x |
formul1$elem.text[opi - 3L] == ")" && |
| 511 | 200x |
formul1$elem.text[opi - 2L] == "*") {
|
| 512 | 200x |
temp <- lav_parse_eval_r_expression(formul1, 3L, opi - 4L, types) |
| 513 | 200x |
if (is.character(temp) && temp[1] != "_error_") {
|
| 514 | 200x |
return(list(efa = temp)) |
| 515 |
} |
|
| 516 |
} |
|
| 517 | ! |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1L]) |
| 518 | ! |
lav_msg_stop(gettext("invalid left hand side modifier"),
|
| 519 | ! |
tl[1L], |
| 520 | ! |
footer = tl[2L] |
| 521 |
) |
|
| 522 |
} else {
|
|
| 523 | 1110x |
getmodifier <- function(s) {
|
| 524 | 1110x |
if (s %in% c("c", "t")) {
|
| 525 | 8x |
tmp <- s |
| 526 | 8x |
attr(tmp, "tiepe") <- "label" |
| 527 | 8x |
return(tmp) |
| 528 |
} |
|
| 529 | 1102x |
v <- all.vars(str2expression(s)) |
| 530 | 1102x |
for (v1 in v) {
|
| 531 | 472x |
assign(v1, v1, modenv) |
| 532 |
} |
|
| 533 | 1102x |
tmp <- eval(str2expression(s), modenv) |
| 534 | 1101x |
rm(list = v, pos = modenv) |
| 535 | 1101x |
if (is.null(attr(tmp, "tiepe"))) {
|
| 536 | 1017x |
if (is.numeric(tmp) || is.logical(tmp)) {
|
| 537 | 566x |
attr(tmp, "tiepe") <- "fixed" |
| 538 |
} else {
|
|
| 539 | 451x |
attr(tmp, "tiepe") <- "label" |
| 540 |
} |
|
| 541 |
} |
|
| 542 | 1101x |
tmp |
| 543 |
} |
|
| 544 | 1110x |
strings <- vapply(seq.int(opi + 1L, nelem - 2L), function(x) {
|
| 545 | 2657x |
if (formul1$elem.type[x] == types$stringliteral) {
|
| 546 | 31x |
paste0('"', formul1$elem.text[x], '"')
|
| 547 |
} else {
|
|
| 548 | 2626x |
formul1$elem.text[x] |
| 549 |
} |
|
| 550 |
}, "") |
|
| 551 | 1110x |
txt <- paste(strings, collapse = "") |
| 552 | 1110x |
if (formul1$elem.text[nelem - 1L] == "?") {
|
| 553 | 14x |
formul1$elem.text[nelem - 1L] <- "*" |
| 554 | 14x |
txt <- paste0("start(", txt, ")")
|
| 555 |
} |
|
| 556 | 1110x |
if (formul1$elem.text[nelem - 1L] != "*") {
|
| 557 | ! |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[nelem - 1L]) |
| 558 | ! |
lav_msg_stop(gettext("invalid modifier symbol (should be '*' or '?')"),
|
| 559 | ! |
tl[1L], |
| 560 | ! |
footer = tl[2L] |
| 561 |
) |
|
| 562 |
} |
|
| 563 | 1110x |
modifier <- try(getmodifier(txt), silent = TRUE) |
| 564 | 1110x |
if (inherits(modifier, "try-error")) {
|
| 565 | 1x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi + 1L]) |
| 566 | 1x |
lav_msg_stop(gettext("invalid modifier specification"),
|
| 567 | 1x |
tl[1L], |
| 568 | 1x |
footer = tl[2L] |
| 569 |
) |
|
| 570 |
} |
|
| 571 | 1109x |
if (attr(modifier, "tiepe") == "label") {
|
| 572 | 477x |
if (!is.character(modifier)) {
|
| 573 | ! |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi + 1L]) |
| 574 | ! |
lav_msg_stop(gettext("invalid label modifier (should be character)"),
|
| 575 | ! |
tl[1L], |
| 576 | ! |
footer = tl[2L] |
| 577 |
) |
|
| 578 |
} |
|
| 579 |
} else {
|
|
| 580 | 632x |
if (!is.numeric(modifier) && !all(is.na(modifier))) {
|
| 581 | 1x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi + 1L]) |
| 582 | 1x |
lav_msg_stop(gettext("invalid numeric modifier"),
|
| 583 | 1x |
tl[1L], |
| 584 | 1x |
footer = tl[2L] |
| 585 |
) |
|
| 586 |
} |
|
| 587 |
} |
|
| 588 | 1108x |
modifierlist <- list(as.vector(modifier)) |
| 589 | 1108x |
names(modifierlist) <- attr(modifier, "tiepe") |
| 590 | 1108x |
modifierlist |
| 591 |
} |
|
| 592 |
} |
|
| 593 | ||
| 594 |
# -------------------- main parsing function --------------------------------- # |
|
| 595 |
lav_parse_model_string <- function(model.syntax = "", as.data.frame. = FALSE) {
|
|
| 596 | 118x |
stopifnot(length(model.syntax) > 0L) |
| 597 |
# replace 'strange' tildes (in some locales) (new in 0.6-6) |
|
| 598 | 118x |
modelsrc <- gsub( |
| 599 | 118x |
pattern = "\u02dc", |
| 600 | 118x |
replacement = "~", |
| 601 | 118x |
paste(unlist(model.syntax), "", collapse = "\n") |
| 602 |
) |
|
| 603 | 118x |
hashstring <- paste0("mdl_", lav_char2hash(paste0(modelsrc, as.data.frame.)))
|
| 604 | 118x |
if (exists(hashstring, envir = lavaan_cache_env)) {
|
| 605 | 31x |
return(get(hashstring, envir = lavaan_cache_env)) |
| 606 |
} |
|
| 607 | 87x |
modenv <- new.env() |
| 608 | 87x |
assign("label", function(...) {
|
| 609 | 12x |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "label"; x
|
| 610 | 87x |
}, modenv) |
| 611 | 87x |
assign("start", function(...) {
|
| 612 | 60x |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "start"; x
|
| 613 | 87x |
}, modenv) |
| 614 | 87x |
assign("fixed", function(...) {
|
| 615 | 1x |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "fixed"; x
|
| 616 | 87x |
}, modenv) |
| 617 | 87x |
assign("upper", function(...) {
|
| 618 | 3x |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "upper"; x
|
| 619 | 87x |
}, modenv) |
| 620 | 87x |
assign("lower", function(...) {
|
| 621 | ! |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "lower"; x
|
| 622 | 87x |
}, modenv) |
| 623 | 87x |
assign("rv", function(...) {
|
| 624 | 2x |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "rv"; x
|
| 625 | 87x |
}, modenv) |
| 626 | 87x |
assign("prior", function(...) {
|
| 627 | ! |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "prior"; x
|
| 628 | 87x |
}, modenv) |
| 629 | 87x |
assign("equal", function(...) {
|
| 630 | 6x |
x <- do.call("c", args = list(...)); attr(x, "tiepe") <- "label"; x
|
| 631 | 87x |
}, modenv) |
| 632 | 87x |
types <- lav_create_enum(c( |
| 633 | 87x |
"identifier", "numliteral", "stringliteral", |
| 634 | 87x |
"symbol", "lavaanoperator", "newline" |
| 635 |
)) |
|
| 636 | 87x |
modellist <- lav_parse_text_tokens(modelsrc, types) |
| 637 | 87x |
if (lav_debug()) {
|
| 638 | ! |
print(data.frame( |
| 639 | ! |
pos = modellist$elem.pos, |
| 640 | ! |
type = types$enum.names[modellist$elem.type], |
| 641 | ! |
text = modellist$elem.text, |
| 642 | ! |
formula = modellist$elem.formula.number |
| 643 |
)) |
|
| 644 |
} |
|
| 645 | 87x |
formulalist <- lav_parse_tokens_formulas(modellist, modelsrc, types) |
| 646 |
#---- analyse syntax formulas and put in flat.----- |
|
| 647 | 85x |
max.mono.formulas <- length(formulalist) |
| 648 | 85x |
flat.lhs <- character(max.mono.formulas) |
| 649 | 85x |
flat.op <- character(max.mono.formulas) |
| 650 | 85x |
flat.rhs <- character(max.mono.formulas) |
| 651 | 85x |
flat.rhs.mod.idx <- integer(max.mono.formulas) |
| 652 | 85x |
flat.block <- integer(max.mono.formulas) # keep track of groups using ":" opr |
| 653 | 85x |
flat.fixed <- character(max.mono.formulas) # only for display purposes! |
| 654 | 85x |
flat.start <- character(max.mono.formulas) # only for display purposes! |
| 655 | 85x |
flat.lower <- character(max.mono.formulas) # only for display purposes! |
| 656 | 85x |
flat.upper <- character(max.mono.formulas) # only for display purposes! |
| 657 | 85x |
flat.label <- character(max.mono.formulas) # only for display purposes! |
| 658 | 85x |
flat.prior <- character(max.mono.formulas) |
| 659 | 85x |
flat.efa <- character(max.mono.formulas) |
| 660 | 85x |
flat.rv <- character(max.mono.formulas) |
| 661 | 85x |
flat.idx <- 0L |
| 662 | 85x |
mod.idx <- 0L |
| 663 | 85x |
constraints <- list() |
| 664 | 85x |
mod <- list() |
| 665 | 85x |
block <- 1L |
| 666 | 85x |
block.op <- FALSE |
| 667 | 85x |
if (lav_debug()) {
|
| 668 | ! |
cat("formula to analyse:\n")
|
| 669 |
} |
|
| 670 |
# operators <- c("=~", "<~", "~*~", "~~", "~", "|~", "==", "<", ">", ":=",
|
|
| 671 |
# ":", "|", "%") |
|
| 672 | 85x |
constraint_operators <- c("==", "<", ">", ":=")
|
| 673 | 85x |
for (s in seq_along(formulalist)) {
|
| 674 | 1817x |
formul1 <- formulalist[[s]] |
| 675 | 1817x |
if (lav_debug()) {
|
| 676 | ! |
cat(vapply(seq_along(formul1$elem.type), function(j) {
|
| 677 | ! |
if (formul1$elem.type[j] == types$stringliteral) {
|
| 678 | ! |
return(dQuote(formul1$elem.text[j], FALSE)) |
| 679 |
} |
|
| 680 | ! |
formul1$elem.text[j] |
| 681 | ! |
}, ""), "\n") |
| 682 |
} |
|
| 683 | 1817x |
nelem <- length(formul1$elem.type) |
| 684 |
# where is the operator |
|
| 685 | 1817x |
opi <- which(formul1$elem.type == types$lavaanoperator) |
| 686 | 1817x |
if (length(opi) > 1L) { # if more then 1 operator skip operators ':'
|
| 687 | 6x |
opii <- 1L |
| 688 | 6x |
while (formul1$elem.text[opi[opii]] == ":" && opii < length(opi)) {
|
| 689 | ! |
opii <- opii + 1L |
| 690 |
} |
|
| 691 | 6x |
opi <- opi[opii] |
| 692 |
} |
|
| 693 | 1817x |
op <- formul1$elem.text[opi] |
| 694 | 1817x |
if (any(op == constraint_operators)) { # ----- constraints -------
|
| 695 | 32x |
lhs <- paste(formul1$elem.text[seq.int(1L, opi - 1L)], collapse = "") |
| 696 | 32x |
rhs <- paste(formul1$elem.text[seq.int(opi + 1L, nelem)], collapse = "") |
| 697 | 32x |
constraints <- c( |
| 698 | 32x |
constraints, |
| 699 | 32x |
list(list( |
| 700 | 32x |
op = op, |
| 701 | 32x |
lhs = lhs, |
| 702 | 32x |
rhs = rhs, |
| 703 | 32x |
user = 1L |
| 704 |
)) |
|
| 705 |
) |
|
| 706 | 32x |
next |
| 707 |
} |
|
| 708 | 1785x |
if (op == ":") { # ------------------------- block start ----------------- #
|
| 709 | 23x |
if (opi == 1L) {
|
| 710 | ! |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1]) |
| 711 | ! |
lav_msg_stop( |
| 712 | ! |
gettext( |
| 713 | ! |
"Missing block identifier. The correct syntax is: \"LHS: RHS\", |
| 714 | ! |
where LHS is a block identifier (eg group or level), and RHS is |
| 715 | ! |
the group/level/block number or label." |
| 716 | ! |
), tl[1L], footer = tl[2L] |
| 717 |
) |
|
| 718 |
} |
|
| 719 | 23x |
if (opi > 2L || all(tolower(formul1$elem.text[1]) != |
| 720 | 23x |
c("group", "level", "block", "class"))) {
|
| 721 | ! |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1]) |
| 722 | ! |
lav_msg_stop( |
| 723 | ! |
gettext( |
| 724 | ! |
"Invalid block identifier. The correct syntax is: \"LHS: RHS\", |
| 725 | ! |
where LHS is a block identifier (eg group or level), and RHS is |
| 726 | ! |
the group/level/block number or label." |
| 727 |
), |
|
| 728 | ! |
tl[1L], footer = tl[2L] |
| 729 |
) |
|
| 730 |
} |
|
| 731 | 23x |
if (nelem != 3 || all(formul1$elem.type[3] != |
| 732 | 23x |
c(types$stringliteral, types$identifier, types$numliteral))) {
|
| 733 | 1x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1]) |
| 734 | 1x |
lav_msg_stop( |
| 735 | 1x |
gettext("syntax contains block identifier \"group\" with missing or
|
| 736 | 1x |
invalid number/label.The correct syntax is: \"LHS: RHS\", where |
| 737 | 1x |
LHS is a block identifier (eg group or level), and RHS is the |
| 738 | 1x |
group/level/block number or label."), |
| 739 | 1x |
tl[1L], |
| 740 | 1x |
footer = tl[2L] |
| 741 |
) |
|
| 742 |
} |
|
| 743 | 22x |
flat.idx <- flat.idx + 1L |
| 744 | 22x |
flat.lhs[flat.idx] <- formul1$elem.text[1] |
| 745 | 22x |
flat.op[flat.idx] <- op |
| 746 | 22x |
flat.rhs[flat.idx] <- formul1$elem.text[3] |
| 747 | 22x |
flat.rhs.mod.idx[flat.idx] <- 0L |
| 748 | 22x |
if (block.op) {
|
| 749 | 16x |
block <- block + 1L |
| 750 |
} else {
|
|
| 751 | 6x |
if (flat.idx != 1) {
|
| 752 | 1x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[1]) |
| 753 | 1x |
lav_msg_warn( |
| 754 | 1x |
gettext("First block defined after other formula's"),
|
| 755 | 1x |
tl[1L], |
| 756 | 1x |
footer = tl[2L] |
| 757 |
) |
|
| 758 |
} |
|
| 759 |
} |
|
| 760 | 22x |
flat.block[flat.idx] <- block |
| 761 | 22x |
block.op <- TRUE |
| 762 | 22x |
next |
| 763 |
} |
|
| 764 |
# ------------------ relational operators -------------------------------- # |
|
| 765 |
# warn if some identifiers contain spaces |
|
| 766 | 1762x |
contsp <- which(formul1$elem.type == types$identifier & |
| 767 | 1762x |
grepl(" ", formul1$elem.text, fixed = TRUE))
|
| 768 | 1762x |
if (length(contsp) > 0L) {
|
| 769 | 18x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[contsp[1L]]) |
| 770 | 18x |
lav_msg_warn( |
| 771 | 18x |
gettextf( |
| 772 | 18x |
"having identifiers with spaces ('%s') is deprecated",
|
| 773 | 18x |
formul1$elem.text[contsp[1]] |
| 774 |
), |
|
| 775 | 18x |
tl[1L], |
| 776 | 18x |
footer = tl[2L] |
| 777 |
) |
|
| 778 |
} |
|
| 779 |
# checks for valid names in lhs and rhs |
|
| 780 | 1762x |
lav_parse_check_name(formul1, opi - 1L, modelsrc) # valid name lhs |
| 781 | 1762x |
for (j in seq.int(opi + 1L, nelem)) { # valid names rhs
|
| 782 | 5546x |
if (formul1$elem.type[j] == types$identifier && |
| 783 | 5546x |
formul1$elem.text[j] != "NA") {
|
| 784 | 2538x |
lav_parse_check_name(formul1, j, modelsrc) |
| 785 |
} |
|
| 786 |
} |
|
| 787 | 1760x |
if (formul1$elem.type[nelem] != types$identifier && |
| 788 | 1760x |
(formul1$elem.type[nelem] != types$numliteral || |
| 789 | 1760x |
all(op != c("~", "|~", "=~")))) {
|
| 790 | ! |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[nelem]) |
| 791 | ! |
lav_msg_stop( |
| 792 | ! |
gettext("Last element of rhs part expected to be an identifier or,
|
| 793 | ! |
for operator ~, |~ or =~, a numeric literal!"), |
| 794 | ! |
tl[1L], |
| 795 | ! |
footer = tl[2L] |
| 796 |
) |
|
| 797 |
} |
|
| 798 |
# intercept fixed on 0 |
|
| 799 |
# replace 'lhs ~ 0' => 'lhs ~ 0 * 1' - intercept fixed on zero |
|
| 800 | 1760x |
if (formul1$elem.text[nelem] == "0" && op == "~" && opi == nelem - 1L) {
|
| 801 | 4x |
formul1$elem.type <- c(formul1$elem.type, types$symbol, types$numliteral) |
| 802 | 4x |
formul1$elem.text <- c(formul1$elem.text, "*", "1") |
| 803 | 4x |
formul1$elem.pos <- c(formul1$elem.pos, rep(formul1$elem.pos[nelem], 2)) |
| 804 | 4x |
nelem <- length(formul1$elem.type) |
| 805 |
} |
|
| 806 |
# phantom latent variable |
|
| 807 |
# replace 'lhs =~ 0' => 'lhs =~ fixed(0)*lhs', 0 can be other numliteral |
|
| 808 |
# also, lhs is last element before '=~' |
|
| 809 | 1760x |
if (formul1$elem.type[nelem] == types$numliteral && op == "=~") {
|
| 810 | 1x |
formul1$elem.type <- c( |
| 811 | 1x |
formul1$elem.type[seq.int(1L, nelem - 1L)], types$identifier, |
| 812 | 1x |
types$symbol, types$numliteral, types$symbol, types$symbol, |
| 813 | 1x |
types$identifier |
| 814 |
) |
|
| 815 | 1x |
formul1$elem.text <- c( |
| 816 | 1x |
formul1$elem.text[seq.int(1L, nelem - 1L)], "fixed", "(",
|
| 817 | 1x |
formul1$elem.text[nelem], ")", "*", formul1$elem.text[opi - 1L] |
| 818 |
) |
|
| 819 | 1x |
formul1$elem.pos <- c( |
| 820 | 1x |
formul1$elem.pos[seq.int(1L, nelem - 1L)], |
| 821 | 1x |
rep(formul1$elem.pos[nelem], 6) |
| 822 |
) |
|
| 823 | 1x |
nelem <- length(formul1$elem.type) |
| 824 |
} |
|
| 825 |
# handling interaction variable types |
|
| 826 | 1760x |
colons <- which(formul1$elem.text[seq.int(1L, nelem - 1L)] == ":" & |
| 827 | 1760x |
formul1$elem.type[seq.int(2L, nelem)] == types$identifier) |
| 828 |
# check at most 1 colon |
|
| 829 | 1760x |
if (length(colons) > 2L || |
| 830 | 1760x |
(length(colons) == 2L && (colons[1L] > opi || colons[2L] < opi))) {
|
| 831 | ! |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[colons[2]]) |
| 832 | ! |
lav_msg_stop( |
| 833 | ! |
gettext( |
| 834 | ! |
"Three-way or higher-order interaction terms (using multiple |
| 835 | ! |
colons) are not supported in the lavaan syntax; please manually |
| 836 | ! |
construct the product terms yourself in the data.frame, give |
| 837 | ! |
them an appropriate name, and then you can use these interaction |
| 838 | ! |
variables as any other (observed) variable in the model syntax." |
| 839 | ! |
), tl[1L], footer = tl[2L] |
| 840 |
) |
|
| 841 |
} |
|
| 842 | 1760x |
if (length(colons) > 0L) {
|
| 843 |
# collapse items around colon "a" ":" "b" => "a:b" |
|
| 844 | 6x |
formul1$elem.text[colons[1L] - 1L] <- |
| 845 | 6x |
paste(formul1$elem.text[seq.int(colons[1L] - 1L, colons[1L] + 1L)], |
| 846 | 6x |
collapse = "" |
| 847 |
) |
|
| 848 | 6x |
formul1 <- lav_parse_sublist(formul1, |
| 849 | 6x |
setdiff(seq.int(1L, nelem), seq.int(colons[1L], colons[1L] + 1L))) |
| 850 | 6x |
nelem <- length(formul1$elem.type) |
| 851 | 6x |
if (colons[1L] < opi) {
|
| 852 | ! |
opi <- opi - 2L # is in LHS |
| 853 | ! |
if (length(colons) == 2L) colons[2L] <- colons[2L] - 2L |
| 854 |
} |
|
| 855 |
} |
|
| 856 | 1760x |
if (length(colons) == 2L) {
|
| 857 |
# collapse items around colon "a" ":" "b" => "a:b" |
|
| 858 | ! |
formul1$elem.text[colons[2L] - 1L] <- |
| 859 | ! |
paste(formul1$elem.text[seq.int(colons[2L] - 1L, colons[2L] + 1L)], |
| 860 | ! |
collapse = "" |
| 861 |
) |
|
| 862 | ! |
formul1 <- lav_parse_sublist(formul1, |
| 863 | ! |
setdiff(seq.int(1L, nelem), seq.int(colons[2L], colons[2L] + 1L))) |
| 864 | ! |
nelem <- length(formul1$elem.type) |
| 865 |
} |
|
| 866 |
# modifiers |
|
| 867 | 1760x |
rhsmodelems <- which(seq_along(formul1$elem.type) > opi & |
| 868 | 1760x |
formul1$elem.type == types$symbol & |
| 869 | 1760x |
(formul1$elem.text == "*" | formul1$elem.text == "?")) |
| 870 | 1760x |
for (j in seq_along(rhsmodelems)) {
|
| 871 | 1122x |
if (sum(formul1$elem.text[seq.int(opi, rhsmodelems[j])] == "(") !=
|
| 872 | 1122x |
sum(formul1$elem.text[seq.int(opi, rhsmodelems[j])] == ")")) |
| 873 | 12x |
rhsmodelems[j] = 0L |
| 874 |
} |
|
| 875 | 1760x |
rhsmodelems <- rhsmodelems[rhsmodelems != 0L] |
| 876 | 686x |
if (length(rhsmodelems) == 0L) rhsmodelems <- opi |
| 877 | 1760x |
lhs <- formul1$elem.text[opi - 1L] |
| 878 | 1760x |
rhs <- formul1$elem.text[nelem] |
| 879 | 1760x |
for (rmei in seq_along(rhsmodelems)) {
|
| 880 | 1796x |
rme <- rhsmodelems[rmei] |
| 881 | 1796x |
rmeprev <- if (rmei == 1L) opi else rhsmodelems[rmei - 1L] |
| 882 | 1796x |
already <- which(flat.lhs == lhs & flat.op == op & flat.block == block & |
| 883 | 1796x |
(flat.rhs == rhs | (flat.rhs == "" & (op == "~" | op == "|~") & |
| 884 | 1796x |
formul1$elem.type[nelem] == types$numliteral))) |
| 885 | 1796x |
if (length(already) == 1L) {
|
| 886 | 56x |
idx <- already |
| 887 |
} else {
|
|
| 888 | 1740x |
flat.idx <- flat.idx + 1L |
| 889 | 1740x |
idx <- flat.idx |
| 890 | 1740x |
flat.lhs[idx] <- lhs |
| 891 | 1740x |
flat.op[idx] <- op |
| 892 | 1740x |
flat.rhs[idx] <- rhs |
| 893 | 1740x |
flat.block[idx] <- block |
| 894 | 1740x |
if (formul1$elem.type[nelem] == types$numliteral) {
|
| 895 | 192x |
if (op == "~" || op == "|~") flat.rhs[idx] <- "" |
| 896 |
} |
|
| 897 |
} |
|
| 898 | 1796x |
lhsmod <- list() |
| 899 | 1796x |
if (opi > 2 && rmei == 1L) {
|
| 900 | 200x |
lhsmod <- lav_parse_modifier( |
| 901 | 200x |
formul1, |
| 902 | 200x |
TRUE, opi, modelsrc, types, modenv = modenv |
| 903 |
) |
|
| 904 |
} |
|
| 905 | 1796x |
rhsmod <- list() |
| 906 | 1796x |
if (nelem - opi > 1) {
|
| 907 | 1110x |
rhsmod <- lav_parse_modifier( |
| 908 | 1110x |
formul1, |
| 909 | 1110x |
FALSE, opi, modelsrc, types, rme, rmeprev, modenv = modenv |
| 910 |
) |
|
| 911 |
} |
|
| 912 | 1794x |
flat.fixed[idx] <- if (is.null(rhsmod$fixed)) {
|
| 913 | 1227x |
flat.fixed[idx] |
| 914 |
} else {
|
|
| 915 | 567x |
paste(rhsmod$fixed, collapse = ";") |
| 916 |
} |
|
| 917 | 1794x |
flat.start[idx] <- if (is.null(rhsmod$start)) {
|
| 918 | 1734x |
flat.start[idx] |
| 919 |
} else {
|
|
| 920 | 60x |
paste(rhsmod$start, collapse = ";") |
| 921 |
} |
|
| 922 | 1794x |
flat.label[idx] <- if (is.null(rhsmod$label)) {
|
| 923 | 1317x |
flat.label[idx] |
| 924 |
} else {
|
|
| 925 | 477x |
paste(rhsmod$label, collapse = ";") |
| 926 |
} |
|
| 927 | 1794x |
flat.lower[idx] <- if (is.null(rhsmod$lower)) {
|
| 928 | 1794x |
flat.lower[idx] |
| 929 |
} else {
|
|
| 930 | ! |
paste(rhsmod$lower, collapse = ";") |
| 931 |
} |
|
| 932 | 1794x |
flat.upper[idx] <- if (is.null(rhsmod$upper)) {
|
| 933 | 1791x |
flat.upper[idx] |
| 934 |
} else {
|
|
| 935 | 3x |
paste(rhsmod$upper, collapse = ";") |
| 936 |
} |
|
| 937 | 1794x |
flat.prior[idx] <- if (is.null(rhsmod$prior)) {
|
| 938 | 1794x |
flat.prior[idx] |
| 939 |
} else {
|
|
| 940 | ! |
paste(rhsmod$prior, collapse = ";") |
| 941 |
} |
|
| 942 | 1794x |
flat.efa[idx] <- if (is.null(lhsmod$efa)) {
|
| 943 | 1594x |
flat.efa[idx] |
| 944 |
} else {
|
|
| 945 | 200x |
paste(lhsmod$efa, collapse = ";") |
| 946 |
} |
|
| 947 | 1794x |
flat.rv[idx] <- if (is.null(rhsmod$rv)) {
|
| 948 | 1793x |
flat.rv[idx] |
| 949 |
} else {
|
|
| 950 | 1x |
paste(rhsmod$rv, collapse = ";") |
| 951 |
} |
|
| 952 | 1794x |
modnu <- c(lhsmod, rhsmod) |
| 953 | 1794x |
if (length(modnu) > 0L) { # there is a modifier here
|
| 954 | 1284x |
if (length(already) == 0) { # unknown element
|
| 955 | 1228x |
mod.idx <- mod.idx + 1L |
| 956 | 1228x |
cur.mod.idx <- mod.idx |
| 957 | 1228x |
mod[[cur.mod.idx]] <- modnu |
| 958 | 1228x |
flat.rhs.mod.idx[idx] <- cur.mod.idx |
| 959 |
} else { # known element
|
|
| 960 | 56x |
if (flat.rhs.mod.idx[idx] == 0) { # not yet modifier
|
| 961 | ! |
mod.idx <- mod.idx + 1L |
| 962 | ! |
cur.mod.idx <- mod.idx |
| 963 | ! |
mod[[cur.mod.idx]] <- modnu |
| 964 | ! |
flat.rhs.mod.idx[idx] <- cur.mod.idx |
| 965 |
} else { # use existing modifier index
|
|
| 966 | 56x |
cur.mod.idx <- flat.rhs.mod.idx[idx] |
| 967 | 56x |
overwrite <- names(modnu)[names(modnu) %in% |
| 968 | 56x |
names(mod[[cur.mod.idx]])] |
| 969 | 56x |
if (length(overwrite) > 0) {
|
| 970 | 5x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[rmeprev + 1L]) |
| 971 | 5x |
lav_msg_warn( |
| 972 | 5x |
gettextf( |
| 973 | 5x |
"modifier %s specified multiple times, overwritten", |
| 974 | 5x |
overwrite[1L] |
| 975 | 5x |
), tl[1L], |
| 976 | 5x |
footer = tl[2L] |
| 977 |
) |
|
| 978 |
} |
|
| 979 | 56x |
mod[[cur.mod.idx]] <- modifyList(mod[[cur.mod.idx]], modnu) |
| 980 |
} |
|
| 981 |
} |
|
| 982 |
} |
|
| 983 |
} |
|
| 984 |
# check for variable regressed on itself |
|
| 985 | 1758x |
if (formul1$elem.text[opi] == "~" && |
| 986 | 1758x |
formul1$elem.text[opi - 1L] == formul1$elem.text[nelem]) {
|
| 987 | 2x |
if (!grepl("^0\\.?0*$", flat.fixed[idx])) {
|
| 988 | 1x |
tl <- lav_parse_txtloc(modelsrc, formul1$elem.pos[opi]) |
| 989 | 1x |
lav_msg_stop( |
| 990 | 1x |
gettext("a variable cannot be regressed on itself"),
|
| 991 | 1x |
tl[1L], |
| 992 | 1x |
footer = tl[2L] |
| 993 |
) |
|
| 994 |
} |
|
| 995 |
} |
|
| 996 |
} |
|
| 997 |
# create flat (omit items without operator) |
|
| 998 | 79x |
filled.ones <- which(flat.op != "") |
| 999 | 79x |
flat <- list( |
| 1000 | 79x |
lhs = flat.lhs[filled.ones], |
| 1001 | 79x |
op = flat.op[filled.ones], |
| 1002 | 79x |
rhs = flat.rhs[filled.ones], |
| 1003 | 79x |
mod.idx = flat.rhs.mod.idx[filled.ones], |
| 1004 | 79x |
block = flat.block[filled.ones], |
| 1005 | 79x |
fixed = flat.fixed[filled.ones], |
| 1006 | 79x |
start = flat.start[filled.ones], |
| 1007 | 79x |
lower = flat.lower[filled.ones], |
| 1008 | 79x |
upper = flat.upper[filled.ones], |
| 1009 | 79x |
label = flat.label[filled.ones], |
| 1010 | 79x |
prior = flat.prior[filled.ones], |
| 1011 | 79x |
efa = flat.efa[filled.ones], |
| 1012 | 79x |
rv = flat.rv[filled.ones] |
| 1013 |
) |
|
| 1014 |
# change op for intercepts (for convenience only) |
|
| 1015 | 79x |
int.idx <- which(flat.op == "~" & flat.rhs == "") |
| 1016 | 79x |
if (length(int.idx) > 0L) {
|
| 1017 | 18x |
flat$op[int.idx] <- "~1" |
| 1018 |
} |
|
| 1019 |
# change op for ininstruments (for convenience only) |
|
| 1020 | 79x |
int.idx <- which(flat.op == "|~" & flat.rhs == "") |
| 1021 | 79x |
if (length(int.idx) > 0L) {
|
| 1022 | ! |
flat$op[int.idx] <- "|~1" |
| 1023 |
} |
|
| 1024 |
# if there are constraints that are simple lower or upper limits, put |
|
| 1025 |
# them in these members, add a modifier and remove constraint |
|
| 1026 | 79x |
aantal <- length(constraints) |
| 1027 | 79x |
if (aantal > 0) {
|
| 1028 | 14x |
for (j in aantal:1) {
|
| 1029 | 32x |
if (any(flat$label == constraints[[j]]$lhs) && |
| 1030 | 32x |
any(constraints[[j]]$op == c("<", ">"))) {
|
| 1031 | 5x |
rhslang <- str2lang(constraints[[j]]$rhs) |
| 1032 | 5x |
numbound <- NA_real_ |
| 1033 | 5x |
if (mode(rhslang) == "numeric") {
|
| 1034 | 5x |
numbound <- as.numeric(constraints[[j]]$rhs) |
| 1035 |
} else {
|
|
| 1036 | ! |
if (mode(rhslang) == "call") {
|
| 1037 | ! |
if (is.numeric(tryCatch(eval(rhslang), |
| 1038 | ! |
error = function(e) "error"))) {
|
| 1039 | ! |
numbound <- eval(rhslang) |
| 1040 |
} |
|
| 1041 |
} |
|
| 1042 |
} |
|
| 1043 | 5x |
if (!is.na(numbound)) {
|
| 1044 | 5x |
nrs <- which(flat$label == constraints[[j]]$lhs) |
| 1045 | 5x |
for (nr in nrs) {
|
| 1046 | 11x |
nrm <- length(mod) + 1L |
| 1047 | 11x |
if (flat$mod.idx[nr] > 0L) {
|
| 1048 | 11x |
nrm <- flat$mod.idx[nr] |
| 1049 |
} else {
|
|
| 1050 | ! |
flat$mod.idx[nr] <- nrm |
| 1051 | ! |
mod <- c(mod, list(label = constraints[[j]]$lhs)) |
| 1052 |
} |
|
| 1053 | 11x |
if (constraints[[j]]$op == "<") {
|
| 1054 | 1x |
flat$upper[nr] <- as.character(numbound) |
| 1055 | 1x |
mod[[nrm]]$upper <- numbound |
| 1056 |
} else {
|
|
| 1057 | 10x |
flat$lower[nr] <- as.character(numbound) |
| 1058 | 10x |
mod[[nrm]]$lower <- numbound |
| 1059 |
} |
|
| 1060 |
} |
|
| 1061 | 5x |
constraints <- constraints[-j] |
| 1062 |
} |
|
| 1063 |
} |
|
| 1064 |
} |
|
| 1065 |
} |
|
| 1066 |
# new in 0.6, reorder covariances here! |
|
| 1067 | 79x |
flat <- lav_partable_covariance_reorder(flat) |
| 1068 | 79x |
if (as.data.frame.) {
|
| 1069 | 61x |
flat <- as.data.frame(flat, stringsAsFactors = FALSE) |
| 1070 |
} |
|
| 1071 |
# new in 0.6-4: check for 'group' within 'level' |
|
| 1072 | 79x |
if (any(flat.op == ":")) {
|
| 1073 | 6x |
op.idx <- which(flat.op == ":") |
| 1074 | 6x |
if (length(op.idx) < 2L) {
|
| 1075 |
# only 1 block identifier? this is weird -> give warning |
|
| 1076 | 1x |
lav_msg_warn(gettext("syntax contains only a single block identifier!"))
|
| 1077 |
} else {
|
|
| 1078 | 5x |
first.block <- flat.lhs[op.idx[1L]] |
| 1079 | 5x |
second.block <- flat.lhs[op.idx[2L]] |
| 1080 | 5x |
if (first.block == "level" && second.block == "group") {
|
| 1081 | 1x |
lav_msg_stop(gettext("groups can not be nested within levels!"))
|
| 1082 |
} |
|
| 1083 |
} |
|
| 1084 |
} |
|
| 1085 |
# create output |
|
| 1086 | 78x |
attr(flat, "modifiers") <- mod |
| 1087 | 78x |
attr(flat, "constraints") <- constraints |
| 1088 | 78x |
assign(hashstring, flat, envir = lavaan_cache_env) |
| 1089 | 78x |
flat |
| 1090 |
} |
| 1 |
# loglikelihood clustered/twolevel data in the presence of missing data |
|
| 2 | ||
| 3 |
# YR: |
|
| 4 |
# - objective function: first version around March 2021 (see Psych paper) |
|
| 5 |
# - analytic gradient: first version around May 2021 |
|
| 6 | ||
| 7 | ||
| 8 |
# Mu.W, Mu.B, Sigma.W, Sigma.B are the model-implied statistics |
|
| 9 |
lav_mvnorm_cluster_missing_loglik_samplestats_2l <- function(Y1 = NULL, |
|
| 10 |
Y2 = NULL, |
|
| 11 |
Lp = NULL, |
|
| 12 |
Mp = NULL, |
|
| 13 |
Mu.W = NULL, |
|
| 14 |
Sigma.W = NULL, |
|
| 15 |
Mu.B = NULL, |
|
| 16 |
Sigma.B = NULL, |
|
| 17 |
Sinv.method = "eigen", |
|
| 18 |
log2pi = FALSE, |
|
| 19 |
loglik.x = 0, |
|
| 20 |
minus.two = TRUE) {
|
|
| 21 |
# map implied to 2l matrices |
|
| 22 | ! |
out <- lav_mvnorm_cluster_implied22l( |
| 23 | ! |
Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, |
| 24 | ! |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 25 |
) |
|
| 26 | ! |
mu.y <- out$mu.y |
| 27 | ! |
mu.z <- out$mu.z |
| 28 | ! |
sigma.w <- out$sigma.w |
| 29 | ! |
sigma.b <- out$sigma.b |
| 30 | ! |
sigma.zz <- out$sigma.zz |
| 31 | ! |
sigma.yz <- out$sigma.yz |
| 32 | ||
| 33 |
# Lp |
|
| 34 | ! |
nclusters <- Lp$nclusters[[2]] |
| 35 | ! |
between.idx <- Lp$between.idx[[2]] |
| 36 | ! |
both.idx <- Lp$both.idx[[2]] |
| 37 | ! |
cluster.idx <- Lp$cluster.idx[[2]] |
| 38 | ||
| 39 |
# sanity checks |
|
| 40 | ! |
if (any(diag(sigma.w) < 0) || any(diag(sigma.b) < 0)) {
|
| 41 | ! |
return(+Inf) |
| 42 |
} |
|
| 43 | ||
| 44 |
# check is both.idx part of sigma.b is 'too' negative; if so, return +Inf |
|
| 45 | ! |
ev <- eigen(sigma.b[both.idx, both.idx, drop = FALSE], |
| 46 | ! |
symmetric = TRUE, |
| 47 | ! |
only.values = TRUE |
| 48 | ! |
)$values |
| 49 | ! |
if (any(ev < -0.05)) {
|
| 50 | ! |
return(+Inf) |
| 51 |
} |
|
| 52 | ||
| 53 |
# cat("sigma.w = \n"); print(sigma.w)
|
|
| 54 |
# cat("sigma.b = \n"); print(sigma.b)
|
|
| 55 |
# cat("mu.y = \n"); print(mu.y)
|
|
| 56 | ||
| 57 |
# global |
|
| 58 | ! |
sigma.w.inv <- solve.default(sigma.w) |
| 59 | ! |
sigma.w.logdet <- log(det(sigma.w)) |
| 60 | ! |
sigma.b <- sigma.b[both.idx, both.idx] # only both part |
| 61 | ||
| 62 |
# y |
|
| 63 | ! |
ny <- ncol(sigma.w) |
| 64 | ! |
if (length(between.idx) > 0L) {
|
| 65 | ! |
Y1w <- Y1[, -between.idx, drop = FALSE] |
| 66 |
} else {
|
|
| 67 | ! |
Y1w <- Y1 |
| 68 |
} |
|
| 69 | ! |
Y1w.c <- t(t(Y1w) - mu.y) |
| 70 | ! |
PIJ <- matrix(0, nrow(Y1w.c), ny) |
| 71 | ||
| 72 |
# z |
|
| 73 | ! |
nz <- length(between.idx) |
| 74 | ! |
if (nz > 0L) {
|
| 75 |
# check is sigma.zz is PD; if not, return +Inf |
|
| 76 | ! |
ev <- eigen(sigma.zz, symmetric = TRUE, only.values = TRUE)$values |
| 77 | ! |
if (any(ev < sqrt(.Machine$double.eps))) {
|
| 78 | ! |
return(+Inf) |
| 79 |
} |
|
| 80 | ||
| 81 | ! |
Z <- Y2[, between.idx, drop = FALSE] |
| 82 | ! |
Z.c <- t(t(Z) - mu.z) |
| 83 | ||
| 84 | ! |
sigma.yz <- sigma.yz[both.idx, , drop = FALSE] # only both part |
| 85 | ! |
sigma.zy <- t(sigma.yz) |
| 86 | ! |
sigma.zz.inv <- solve.default(sigma.zz) |
| 87 | ! |
sigma.zz.logdet <- log(det(sigma.zz)) |
| 88 | ! |
sigma.zi.zy <- sigma.zz.inv %*% sigma.zy |
| 89 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 90 | ! |
GZ <- Z.c %*% sigma.zz.inv # for complete cases only |
| 91 |
} |
|
| 92 | ||
| 93 |
# containters per cluster |
|
| 94 | ! |
q.yy.b <- q.zy <- q.zz.b <- numeric(nclusters) |
| 95 | ! |
IBZA.j.logdet <- numeric(nclusters) |
| 96 | ! |
ALIST <- rep(list(matrix( |
| 97 | ! |
0, length(both.idx), |
| 98 | ! |
length(both.idx) |
| 99 | ! |
)), nclusters) |
| 100 | ||
| 101 |
# Z per missing pattern |
|
| 102 | ! |
if (nz > 0L) {
|
| 103 | ! |
Zp <- Mp$Zp |
| 104 | ! |
ZPAT2J <- integer(nclusters) # which sigma.b.z per cluster |
| 105 | ! |
SIGMA.B.Z <- vector("list", length = Zp$npatterns + 1L)
|
| 106 | ||
| 107 | ! |
sigma.j.zz.logdet <- q.zz.a <- 0 |
| 108 | ! |
for (p in seq_len(Zp$npatterns)) {
|
| 109 | ! |
freq <- Zp$freq[p] |
| 110 | ! |
z.na.idx <- which(!Zp$pat[p, ]) |
| 111 | ! |
j.idx <- Zp$case.idx[[p]] # cluster indices with this pattern |
| 112 | ! |
ZPAT2J[j.idx] <- p |
| 113 | ||
| 114 | ! |
if (length(z.na.idx) > 0L) {
|
| 115 | ! |
zp <- sigma.zz[-z.na.idx, -z.na.idx, drop = FALSE] |
| 116 | ! |
zp.inv <- lav_matrix_symmetric_inverse_update( |
| 117 | ! |
S.inv = sigma.zz.inv, rm.idx = z.na.idx, |
| 118 | ! |
logdet = TRUE, S.logdet = sigma.zz.logdet |
| 119 |
) |
|
| 120 | ! |
zp.logdet <- attr(zp.inv, "logdet") |
| 121 | ! |
sigma.j.zz.logdet <- sigma.j.zz.logdet + (zp.logdet * freq) |
| 122 | ||
| 123 | ! |
GZ[j.idx, -z.na.idx] <- Z.c[j.idx, -z.na.idx] %*% zp.inv |
| 124 | ||
| 125 | ! |
yziy <- (sigma.yz[, -z.na.idx, drop = FALSE] %*% zp.inv %*% |
| 126 | ! |
sigma.zy[-z.na.idx, , drop = FALSE]) |
| 127 | ! |
SIGMA.B.Z[[p]] <- (sigma.b - yziy) |
| 128 |
} else {
|
|
| 129 |
# complete case |
|
| 130 | ! |
sigma.j.zz.logdet <- |
| 131 | ! |
sigma.j.zz.logdet + (sigma.zz.logdet * freq) |
| 132 | ! |
SIGMA.B.Z[[p]] <- sigma.b.z |
| 133 |
} |
|
| 134 |
} # p |
|
| 135 | ||
| 136 |
# add empty patterns (if any) |
|
| 137 | ! |
if (length(Zp$empty.idx) > 0L) {
|
| 138 | ! |
ZPAT2J[Zp$empty.idx] <- p + 1L |
| 139 | ! |
SIGMA.B.Z[[p + 1L]] <- sigma.b |
| 140 |
} |
|
| 141 | ||
| 142 | ! |
q.zz.a <- sum(GZ * Z.c, na.rm = TRUE) |
| 143 | ! |
GZ0 <- GZ |
| 144 | ! |
GZ0[is.na(GZ0)] <- 0 |
| 145 | ! |
GJ <- GZ0 %*% sigma.zy # only both part |
| 146 |
} |
|
| 147 | ||
| 148 |
# Y per missing pattern |
|
| 149 | ! |
W.logdet <- 0 |
| 150 |
#MPi <- integer(nrow(Y1)) |
|
| 151 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 152 | ! |
freq <- Mp$freq[p] |
| 153 | ! |
na.idx <- which(!Mp$pat[p, ]) |
| 154 | ! |
j.idx <- Mp$j.idx[[p]] |
| 155 | ! |
j1.idx <- Mp$j1.idx[[p]] |
| 156 | ! |
TAB <- integer(nclusters) |
| 157 | ! |
TAB[j1.idx] <- Mp$j.freq[[p]] |
| 158 | ||
| 159 |
# compute sigma.w.inv for this pattern |
|
| 160 | ! |
if (length(na.idx) > 0L) {
|
| 161 |
#MPi[Mp$case.idx[[p]]] <- p |
|
| 162 | ! |
wp <- sigma.w[-na.idx, -na.idx, drop = FALSE] |
| 163 | ! |
wp.inv <- lav_matrix_symmetric_inverse_update( |
| 164 | ! |
S.inv = sigma.w.inv, rm.idx = na.idx, |
| 165 | ! |
logdet = TRUE, S.logdet = sigma.w.logdet |
| 166 |
) |
|
| 167 | ! |
wp.logdet <- attr(wp.inv, "logdet") |
| 168 | ! |
W.logdet <- W.logdet + (wp.logdet * freq) |
| 169 | ||
| 170 | ! |
PIJ[Mp$case.idx[[p]], -na.idx] <- |
| 171 | ! |
Y1w.c[Mp$case.idx[[p]], -na.idx] %*% wp.inv |
| 172 | ||
| 173 | ! |
A.j <- matrix(0, ny, ny) |
| 174 | ! |
A.j[-na.idx, -na.idx] <- wp.inv |
| 175 | ! |
for (j in j1.idx) {
|
| 176 | ! |
ALIST[[j]] <- ALIST[[j]] + (A.j[both.idx, both.idx] * TAB[j]) |
| 177 |
} |
|
| 178 |
# WIP[[p]][-na.idx, -na.idx] <- wp.inv |
|
| 179 |
} else {
|
|
| 180 |
# complete case |
|
| 181 | ! |
W.logdet <- W.logdet + (sigma.w.logdet * freq) |
| 182 | ! |
PIJ[Mp$case.idx[[p]], ] <- |
| 183 | ! |
Y1w.c[Mp$case.idx[[p]], ] %*% sigma.w.inv |
| 184 | ! |
for (j in j1.idx) {
|
| 185 | ! |
ALIST[[j]] <- |
| 186 | ! |
ALIST[[j]] + (sigma.w.inv[both.idx, both.idx] * TAB[j]) |
| 187 |
} |
|
| 188 |
} |
|
| 189 |
} # p |
|
| 190 | ! |
q.yy.a <- sum(PIJ * Y1w.c, na.rm = TRUE) |
| 191 | ! |
PJ <- rowsum.default(PIJ[, both.idx], cluster.idx, |
| 192 | ! |
reorder = FALSE, |
| 193 | ! |
na.rm = TRUE |
| 194 | ! |
) # only both part is needed |
| 195 | ||
| 196 |
# per cluster |
|
| 197 | ! |
both.diag.idx <- lav_matrix_diag_idx(length(both.idx)) |
| 198 | ! |
for (j in seq_len(nclusters)) {
|
| 199 |
# we only need the 'both.idx' part of A.j, sigma.b.z, p.j, g.j ,... |
|
| 200 | ! |
A.j <- ALIST[[j]] |
| 201 | ! |
p.j <- PJ[j, ] |
| 202 | ! |
if (nz > 0L) {
|
| 203 | ! |
sigma.b.z <- SIGMA.B.Z[[ZPAT2J[j]]] |
| 204 |
} else {
|
|
| 205 | ! |
sigma.b.z <- sigma.b |
| 206 |
} |
|
| 207 | ! |
IBZA.j <- sigma.b.z %*% A.j |
| 208 | ! |
IBZA.j[both.diag.idx] <- IBZA.j[both.diag.idx] + 1 |
| 209 |
# logdet IBZA.j |
|
| 210 | ! |
tmp <- determinant.matrix(IBZA.j, logarithm = TRUE) |
| 211 | ! |
IBZA.j.logdet[j] <- tmp$modulus * tmp$sign |
| 212 |
# IBZA.j.inv.BZ.p |
|
| 213 | ! |
IBZA.j.inv.BZ.p <- solve.default(IBZA.j, drop(sigma.b.z %*% p.j)) |
| 214 | ! |
q.yy.b[j] <- sum(p.j * IBZA.j.inv.BZ.p) |
| 215 | ||
| 216 | ! |
if (nz > 0L) {
|
| 217 | ! |
g.j <- GJ[j, ] |
| 218 | ! |
IBZA.j.inv.g <- solve.default(IBZA.j, g.j) |
| 219 | ! |
A.IBZA.j.inv.g <- A.j %*% IBZA.j.inv.g |
| 220 | ||
| 221 | ! |
q.zz.b[j] <- sum(g.j * A.IBZA.j.inv.g) |
| 222 | ! |
q.zy[j] <- -sum(p.j * IBZA.j.inv.g) |
| 223 |
} |
|
| 224 |
} |
|
| 225 | ||
| 226 | ||
| 227 | ! |
if (nz > 0L) {
|
| 228 | ! |
P <- Mp$nel + Zp$nel |
| 229 | ! |
DIST <- (q.yy.a - sum(q.yy.b)) + 2 * sum(q.zy) + (q.zz.a + sum(q.zz.b)) |
| 230 | ! |
LOGDET <- W.logdet + sum(IBZA.j.logdet) + sigma.j.zz.logdet |
| 231 |
} else {
|
|
| 232 | ! |
P <- Mp$nel |
| 233 | ! |
DIST <- (q.yy.a - sum(q.yy.b)) |
| 234 | ! |
LOGDET <- W.logdet + sum(IBZA.j.logdet) |
| 235 |
} |
|
| 236 | ||
| 237 |
# loglik? |
|
| 238 | ! |
if (log2pi && !minus.two) {
|
| 239 | ! |
LOG.2PI <- log(2 * pi) |
| 240 | ! |
loglik <- -(P * LOG.2PI + LOGDET + DIST) / 2 |
| 241 |
} else {
|
|
| 242 | ! |
loglik <- DIST + LOGDET |
| 243 |
} |
|
| 244 | ||
| 245 |
# loglik.x (only if loglik is requested) |
|
| 246 | ! |
if (length(unlist(Lp$ov.x.idx)) > 0L && log2pi && !minus.two) {
|
| 247 | ! |
loglik <- loglik - loglik.x |
| 248 |
} |
|
| 249 | ||
| 250 | ! |
loglik |
| 251 |
} |
|
| 252 | ||
| 253 |
# Mu.W, Mu.B, Sigma.W, Sigma.B are the model-implied statistics |
|
| 254 |
lav_mvnorm_cluster_missing_dlogl_2l_samplestats <- function( |
|
| 255 |
Y1 = NULL, |
|
| 256 |
Y2 = NULL, |
|
| 257 |
Lp = NULL, |
|
| 258 |
Mp = NULL, |
|
| 259 |
Mu.W = NULL, |
|
| 260 |
Sigma.W = NULL, |
|
| 261 |
Mu.B = NULL, |
|
| 262 |
Sigma.B = NULL, |
|
| 263 |
Sinv.method = "eigen", |
|
| 264 |
return.list = FALSE) {
|
|
| 265 |
# map implied to 2l matrices |
|
| 266 | ! |
out <- lav_mvnorm_cluster_implied22l( |
| 267 | ! |
Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, |
| 268 | ! |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 269 |
) |
|
| 270 | ! |
mu.y <- out$mu.y |
| 271 | ! |
mu.z <- out$mu.z |
| 272 | ! |
sigma.w <- out$sigma.w |
| 273 | ! |
sigma.b <- out$sigma.b |
| 274 | ! |
sigma.zz <- out$sigma.zz |
| 275 | ! |
sigma.yz <- out$sigma.yz |
| 276 | ||
| 277 |
# containers for dx |
|
| 278 | ! |
dx.mu.y <- numeric(length(mu.y)) |
| 279 | ! |
dx.mu.z <- numeric(length(mu.z)) |
| 280 | ! |
dx.sigma.zz <- matrix(0, nrow(sigma.zz), ncol(sigma.zz)) |
| 281 | ! |
dx.sigma.yz <- matrix(0, nrow(sigma.yz), ncol(sigma.yz)) |
| 282 | ! |
dx.sigma.b <- matrix(0, nrow(sigma.b), ncol(sigma.b)) |
| 283 | ! |
dx.sigma.w <- matrix(0, nrow(sigma.w), ncol(sigma.w)) |
| 284 | ||
| 285 |
# Lp |
|
| 286 | ! |
nclusters <- Lp$nclusters[[2]] |
| 287 | ! |
between.idx <- Lp$between.idx[[2]] |
| 288 | ! |
cluster.idx <- Lp$cluster.idx[[2]] |
| 289 | ! |
both.idx <- Lp$both.idx[[2]] |
| 290 | ||
| 291 |
# sigma.w |
|
| 292 | ! |
sigma.w.inv <- solve.default(sigma.w) |
| 293 | ! |
sigma.b <- sigma.b[both.idx, both.idx] # only both part |
| 294 | ||
| 295 |
# y |
|
| 296 | ! |
ny <- ncol(sigma.w) |
| 297 | ! |
if (length(between.idx) > 0L) {
|
| 298 | ! |
Y1w <- Y1[, -between.idx, drop = FALSE] |
| 299 |
} else {
|
|
| 300 | ! |
Y1w <- Y1 |
| 301 |
} |
|
| 302 | ! |
Y1w.c <- t(t(Y1w) - mu.y) |
| 303 | ! |
PIJ <- matrix(0, nrow(Y1w.c), ny) |
| 304 | ||
| 305 |
# z |
|
| 306 | ! |
nz <- length(between.idx) |
| 307 | ! |
if (nz > 0L) {
|
| 308 | ! |
Z <- Y2[, between.idx, drop = FALSE] |
| 309 | ! |
Z.c <- t(t(Z) - mu.z) |
| 310 | ! |
sigma.yz <- sigma.yz[both.idx, , drop = FALSE] # only both part |
| 311 | ! |
sigma.zy <- t(sigma.yz) |
| 312 | ! |
sigma.zz.inv <- solve.default(sigma.zz) |
| 313 | ! |
sigma.zz.logdet <- log(det(sigma.zz)) |
| 314 | ! |
sigma.zi.zy <- sigma.zz.inv %*% sigma.zy |
| 315 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 316 | ! |
GZ <- Z.c %*% sigma.zz.inv # for complete cases only |
| 317 |
} |
|
| 318 | ||
| 319 |
# containters per cluster |
|
| 320 |
# ALIST <- rep(list(matrix(0, length(both.idx), |
|
| 321 |
# length(both.idx))), nclusters) |
|
| 322 | ! |
ALIST <- rep(list(matrix(0, ny, ny)), nclusters) |
| 323 | ||
| 324 |
# Z per missing pattern |
|
| 325 | ! |
if (nz > 0L) {
|
| 326 | ! |
Zp <- Mp$Zp |
| 327 | ! |
ZPAT2J <- integer(nclusters) # which pattern per cluster |
| 328 | ! |
SIGMA.B.Z <- vector("list", length = Zp$npatterns + 1L) # +1 for empty
|
| 329 | ! |
ZIZY <- rep(list(matrix( |
| 330 | ! |
0, nrow(sigma.zy), |
| 331 | ! |
ncol(sigma.zy) |
| 332 | ! |
)), Zp$npatterns + 1L) |
| 333 | ! |
ZIP <- rep(list(matrix( |
| 334 | ! |
0, nrow(sigma.zz), |
| 335 | ! |
ncol(sigma.zz) |
| 336 | ! |
)), Zp$npatterns + 1L) |
| 337 | ! |
for (p in seq_len(Zp$npatterns)) {
|
| 338 | ! |
freq <- Zp$freq[p] |
| 339 | ! |
z.na.idx <- which(!Zp$pat[p, ]) |
| 340 | ! |
j.idx <- Zp$case.idx[[p]] # cluster indices with this pattern |
| 341 | ! |
ZPAT2J[j.idx] <- p |
| 342 | ||
| 343 | ! |
if (length(z.na.idx) > 0L) {
|
| 344 | ! |
zp <- sigma.zz[-z.na.idx, -z.na.idx, drop = FALSE] |
| 345 | ! |
zp.inv <- lav_matrix_symmetric_inverse_update( |
| 346 | ! |
S.inv = sigma.zz.inv, rm.idx = z.na.idx, |
| 347 | ! |
logdet = FALSE |
| 348 |
) |
|
| 349 | ! |
ZIP[[p]][-z.na.idx, -z.na.idx] <- zp.inv |
| 350 | ! |
GZ[j.idx, -z.na.idx] <- Z.c[j.idx, -z.na.idx] %*% zp.inv |
| 351 | ! |
Z.G.ZY <- zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE] |
| 352 | ! |
ZIZY[[p]][-z.na.idx, ] <- |
| 353 | ! |
zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE] |
| 354 | ! |
yziy <- sigma.yz[, -z.na.idx, drop = FALSE] %*% Z.G.ZY |
| 355 | ! |
SIGMA.B.Z[[p]] <- (sigma.b - yziy) |
| 356 |
} else {
|
|
| 357 |
# complete case |
|
| 358 | ! |
ZIZY[[p]] <- sigma.zi.zy |
| 359 | ! |
ZIP[[p]] <- sigma.zz.inv |
| 360 | ! |
SIGMA.B.Z[[p]] <- sigma.b.z |
| 361 |
} |
|
| 362 |
} # p |
|
| 363 | ||
| 364 |
# add empty patterns (if any) |
|
| 365 | ! |
if (length(Zp$empty.idx) > 0L) {
|
| 366 | ! |
ZPAT2J[Zp$empty.idx] <- p + 1L |
| 367 | ! |
SIGMA.B.Z[[p + 1L]] <- sigma.b |
| 368 |
} |
|
| 369 | ||
| 370 | ! |
GZ[is.na(GZ)] <- 0 |
| 371 | ! |
GJ <- GZ %*% sigma.zy |
| 372 |
} |
|
| 373 | ||
| 374 |
# Y per missing pattern |
|
| 375 | ! |
WIP <- rep(list(matrix(0, ny, ny)), Mp$npatterns) |
| 376 | ! |
MPi <- integer(nrow(Y1)) |
| 377 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 378 | ! |
freq <- Mp$freq[p] |
| 379 | ! |
na.idx <- which(!Mp$pat[p, ]) |
| 380 | ! |
j.idx <- Mp$j.idx[[p]] |
| 381 | ! |
j1.idx <- Mp$j1.idx[[p]] |
| 382 | ! |
TAB <- integer(nclusters) |
| 383 | ! |
TAB[j1.idx] <- Mp$j.freq[[p]] |
| 384 | ||
| 385 | ! |
if (length(na.idx) > 0L) {
|
| 386 | ! |
MPi[Mp$case.idx[[p]]] <- p |
| 387 | ! |
wp.inv <- lav_matrix_symmetric_inverse_update( |
| 388 | ! |
S.inv = sigma.w.inv, rm.idx = na.idx, |
| 389 | ! |
logdet = FALSE |
| 390 |
) |
|
| 391 | ! |
WIP[[p]][-na.idx, -na.idx] <- wp.inv |
| 392 | ! |
PIJ[Mp$case.idx[[p]], -na.idx] <- |
| 393 | ! |
Y1w.c[Mp$case.idx[[p]], -na.idx] %*% wp.inv |
| 394 | ||
| 395 | ! |
for (j in j1.idx) {
|
| 396 | ! |
ALIST[[j]] <- |
| 397 |
# ALIST[[j]] + (WIP[[p]][both.idx, both.idx] * TAB[j]) |
|
| 398 | ! |
ALIST[[j]] + (WIP[[p]] * TAB[j]) |
| 399 |
} |
|
| 400 |
} else {
|
|
| 401 |
# complete case |
|
| 402 | ! |
PIJ[Mp$case.idx[[p]], ] <- |
| 403 | ! |
Y1w.c[Mp$case.idx[[p]], ] %*% sigma.w.inv |
| 404 | ! |
WIP[[p]] <- sigma.w.inv |
| 405 | ! |
for (j in j1.idx) {
|
| 406 | ! |
ALIST[[j]] <- |
| 407 |
# ALIST[[j]] + (sigma.w.inv[both.idx, both.idx] * TAB[j]) |
|
| 408 | ! |
ALIST[[j]] + (sigma.w.inv * TAB[j]) |
| 409 |
} |
|
| 410 |
} |
|
| 411 |
} # p |
|
| 412 | ! |
PJ <- rowsum.default(PIJ[, , drop = FALSE], |
| 413 | ! |
cluster.idx, |
| 414 | ! |
reorder = FALSE, na.rm = TRUE |
| 415 |
) |
|
| 416 | ||
| 417 |
# per cluster |
|
| 418 | ! |
both.diag.idx <- lav_matrix_diag_idx(length(both.idx)) |
| 419 | ! |
for (j in seq_len(nclusters)) {
|
| 420 | ! |
A.j.full <- ALIST[[j]] |
| 421 | ! |
A.j <- A.j.full[both.idx, both.idx, drop = FALSE] |
| 422 | ! |
p.j <- as.matrix(PJ[j, ]) |
| 423 | ! |
pb.j <- as.matrix(PJ[j, both.idx]) # only both.idx part |
| 424 | ! |
if (nz > 0L) {
|
| 425 | ! |
sigma.b.z <- SIGMA.B.Z[[ZPAT2J[j]]] |
| 426 |
} else {
|
|
| 427 | ! |
sigma.b.z <- sigma.b |
| 428 |
} |
|
| 429 | ||
| 430 | ! |
IBZA.j <- sigma.b.z %*% A.j |
| 431 | ! |
IBZA.j[both.diag.idx] <- IBZA.j[both.diag.idx] + 1 |
| 432 | ||
| 433 | ! |
IBZA.j.inv.BZ <- solve.default(IBZA.j, sigma.b.z) |
| 434 | ! |
IBZA.j.inv.BZ.p <- IBZA.j.inv.BZ %*% pb.j |
| 435 | ! |
A.IBZA.j.inv.BZ <- A.j %*% IBZA.j.inv.BZ |
| 436 | ! |
A.IBZA.j.inv.BZ.p <- A.IBZA.j.inv.BZ %*% pb.j |
| 437 | ||
| 438 | ! |
IBZA.j.inv <- solve.default(IBZA.j) |
| 439 | ! |
A.IBZA.j.inv <- A.j %*% IBZA.j.inv |
| 440 | ! |
p.IBZA.j.inv <- t(crossprod(pb.j, IBZA.j.inv)) |
| 441 | ||
| 442 |
# only if we have between-only variables |
|
| 443 | ! |
if (nz > 0L) {
|
| 444 | ! |
g.j <- as.matrix(GJ[j, ]) |
| 445 | ! |
zij <- as.matrix(GZ[j, ]) |
| 446 | ! |
zizy <- ZIZY[[ZPAT2J[j]]] |
| 447 | ! |
zip <- ZIP[[ZPAT2J[j]]] |
| 448 | ||
| 449 | ! |
IBZA.j.inv.zizy <- solve.default(IBZA.j, t(zizy)) |
| 450 | ! |
IBZA.j.inv.g <- IBZA.j.inv %*% g.j |
| 451 | ! |
IBZA.j.inv.p <- IBZA.j.inv %*% pb.j |
| 452 | ! |
A.IBZA.j.inv.g <- A.j %*% IBZA.j.inv.g |
| 453 | ! |
A.IBZA.j.inv.zizy <- A.j %*% IBZA.j.inv.zizy |
| 454 | ! |
zizy.A.IBZA.j.inv.g <- zizy %*% A.IBZA.j.inv.g |
| 455 | ! |
p.IBZA.j.inv.zizy <- crossprod(pb.j, IBZA.j.inv.zizy) |
| 456 | ! |
ggbzpp <- 2 * A.IBZA.j.inv.g + A.IBZA.j.inv.BZ.p - pb.j |
| 457 | ! |
ZIJzizyp <- (2 * zij - zizy %*% pb.j) |
| 458 | ||
| 459 |
########### |
|
| 460 |
# dx.mu.z # |
|
| 461 |
########### |
|
| 462 | ! |
tmp <- 2 * (t(p.IBZA.j.inv.zizy) - zij - zizy.A.IBZA.j.inv.g) |
| 463 | ! |
dx.mu.z <- dx.mu.z + drop(tmp) |
| 464 | ||
| 465 |
############### |
|
| 466 |
# dx.sigma.zz # |
|
| 467 |
############### |
|
| 468 | ! |
tmp1 <- (zip + zizy %*% A.IBZA.j.inv.zizy # logdet |
| 469 | ! |
- tcrossprod(zij) # ZA |
| 470 | ! |
- tcrossprod(zizy.A.IBZA.j.inv.g)) # ZB-1 |
| 471 | ||
| 472 | ! |
d <- (t((2 * zizy.A.IBZA.j.inv.g + zizy %*% A.IBZA.j.inv.BZ.p) |
| 473 | ! |
%*% p.IBZA.j.inv.zizy) |
| 474 | ! |
+ ZIJzizyp %*% p.IBZA.j.inv.zizy |
| 475 | ! |
- 2 * tcrossprod(zizy.A.IBZA.j.inv.g, zij)) |
| 476 | ! |
tmp2 <- (d + t(d)) / 2 |
| 477 | ! |
tmp <- tmp1 + tmp2 |
| 478 |
# symmetry correction |
|
| 479 | ! |
ZZ <- 2 * tmp |
| 480 | ! |
diag(ZZ) <- diag(tmp) |
| 481 | ! |
dx.sigma.zz <- dx.sigma.zz + ZZ |
| 482 | ||
| 483 |
############### |
|
| 484 |
# dx.sigma.yz # |
|
| 485 |
############### |
|
| 486 | ! |
t0 <- -2 * A.IBZA.j.inv.zizy |
| 487 | ||
| 488 | ! |
t1 <- (-2 * tcrossprod(p.IBZA.j.inv, g.j) |
| 489 | ! |
- 1 * tcrossprod(p.IBZA.j.inv, sigma.b.z %*% pb.j) |
| 490 | ! |
+ 2 * tcrossprod(A.IBZA.j.inv.g, g.j)) %*% A.IBZA.j.inv.zizy |
| 491 | ! |
t2 <- -ggbzpp %*% p.IBZA.j.inv.zizy |
| 492 | ! |
t3 <- -tcrossprod(p.IBZA.j.inv, ZIJzizyp) |
| 493 | ! |
t4 <- 2 * tcrossprod(A.IBZA.j.inv.g, zij) |
| 494 | ! |
tmp <- t0 + t1 + t2 + t3 + t4 |
| 495 | ! |
dx.sigma.yz[both.idx, ] <- dx.sigma.yz[both.idx, , drop = FALSE] + tmp |
| 496 | ||
| 497 |
############## |
|
| 498 |
# dx.sigma.b # |
|
| 499 |
############## |
|
| 500 | ! |
c <- tcrossprod(ggbzpp, p.IBZA.j.inv) |
| 501 | ! |
tmp <- t(A.IBZA.j.inv) - tcrossprod(A.IBZA.j.inv.g) + (c + t(c)) / 2 |
| 502 |
# symmetry correction |
|
| 503 | ! |
ZZ <- 2 * tmp |
| 504 | ! |
diag(ZZ) <- diag(tmp) |
| 505 | ! |
dx.sigma.b[both.idx, both.idx] <- |
| 506 | ! |
dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ |
| 507 | ||
| 508 |
# for dx.sigma.w |
|
| 509 | ! |
PART1.b <- -1 * (IBZA.j.inv.g %*% |
| 510 | ! |
(2 * t(IBZA.j.inv.BZ.p) + t(g.j) - |
| 511 | ! |
t(g.j) %*% A.IBZA.j.inv.BZ) |
| 512 | ! |
+ IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p)) |
| 513 | ! |
PART2.b <- 2 * (IBZA.j.inv.g + IBZA.j.inv.BZ.p) # vector |
| 514 |
} else {
|
|
| 515 |
############## |
|
| 516 |
# dx.sigma.b # |
|
| 517 |
############## |
|
| 518 | ! |
bzpp <- A.IBZA.j.inv.BZ.p - pb.j |
| 519 | ! |
c <- tcrossprod(bzpp, p.IBZA.j.inv) |
| 520 | ! |
tmp <- t(A.IBZA.j.inv) + (c + t(c)) / 2 |
| 521 |
# symmetry correction |
|
| 522 | ! |
ZZ <- 2 * tmp |
| 523 | ! |
diag(ZZ) <- diag(tmp) |
| 524 | ! |
dx.sigma.b[both.idx, both.idx] <- |
| 525 | ! |
dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ |
| 526 | ||
| 527 | ! |
PART1.b <- -1 * (IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p)) |
| 528 | ! |
PART2.b <- 2 * IBZA.j.inv.BZ.p # vector |
| 529 |
} |
|
| 530 | ||
| 531 |
############## |
|
| 532 |
# dx.sigma.w # |
|
| 533 |
############## |
|
| 534 | ||
| 535 | ! |
PART1 <- matrix(0, ny, ny) |
| 536 | ! |
PART1[both.idx, both.idx] <- PART1.b |
| 537 | ||
| 538 | ! |
PART2 <- matrix(0, ny, 1L) |
| 539 | ! |
PART2[both.idx, 1L] <- PART2.b |
| 540 | ||
| 541 | ! |
ij.index <- which(cluster.idx == j) |
| 542 | ! |
pij <- PIJ[ij.index, , drop = FALSE] |
| 543 | ||
| 544 | ! |
which.compl <- which(MPi[ij.index] == 0L) |
| 545 | ! |
which.incompl <- which(MPi[ij.index] != 0L) |
| 546 | ||
| 547 | ! |
AP2 <- rep(list(sigma.w.inv %*% PART2), length(ij.index)) |
| 548 | ! |
AP1A.a <- AP1A.b <- matrix(0, ny, ny) |
| 549 |
# A.j.full <- matrix(0, ny, ny) |
|
| 550 | ! |
if (length(which.compl) > 0L) {
|
| 551 | ! |
tmp <- (sigma.w.inv %*% PART1 %*% sigma.w.inv) |
| 552 | ! |
AP1A.a <- tmp * length(which.compl) |
| 553 |
# A.j.full <- A.j.full + sigma.w.inv * length(which.compl) |
|
| 554 |
} |
|
| 555 | ! |
if (length(which.incompl) > 0L) {
|
| 556 | ! |
p.idx <- MPi[ij.index][which.incompl] |
| 557 | ! |
tmp <- lapply(WIP[p.idx], function(x) {
|
| 558 | ! |
x %*% PART1 %*% x |
| 559 |
}) |
|
| 560 | ! |
AP1A.b <- Reduce("+", tmp)
|
| 561 | ! |
AP2[which.incompl] <- |
| 562 | ! |
lapply(WIP[p.idx], function(x) {
|
| 563 | ! |
x %*% PART2 |
| 564 |
}) |
|
| 565 |
# A.j.full <- A.j.full + Reduce("+", WIP[ p.idx ])
|
|
| 566 |
} |
|
| 567 | ! |
t1 <- AP1A.a + AP1A.b |
| 568 | ! |
t2 <- (do.call("cbind", AP2) - t(pij)) %*% pij
|
| 569 | ||
| 570 | ! |
AA.wj <- t1 + t2 |
| 571 | ||
| 572 | ! |
tmp <- A.j.full + (AA.wj + t(AA.wj)) / 2 |
| 573 |
# symmetry correction |
|
| 574 | ! |
ZZ <- 2 * tmp |
| 575 | ! |
diag(ZZ) <- diag(tmp) |
| 576 | ! |
dx.sigma.w <- dx.sigma.w + ZZ |
| 577 | ||
| 578 |
########### |
|
| 579 |
# dx.mu.y # |
|
| 580 |
########### |
|
| 581 | ! |
tmp <- numeric(ny) |
| 582 | ! |
if (nz > 0L) {
|
| 583 | ! |
tmp[both.idx] <- IBZA.j.inv.g + IBZA.j.inv.BZ.p |
| 584 |
} else {
|
|
| 585 | ! |
tmp[both.idx] <- IBZA.j.inv.BZ.p |
| 586 |
} |
|
| 587 | ! |
gbzpp <- A.j.full %*% tmp - p.j |
| 588 | ! |
dx.mu.y <- dx.mu.y + drop(2 * gbzpp) |
| 589 |
} # j |
|
| 590 | ||
| 591 |
# rearrange |
|
| 592 | ! |
dout <- lav_mvnorm_cluster_2l2implied( |
| 593 | ! |
Lp = Lp, |
| 594 | ! |
sigma.w = dx.sigma.w, sigma.b = dx.sigma.b, |
| 595 | ! |
sigma.yz = dx.sigma.yz, sigma.zz = dx.sigma.zz, |
| 596 | ! |
mu.y = dx.mu.y, mu.z = dx.mu.z |
| 597 |
) |
|
| 598 | ||
| 599 | ! |
if (return.list) {
|
| 600 | ! |
out <- dout |
| 601 |
} else {
|
|
| 602 | ! |
out <- c( |
| 603 | ! |
dout$Mu.W, lav_matrix_vech(dout$Sigma.W), |
| 604 | ! |
dout$Mu.B, lav_matrix_vech(dout$Sigma.B) |
| 605 |
) |
|
| 606 |
} |
|
| 607 | ||
| 608 | ! |
out |
| 609 |
} |
|
| 610 | ||
| 611 |
# cluster-wise scores -2*logl wrt Mu.W, Mu.B, Sigma.W, Sigma.B |
|
| 612 |
lav_mvnorm_cluster_missing_scores_2l <- function( |
|
| 613 |
Y1 = NULL, |
|
| 614 |
Y2 = NULL, |
|
| 615 |
Lp = NULL, |
|
| 616 |
Mp = NULL, |
|
| 617 |
Mu.W = NULL, |
|
| 618 |
Sigma.W = NULL, |
|
| 619 |
Mu.B = NULL, |
|
| 620 |
Sigma.B = NULL, |
|
| 621 |
Sinv.method = "eigen") {
|
|
| 622 |
# map implied to 2l matrices |
|
| 623 | ! |
out <- lav_mvnorm_cluster_implied22l( |
| 624 | ! |
Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, |
| 625 | ! |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 626 |
) |
|
| 627 | ! |
mu.y <- out$mu.y |
| 628 | ! |
mu.z <- out$mu.z |
| 629 | ! |
sigma.w <- out$sigma.w |
| 630 | ! |
sigma.b <- out$sigma.b |
| 631 | ! |
sigma.zz <- out$sigma.zz |
| 632 | ! |
sigma.yz <- out$sigma.yz |
| 633 | ||
| 634 |
# Lp |
|
| 635 | ! |
nclusters <- Lp$nclusters[[2]] |
| 636 | ! |
between.idx <- Lp$between.idx[[2]] |
| 637 | ! |
cluster.idx <- Lp$cluster.idx[[2]] |
| 638 | ! |
both.idx <- Lp$both.idx[[2]] |
| 639 | ||
| 640 |
# sigma.w |
|
| 641 | ! |
sigma.w.inv <- solve.default(sigma.w) |
| 642 | ! |
sigma.b <- sigma.b[both.idx, both.idx] # only both part |
| 643 | ||
| 644 |
# y |
|
| 645 | ! |
ny <- ncol(sigma.w) |
| 646 | ! |
if (length(between.idx) > 0L) {
|
| 647 | ! |
Y1w <- Y1[, -between.idx, drop = FALSE] |
| 648 |
} else {
|
|
| 649 | ! |
Y1w <- Y1 |
| 650 |
} |
|
| 651 | ! |
Y1w.c <- t(t(Y1w) - mu.y) |
| 652 | ! |
PIJ <- matrix(0, nrow(Y1w.c), ny) |
| 653 | ||
| 654 |
# z |
|
| 655 | ! |
nz <- length(between.idx) |
| 656 | ! |
if (nz > 0L) {
|
| 657 | ! |
Z <- Y2[, between.idx, drop = FALSE] |
| 658 | ! |
Z.c <- t(t(Z) - mu.z) |
| 659 | ! |
sigma.yz <- sigma.yz[both.idx, , drop = FALSE] # only both part |
| 660 | ! |
sigma.zy <- t(sigma.yz) |
| 661 | ! |
sigma.zz.inv <- solve.default(sigma.zz) |
| 662 | ! |
sigma.zz.logdet <- log(det(sigma.zz)) |
| 663 | ! |
sigma.zi.zy <- sigma.zz.inv %*% sigma.zy |
| 664 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 665 | ! |
GZ <- Z.c %*% sigma.zz.inv # for complete cases only |
| 666 |
} |
|
| 667 | ||
| 668 |
# containters per cluster |
|
| 669 |
# ALIST <- rep(list(matrix(0, length(both.idx), |
|
| 670 |
# length(both.idx))), nclusters) |
|
| 671 | ! |
ALIST <- rep(list(matrix(0, ny, ny)), nclusters) |
| 672 | ||
| 673 |
# both level-1 and level-2 |
|
| 674 | ! |
G.muy <- matrix(0, nclusters, length(mu.y)) |
| 675 | ! |
G.Sigma.w <- matrix(0, nclusters, length(lav_matrix_vech(sigma.w))) |
| 676 | ! |
G.Sigma.b <- matrix(0, nclusters, length(lav_matrix_vech(out$sigma.b))) |
| 677 | ! |
G.muz <- matrix(0, nclusters, length(mu.z)) |
| 678 | ! |
G.Sigma.zz <- matrix(0, nclusters, length(lav_matrix_vech(sigma.zz))) |
| 679 | ! |
G.Sigma.yz <- matrix(0, nclusters, length(lav_matrix_vec(out$sigma.yz))) |
| 680 | ||
| 681 |
# Z per missing pattern |
|
| 682 | ! |
if (nz > 0L) {
|
| 683 | ! |
Zp <- Mp$Zp |
| 684 | ! |
ZPAT2J <- integer(nclusters) # which pattern per cluster |
| 685 | ! |
SIGMA.B.Z <- vector("list", length = Zp$npatterns + 1L) # +1 for empty
|
| 686 | ! |
ZIZY <- rep(list(matrix( |
| 687 | ! |
0, nrow(sigma.zy), |
| 688 | ! |
ncol(sigma.zy) |
| 689 | ! |
)), Zp$npatterns + 1L) |
| 690 | ! |
ZIP <- rep(list(matrix( |
| 691 | ! |
0, nrow(sigma.zz), |
| 692 | ! |
ncol(sigma.zz) |
| 693 | ! |
)), Zp$npatterns + 1L) |
| 694 | ! |
for (p in seq_len(Zp$npatterns)) {
|
| 695 | ! |
freq <- Zp$freq[p] |
| 696 | ! |
z.na.idx <- which(!Zp$pat[p, ]) |
| 697 | ! |
j.idx <- Zp$case.idx[[p]] # cluster indices with this pattern |
| 698 | ! |
ZPAT2J[j.idx] <- p |
| 699 | ||
| 700 | ! |
if (length(z.na.idx) > 0L) {
|
| 701 | ! |
zp <- sigma.zz[-z.na.idx, -z.na.idx, drop = FALSE] |
| 702 | ! |
zp.inv <- lav_matrix_symmetric_inverse_update( |
| 703 | ! |
S.inv = sigma.zz.inv, rm.idx = z.na.idx, |
| 704 | ! |
logdet = FALSE |
| 705 |
) |
|
| 706 | ! |
ZIP[[p]][-z.na.idx, -z.na.idx] <- zp.inv |
| 707 | ! |
GZ[j.idx, -z.na.idx] <- Z.c[j.idx, -z.na.idx] %*% zp.inv |
| 708 | ! |
Z.G.ZY <- zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE] |
| 709 | ! |
ZIZY[[p]][-z.na.idx, ] <- |
| 710 | ! |
zp.inv %*% sigma.zy[-z.na.idx, , drop = FALSE] |
| 711 | ! |
yziy <- sigma.yz[, -z.na.idx, drop = FALSE] %*% Z.G.ZY |
| 712 | ! |
SIGMA.B.Z[[p]] <- (sigma.b - yziy) |
| 713 |
} else {
|
|
| 714 |
# complete case |
|
| 715 | ! |
ZIZY[[p]] <- sigma.zi.zy |
| 716 | ! |
ZIP[[p]] <- sigma.zz.inv |
| 717 | ! |
SIGMA.B.Z[[p]] <- sigma.b.z |
| 718 |
} |
|
| 719 |
} # p |
|
| 720 | ||
| 721 |
# add empty patterns (if any) |
|
| 722 | ! |
if (length(Zp$empty.idx) > 0L) {
|
| 723 | ! |
ZPAT2J[Zp$empty.idx] <- p + 1L |
| 724 | ! |
SIGMA.B.Z[[p + 1L]] <- sigma.b |
| 725 |
} |
|
| 726 | ||
| 727 | ! |
GZ[is.na(GZ)] <- 0 |
| 728 | ! |
GJ <- GZ %*% sigma.zy |
| 729 |
} |
|
| 730 | ||
| 731 |
# Y per missing pattern |
|
| 732 | ! |
WIP <- rep(list(matrix(0, ny, ny)), Mp$npatterns) |
| 733 | ! |
MPi <- integer(nrow(Y1)) |
| 734 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 735 | ! |
freq <- Mp$freq[p] |
| 736 | ! |
na.idx <- which(!Mp$pat[p, ]) |
| 737 | ! |
j.idx <- Mp$j.idx[[p]] |
| 738 | ! |
j1.idx <- Mp$j1.idx[[p]] |
| 739 | ! |
TAB <- integer(nclusters) |
| 740 | ! |
TAB[j1.idx] <- Mp$j.freq[[p]] |
| 741 | ||
| 742 | ! |
if (length(na.idx) > 0L) {
|
| 743 | ! |
MPi[Mp$case.idx[[p]]] <- p |
| 744 | ! |
wp.inv <- lav_matrix_symmetric_inverse_update( |
| 745 | ! |
S.inv = sigma.w.inv, rm.idx = na.idx, |
| 746 | ! |
logdet = FALSE |
| 747 |
) |
|
| 748 | ! |
WIP[[p]][-na.idx, -na.idx] <- wp.inv |
| 749 | ! |
PIJ[Mp$case.idx[[p]], -na.idx] <- |
| 750 | ! |
Y1w.c[Mp$case.idx[[p]], -na.idx] %*% wp.inv |
| 751 | ||
| 752 | ! |
for (j in j1.idx) {
|
| 753 | ! |
ALIST[[j]] <- |
| 754 |
# ALIST[[j]] + (WIP[[p]][both.idx, both.idx] * TAB[j]) |
|
| 755 | ! |
ALIST[[j]] + (WIP[[p]] * TAB[j]) |
| 756 |
} |
|
| 757 |
} else {
|
|
| 758 |
# complete case |
|
| 759 | ! |
PIJ[Mp$case.idx[[p]], ] <- |
| 760 | ! |
Y1w.c[Mp$case.idx[[p]], ] %*% sigma.w.inv |
| 761 | ! |
WIP[[p]] <- sigma.w.inv |
| 762 | ! |
for (j in j1.idx) {
|
| 763 | ! |
ALIST[[j]] <- |
| 764 |
# ALIST[[j]] + (sigma.w.inv[both.idx, both.idx] * TAB[j]) |
|
| 765 | ! |
ALIST[[j]] + (sigma.w.inv * TAB[j]) |
| 766 |
} |
|
| 767 |
} |
|
| 768 |
} # p |
|
| 769 | ||
| 770 | ! |
PJ <- rowsum.default(PIJ[, , drop = FALSE], |
| 771 | ! |
cluster.idx, |
| 772 | ! |
reorder = FALSE, na.rm = TRUE |
| 773 |
) |
|
| 774 | ||
| 775 |
# per cluster |
|
| 776 | ! |
both.diag.idx <- lav_matrix_diag_idx(length(both.idx)) |
| 777 | ! |
for (j in seq_len(nclusters)) {
|
| 778 | ! |
A.j.full <- ALIST[[j]] |
| 779 | ! |
A.j <- A.j.full[both.idx, both.idx, drop = FALSE] |
| 780 | ! |
p.j <- as.matrix(PJ[j, ]) |
| 781 | ! |
pb.j <- as.matrix(PJ[j, both.idx]) # only both.idx part |
| 782 | ! |
if (nz > 0L) {
|
| 783 | ! |
sigma.b.z <- SIGMA.B.Z[[ZPAT2J[j]]] |
| 784 |
} else {
|
|
| 785 | ! |
sigma.b.z <- sigma.b |
| 786 |
} |
|
| 787 | ||
| 788 | ! |
IBZA.j <- sigma.b.z %*% A.j |
| 789 | ! |
IBZA.j[both.diag.idx] <- IBZA.j[both.diag.idx] + 1 |
| 790 | ||
| 791 | ! |
IBZA.j.inv.BZ <- solve.default(IBZA.j, sigma.b.z) |
| 792 | ! |
IBZA.j.inv.BZ.p <- IBZA.j.inv.BZ %*% pb.j |
| 793 | ! |
A.IBZA.j.inv.BZ <- A.j %*% IBZA.j.inv.BZ |
| 794 | ! |
A.IBZA.j.inv.BZ.p <- A.IBZA.j.inv.BZ %*% pb.j |
| 795 | ||
| 796 | ! |
IBZA.j.inv <- solve.default(IBZA.j) |
| 797 | ! |
A.IBZA.j.inv <- A.j %*% IBZA.j.inv |
| 798 | ! |
p.IBZA.j.inv <- t(crossprod(pb.j, IBZA.j.inv)) |
| 799 | ||
| 800 |
# only if we have between-only variables |
|
| 801 | ! |
if (nz > 0L) {
|
| 802 | ! |
g.j <- as.matrix(GJ[j, ]) |
| 803 | ! |
zij <- as.matrix(GZ[j, ]) |
| 804 | ! |
zizy <- ZIZY[[ZPAT2J[j]]] |
| 805 | ! |
zip <- ZIP[[ZPAT2J[j]]] |
| 806 | ||
| 807 | ! |
IBZA.j.inv.zizy <- solve.default(IBZA.j, t(zizy)) |
| 808 | ! |
IBZA.j.inv.g <- IBZA.j.inv %*% g.j |
| 809 | ! |
IBZA.j.inv.p <- IBZA.j.inv %*% pb.j |
| 810 | ! |
A.IBZA.j.inv.g <- A.j %*% IBZA.j.inv.g |
| 811 | ! |
A.IBZA.j.inv.zizy <- A.j %*% IBZA.j.inv.zizy |
| 812 | ! |
zizy.A.IBZA.j.inv.g <- zizy %*% A.IBZA.j.inv.g |
| 813 | ! |
p.IBZA.j.inv.zizy <- crossprod(pb.j, IBZA.j.inv.zizy) |
| 814 | ! |
ggbzpp <- 2 * A.IBZA.j.inv.g + A.IBZA.j.inv.BZ.p - pb.j |
| 815 | ! |
ZIJzizyp <- (2 * zij - zizy %*% pb.j) |
| 816 | ||
| 817 |
########### |
|
| 818 |
# dx.mu.z # |
|
| 819 |
########### |
|
| 820 | ! |
tmp <- 2 * (t(p.IBZA.j.inv.zizy) - zij - zizy.A.IBZA.j.inv.g) |
| 821 | ! |
G.muz[j, ] <- drop(tmp) |
| 822 | ||
| 823 |
############### |
|
| 824 |
# dx.sigma.zz # |
|
| 825 |
############### |
|
| 826 | ! |
tmp1 <- (zip + zizy %*% A.IBZA.j.inv.zizy # logdet |
| 827 | ! |
- tcrossprod(zij) # ZA |
| 828 | ! |
- tcrossprod(zizy.A.IBZA.j.inv.g)) # ZB-1 |
| 829 | ||
| 830 | ! |
d <- (t((2 * zizy.A.IBZA.j.inv.g + zizy %*% A.IBZA.j.inv.BZ.p) |
| 831 | ! |
%*% p.IBZA.j.inv.zizy) |
| 832 | ! |
+ ZIJzizyp %*% p.IBZA.j.inv.zizy |
| 833 | ! |
- 2 * tcrossprod(zizy.A.IBZA.j.inv.g, zij)) |
| 834 | ! |
tmp2 <- (d + t(d)) / 2 |
| 835 | ! |
tmp <- tmp1 + tmp2 |
| 836 |
# symmetry correction |
|
| 837 | ! |
ZZ <- 2 * tmp |
| 838 | ! |
diag(ZZ) <- diag(tmp) |
| 839 | ! |
G.Sigma.zz[j, ] <- lav_matrix_vech(ZZ) |
| 840 | ||
| 841 |
############### |
|
| 842 |
# dx.sigma.yz # |
|
| 843 |
############### |
|
| 844 | ! |
t0 <- -2 * A.IBZA.j.inv.zizy |
| 845 | ||
| 846 | ! |
t1 <- (-2 * tcrossprod(p.IBZA.j.inv, g.j) |
| 847 | ! |
- 1 * tcrossprod(p.IBZA.j.inv, sigma.b.z %*% pb.j) |
| 848 | ! |
+ 2 * tcrossprod(A.IBZA.j.inv.g, g.j)) %*% A.IBZA.j.inv.zizy |
| 849 | ! |
t2 <- -ggbzpp %*% p.IBZA.j.inv.zizy |
| 850 | ! |
t3 <- -tcrossprod(p.IBZA.j.inv, ZIJzizyp) |
| 851 | ! |
t4 <- 2 * tcrossprod(A.IBZA.j.inv.g, zij) |
| 852 | ! |
tmp <- t0 + t1 + t2 + t3 + t4 |
| 853 | ! |
tmp2 <- matrix(0, nrow(out$sigma.yz), ncol(out$sigma.yz)) |
| 854 | ! |
tmp2[both.idx, ] <- tmp |
| 855 | ! |
G.Sigma.yz[j, ] <- lav_matrix_vec(tmp2) |
| 856 | ||
| 857 |
############## |
|
| 858 |
# dx.sigma.b # |
|
| 859 |
############## |
|
| 860 | ! |
c <- tcrossprod(ggbzpp, p.IBZA.j.inv) |
| 861 | ! |
tmp <- t(A.IBZA.j.inv) - tcrossprod(A.IBZA.j.inv.g) + (c + t(c)) / 2 |
| 862 |
# symmetry correction |
|
| 863 | ! |
ZZ <- 2 * tmp |
| 864 | ! |
diag(ZZ) <- diag(tmp) |
| 865 | ! |
ZZ2 <- matrix(0, nrow(out$sigma.b), ncol(out$sigma.b)) |
| 866 | ! |
ZZ2[both.idx, both.idx] <- ZZ |
| 867 | ! |
G.Sigma.b[j, ] <- lav_matrix_vech(ZZ2) |
| 868 |
# dx.sigma.b[both.idx, both.idx] <- |
|
| 869 |
# dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ |
|
| 870 | ||
| 871 |
# for dx.sigma.w |
|
| 872 | ! |
PART1.b <- -1 * (IBZA.j.inv.g %*% |
| 873 | ! |
(2 * t(IBZA.j.inv.BZ.p) + t(g.j) - |
| 874 | ! |
t(g.j) %*% A.IBZA.j.inv.BZ) |
| 875 | ! |
+ IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p)) |
| 876 | ! |
PART2.b <- 2 * (IBZA.j.inv.g + IBZA.j.inv.BZ.p) # vector |
| 877 |
} else {
|
|
| 878 |
############## |
|
| 879 |
# dx.sigma.b # |
|
| 880 |
############## |
|
| 881 | ! |
bzpp <- A.IBZA.j.inv.BZ.p - pb.j |
| 882 | ! |
c <- tcrossprod(bzpp, p.IBZA.j.inv) |
| 883 | ! |
tmp <- t(A.IBZA.j.inv) + (c + t(c)) / 2 |
| 884 |
# symmetry correction |
|
| 885 | ! |
ZZ <- 2 * tmp |
| 886 | ! |
diag(ZZ) <- diag(tmp) |
| 887 | ! |
ZZ2 <- matrix(0, nrow(out$sigma.b), ncol(out$sigma.b)) |
| 888 | ! |
ZZ2[both.idx, both.idx] <- ZZ |
| 889 | ! |
G.Sigma.b[j, ] <- lav_matrix_vech(ZZ2) |
| 890 |
# dx.sigma.b[both.idx, both.idx] <- |
|
| 891 |
# dx.sigma.b[both.idx, both.idx, drop = FALSE] + ZZ |
|
| 892 | ||
| 893 | ! |
PART1.b <- -1 * (IBZA.j.inv.BZ + tcrossprod(IBZA.j.inv.BZ.p)) |
| 894 | ! |
PART2.b <- 2 * IBZA.j.inv.BZ.p # vector |
| 895 |
} |
|
| 896 | ||
| 897 |
############## |
|
| 898 |
# dx.sigma.w # |
|
| 899 |
############## |
|
| 900 | ||
| 901 | ! |
PART1 <- matrix(0, ny, ny) |
| 902 | ! |
PART1[both.idx, both.idx] <- PART1.b |
| 903 | ||
| 904 | ! |
PART2 <- matrix(0, ny, 1L) |
| 905 | ! |
PART2[both.idx, 1L] <- PART2.b |
| 906 | ||
| 907 | ! |
ij.index <- which(cluster.idx == j) |
| 908 | ! |
pij <- PIJ[ij.index, , drop = FALSE] |
| 909 | ||
| 910 | ! |
which.compl <- which(MPi[ij.index] == 0L) |
| 911 | ! |
which.incompl <- which(MPi[ij.index] != 0L) |
| 912 | ||
| 913 | ! |
AP2 <- rep(list(sigma.w.inv %*% PART2), length(ij.index)) |
| 914 | ! |
AP1A.a <- AP1A.b <- matrix(0, ny, ny) |
| 915 |
# A.j.full <- matrix(0, ny, ny) |
|
| 916 | ! |
if (length(which.compl) > 0L) {
|
| 917 | ! |
tmp <- (sigma.w.inv %*% PART1 %*% sigma.w.inv) |
| 918 | ! |
AP1A.a <- tmp * length(which.compl) |
| 919 |
# A.j.full <- A.j.full + sigma.w.inv * length(which.compl) |
|
| 920 |
} |
|
| 921 | ! |
if (length(which.incompl) > 0L) {
|
| 922 | ! |
p.idx <- MPi[ij.index][which.incompl] |
| 923 | ! |
tmp <- lapply(WIP[p.idx], function(x) {
|
| 924 | ! |
x %*% PART1 %*% x |
| 925 |
}) |
|
| 926 | ! |
AP1A.b <- Reduce("+", tmp)
|
| 927 | ! |
AP2[which.incompl] <- |
| 928 | ! |
lapply(WIP[p.idx], function(x) {
|
| 929 | ! |
x %*% PART2 |
| 930 |
}) |
|
| 931 |
# A.j.full <- A.j.full + Reduce("+", WIP[ p.idx ])
|
|
| 932 |
} |
|
| 933 | ! |
t1 <- AP1A.a + AP1A.b |
| 934 | ! |
t2 <- (do.call("cbind", AP2) - t(pij)) %*% pij
|
| 935 | ||
| 936 | ! |
AA.wj <- t1 + t2 |
| 937 | ||
| 938 | ! |
tmp <- A.j.full + (AA.wj + t(AA.wj)) / 2 |
| 939 |
# symmetry correction |
|
| 940 | ! |
ZZ <- 2 * tmp |
| 941 | ! |
diag(ZZ) <- diag(tmp) |
| 942 | ! |
G.Sigma.w[j, ] <- lav_matrix_vech(ZZ) |
| 943 |
# dx.sigma.w <- dx.sigma.w + ZZ |
|
| 944 | ||
| 945 |
########### |
|
| 946 |
# dx.mu.y # |
|
| 947 |
########### |
|
| 948 | ! |
tmp <- numeric(ny) |
| 949 | ! |
if (nz > 0L) {
|
| 950 | ! |
tmp[both.idx] <- IBZA.j.inv.g + IBZA.j.inv.BZ.p |
| 951 |
} else {
|
|
| 952 | ! |
tmp[both.idx] <- IBZA.j.inv.BZ.p |
| 953 |
} |
|
| 954 | ! |
gbzpp <- A.j.full %*% tmp - p.j |
| 955 |
# dx.mu.y <- dx.mu.y + drop(2 * gbzpp) |
|
| 956 | ! |
G.muy[j, ] <- drop(2 * gbzpp) |
| 957 |
} # j |
|
| 958 | ||
| 959 |
# browser() |
|
| 960 | ||
| 961 |
# rearrange columns to Mu.W, Mu.B, Sigma.W, Sigma.B |
|
| 962 | ! |
ov.idx <- Lp$ov.idx |
| 963 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 964 | ||
| 965 |
# Mu.W (for within-only) |
|
| 966 | ! |
Mu.W.tilde <- matrix(0, nclusters, p.tilde) |
| 967 | ! |
Mu.W.tilde[, ov.idx[[1]]] <- G.muy |
| 968 | ! |
Mu.W.tilde[, Lp$both.idx[[2]]] <- 0 # ZERO!!! |
| 969 | ! |
Mu.W <- Mu.W.tilde[, ov.idx[[1]], drop = FALSE] |
| 970 | ||
| 971 |
# Mu.B |
|
| 972 | ! |
Mu.B.tilde <- matrix(0, nclusters, p.tilde) |
| 973 | ! |
Mu.B.tilde[, ov.idx[[1]]] <- G.muy |
| 974 | ! |
if (length(between.idx) > 0L) {
|
| 975 | ! |
Mu.B.tilde[, between.idx] <- G.muz |
| 976 |
} |
|
| 977 | ! |
Mu.B <- Mu.B.tilde[, ov.idx[[2]], drop = FALSE] |
| 978 | ||
| 979 |
# Sigma.W |
|
| 980 | ! |
Sigma.W <- G.Sigma.w |
| 981 | ||
| 982 |
# Sigma.B |
|
| 983 | ! |
if (length(between.idx) > 0L) {
|
| 984 | ! |
p.tilde.star <- p.tilde * (p.tilde + 1) / 2 |
| 985 | ! |
B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star)) |
| 986 | ||
| 987 | ! |
Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star) |
| 988 | ||
| 989 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], |
| 990 | ! |
drop = FALSE |
| 991 |
]) |
|
| 992 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.b |
| 993 | ||
| 994 | ! |
col.idx <- lav_matrix_vec(B.tilde[ov.idx[[1]], between.idx, |
| 995 | ! |
drop = FALSE |
| 996 |
]) |
|
| 997 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.yz |
| 998 | ||
| 999 | ! |
col.idx <- lav_matrix_vech(B.tilde[between.idx, between.idx, |
| 1000 | ! |
drop = FALSE |
| 1001 |
]) |
|
| 1002 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.zz |
| 1003 | ||
| 1004 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], |
| 1005 | ! |
drop = FALSE |
| 1006 |
]) |
|
| 1007 | ! |
Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE] |
| 1008 |
} else {
|
|
| 1009 | ! |
p.tilde.star <- p.tilde * (p.tilde + 1) / 2 |
| 1010 | ! |
B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star)) |
| 1011 | ||
| 1012 | ! |
Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star) |
| 1013 | ||
| 1014 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], |
| 1015 | ! |
drop = FALSE |
| 1016 |
]) |
|
| 1017 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.b |
| 1018 | ||
| 1019 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], |
| 1020 | ! |
drop = FALSE |
| 1021 |
]) |
|
| 1022 | ! |
Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE] |
| 1023 |
# Sigma.B <- G.Sigma.b |
|
| 1024 |
} |
|
| 1025 | ||
| 1026 | ! |
SCORES <- cbind(Mu.W, Sigma.W, Mu.B, Sigma.B) |
| 1027 | ||
| 1028 | ! |
SCORES |
| 1029 |
} |
|
| 1030 | ||
| 1031 |
# first-order information: outer crossprod of scores per cluster |
|
| 1032 |
lav_mvnorm_cluster_missing_information_firstorder <- function( |
|
| 1033 |
Y1 = NULL, |
|
| 1034 |
Y2 = NULL, |
|
| 1035 |
Lp = NULL, |
|
| 1036 |
Mp = NULL, |
|
| 1037 |
Mu.W = NULL, |
|
| 1038 |
Sigma.W = NULL, |
|
| 1039 |
Mu.B = NULL, |
|
| 1040 |
Sigma.B = NULL, |
|
| 1041 |
x.idx = NULL, |
|
| 1042 |
divide.by.two = FALSE, |
|
| 1043 |
Sinv.method = "eigen") {
|
|
| 1044 | ! |
N <- NROW(Y1) |
| 1045 | ||
| 1046 | ! |
SCORES <- lav_mvnorm_cluster_missing_scores_2l( |
| 1047 | ! |
Y1 = Y1, |
| 1048 | ! |
Y2 = Y2, |
| 1049 | ! |
Lp = Lp, |
| 1050 | ! |
Mp = Mp, |
| 1051 | ! |
Mu.W = Mu.W, |
| 1052 | ! |
Sigma.W = Sigma.W, |
| 1053 | ! |
Mu.B = Mu.B, |
| 1054 | ! |
Sigma.B = Sigma.B, |
| 1055 | ! |
Sinv.method = Sinv.method |
| 1056 |
) |
|
| 1057 | ||
| 1058 |
# divide by 2 (if we want scores wrt objective function) |
|
| 1059 | ! |
if (divide.by.two) {
|
| 1060 | ! |
SCORES <- SCORES / 2 |
| 1061 |
} |
|
| 1062 | ||
| 1063 |
# unit information |
|
| 1064 | ! |
information <- crossprod(SCORES) / Lp$nclusters[[2]] |
| 1065 | ||
| 1066 | ||
| 1067 |
# if x.idx, set rows/cols to zero |
|
| 1068 | ! |
if (length(x.idx) > 0L) {
|
| 1069 | ! |
nw <- length(as.vector(Mu.W)) |
| 1070 | ! |
nw.star <- nw * (nw + 1) / 2 |
| 1071 | ! |
nb <- length(as.vector(Mu.B)) |
| 1072 | ! |
ov.idx <- Lp$ov.idx |
| 1073 | ||
| 1074 | ! |
x.idx.w <- which(ov.idx[[1]] %in% x.idx) |
| 1075 | ! |
if (length(x.idx.w) > 0L) {
|
| 1076 | ! |
xw.idx <- c( |
| 1077 | ! |
x.idx.w, |
| 1078 | ! |
nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w) |
| 1079 |
) |
|
| 1080 |
} else {
|
|
| 1081 | ! |
xw.idx <- integer(0L) |
| 1082 |
} |
|
| 1083 | ! |
x.idx.b <- which(ov.idx[[2]] %in% x.idx) |
| 1084 | ! |
if (length(x.idx.b) > 0L) {
|
| 1085 | ! |
xb.idx <- c( |
| 1086 | ! |
x.idx.b, |
| 1087 | ! |
nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b) |
| 1088 |
) |
|
| 1089 |
} else {
|
|
| 1090 | ! |
xb.idx <- integer(0L) |
| 1091 |
} |
|
| 1092 | ||
| 1093 | ! |
all.idx <- c(xw.idx, nw + nw.star + xb.idx) |
| 1094 | ||
| 1095 | ! |
information[all.idx, ] <- 0 |
| 1096 | ! |
information[, all.idx] <- 0 |
| 1097 |
} |
|
| 1098 | ||
| 1099 | ! |
information |
| 1100 |
} |
|
| 1101 | ||
| 1102 |
# observed information |
|
| 1103 |
# order: mu.w within, vech(sigma.w) within, mu.b between, vech(sigma.b) between |
|
| 1104 |
# mu.w rows/cols that are splitted within/between are forced to zero |
|
| 1105 |
# |
|
| 1106 |
# numerical approximation (for now) |
|
| 1107 |
lav_mvnorm_cluster_missing_information_observed <- function( |
|
| 1108 |
Y1 = NULL, |
|
| 1109 |
Y2 = NULL, |
|
| 1110 |
Lp = NULL, |
|
| 1111 |
Mp = NULL, |
|
| 1112 |
YLp = NULL, |
|
| 1113 |
Mu.W = NULL, |
|
| 1114 |
Sigma.W = NULL, |
|
| 1115 |
Mu.B = NULL, |
|
| 1116 |
Sigma.B = NULL, |
|
| 1117 |
x.idx = integer(0L), |
|
| 1118 |
Sinv.method = "eigen") {
|
|
| 1119 | ||
| 1120 | ! |
nobs <- Lp$nclusters[[1]] |
| 1121 | ||
| 1122 | ! |
nw <- length(as.vector(Mu.W)) |
| 1123 | ! |
nw.star <- nw * (nw + 1) / 2 |
| 1124 | ! |
nb <- length(as.vector(Mu.B)) |
| 1125 | ! |
nb.star <- nb * (nb + 1) / 2 |
| 1126 | ||
| 1127 | ! |
ov.idx <- Lp$ov.idx |
| 1128 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 1129 | ||
| 1130 |
# Mu.W (for within-only) |
|
| 1131 | ! |
Mu.W.tilde <- numeric(p.tilde) |
| 1132 | ! |
Mu.W.tilde[ov.idx[[1]]] <- Mu.W |
| 1133 | ||
| 1134 |
# local function -- gradient |
|
| 1135 | ! |
GRAD <- function(x) {
|
| 1136 |
# Mu.W (for within-only) |
|
| 1137 | ! |
Mu.W.tilde2 <- numeric(p.tilde) |
| 1138 | ! |
Mu.W.tilde2[ov.idx[[1]]] <- x[1:nw] |
| 1139 | ! |
Mu.W.tilde2[Lp$both.idx[[2]]] <- Mu.W.tilde[Lp$both.idx[[2]]] |
| 1140 | ! |
Mu.W2 <- Mu.W.tilde2[ov.idx[[1]]] |
| 1141 | ||
| 1142 | ! |
Sigma.W2 <- lav_matrix_vech_reverse(x[nw + 1:nw.star]) |
| 1143 | ! |
Mu.B2 <- x[nw + nw.star + 1:nb] |
| 1144 | ! |
Sigma.B2 <- lav_matrix_vech_reverse(x[nw + nw.star + nb + 1:nb.star]) |
| 1145 | ||
| 1146 | ! |
dx <- lav_mvnorm_cluster_missing_dlogl_2l_samplestats( |
| 1147 | ! |
Y1 = Y1, Y2 = Y2, Lp = Lp, Mp = Mp, |
| 1148 | ! |
Mu.W = Mu.W2, Sigma.W = Sigma.W2, |
| 1149 | ! |
Mu.B = Mu.B2, Sigma.B = Sigma.B2, |
| 1150 | ! |
return.list = FALSE, |
| 1151 | ! |
Sinv.method = Sinv.method |
| 1152 |
) |
|
| 1153 | ||
| 1154 |
# dx is for -2*logl |
|
| 1155 | ! |
-1 / 2 * dx |
| 1156 |
} |
|
| 1157 | ||
| 1158 |
# start.x |
|
| 1159 | ! |
start.x <- c( |
| 1160 | ! |
as.vector(Mu.W), lav_matrix_vech(Sigma.W), |
| 1161 | ! |
as.vector(Mu.B), lav_matrix_vech(Sigma.B) |
| 1162 |
) |
|
| 1163 | ||
| 1164 |
# total information |
|
| 1165 | ! |
information <- -1 * numDeriv::jacobian(func = GRAD, x = start.x) |
| 1166 | ||
| 1167 |
# unit information |
|
| 1168 | ! |
information <- information / Lp$nclusters[[2]] |
| 1169 | ||
| 1170 | ||
| 1171 |
# if x.idx, set rows/cols to zero |
|
| 1172 | ! |
if (length(x.idx) > 0L) {
|
| 1173 | ! |
x.idx.w <- which(ov.idx[[1]] %in% x.idx) |
| 1174 | ! |
if (length(x.idx.w) > 0L) {
|
| 1175 | ! |
xw.idx <- c( |
| 1176 | ! |
x.idx.w, |
| 1177 | ! |
nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w) |
| 1178 |
) |
|
| 1179 |
} else {
|
|
| 1180 | ! |
xw.idx <- integer(0L) |
| 1181 |
} |
|
| 1182 | ! |
x.idx.b <- which(ov.idx[[2]] %in% x.idx) |
| 1183 | ! |
if (length(x.idx.b) > 0L) {
|
| 1184 | ! |
xb.idx <- c( |
| 1185 | ! |
x.idx.b, |
| 1186 | ! |
nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b) |
| 1187 |
) |
|
| 1188 |
} else {
|
|
| 1189 | ! |
xb.idx <- integer(0L) |
| 1190 |
} |
|
| 1191 | ||
| 1192 | ! |
all.idx <- c(xw.idx, nw + nw.star + xb.idx) |
| 1193 | ||
| 1194 | ! |
information[all.idx, ] <- 0 |
| 1195 | ! |
information[, all.idx] <- 0 |
| 1196 |
} |
|
| 1197 | ||
| 1198 | ! |
information |
| 1199 |
} |
| 1 |
# the multivariate linear model using maximum likelihood |
|
| 2 | ||
| 3 |
# 1) loglikelihood (from raw data, or sample statistics) |
|
| 4 |
# 2) derivatives with respect to Beta, res.cov, vech(res.cov) |
|
| 5 |
# 3) casewise scores with respect to Beta, vech(res.cov), Beta + vech(res.cov) |
|
| 6 |
# 4) hessian Beta + vech(res.cov) |
|
| 7 |
# 5) information h0 Beta + vech(res.cov) |
|
| 8 |
# 5a: (unit) expected information |
|
| 9 |
# 5b: (unit) observed information |
|
| 10 |
# 5c: (unit) first.order information |
|
| 11 | ||
| 12 |
# YR 24 Mar 2016: first version |
|
| 13 |
# YR 20 Jan 2017: removed added 'N' in many equations, to be consistent with |
|
| 14 |
# lav_mvnorm_* |
|
| 15 |
# YR 18 Okt 2018: add 'information' functions, change arguments |
|
| 16 |
# (X -> eXo, Sigma -> res.cov, Beta -> res.int + res.slopes) |
|
| 17 | ||
| 18 |
# 1. loglikelihood |
|
| 19 | ||
| 20 |
# 1a. input is raw data |
|
| 21 |
lav_mvreg_loglik_data <- function(Y = NULL, |
|
| 22 |
eXo = NULL, # no intercept |
|
| 23 |
Beta = NULL, |
|
| 24 |
res.int = NULL, |
|
| 25 |
res.slopes = NULL, |
|
| 26 |
res.cov = NULL, |
|
| 27 |
casewise = FALSE, |
|
| 28 |
Sinv.method = "eigen") {
|
|
| 29 | ! |
Y <- unname(Y) |
| 30 | ! |
Q <- NCOL(Y) |
| 31 | ! |
N <- NROW(Y) |
| 32 | ! |
X <- cbind(1, unname(eXo)) |
| 33 | ||
| 34 |
# construct model-implied Beta |
|
| 35 | ! |
if (is.null(Beta)) {
|
| 36 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 37 |
} |
|
| 38 | ||
| 39 | ! |
if (casewise) {
|
| 40 | ! |
LOG.2PI <- log(2 * pi) |
| 41 | ||
| 42 |
# invert res.cov |
|
| 43 | ! |
if (Sinv.method == "chol") {
|
| 44 | ! |
cS <- chol(res.cov) |
| 45 | ! |
icS <- backsolve(cS, diag(Q)) |
| 46 | ! |
logdet <- -2 * sum(log(diag(icS))) |
| 47 | ||
| 48 | ! |
RES <- Y - X %*% Beta |
| 49 | ! |
DIST <- rowSums((RES %*% icS)^2) |
| 50 |
} else {
|
|
| 51 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 52 | ! |
S = res.cov, logdet = TRUE, |
| 53 | ! |
Sinv.method = Sinv.method |
| 54 |
) |
|
| 55 | ! |
logdet <- attr(res.cov.inv, "logdet") |
| 56 | ||
| 57 | ! |
RES <- Y - X %*% Beta |
| 58 | ! |
DIST <- rowSums(RES %*% res.cov.inv * RES) |
| 59 |
} |
|
| 60 | ||
| 61 | ! |
loglik <- -(Q * LOG.2PI + logdet + DIST) / 2 |
| 62 |
} else {
|
|
| 63 |
# invert res.cov |
|
| 64 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 65 | ! |
S = res.cov, logdet = TRUE, |
| 66 | ! |
Sinv.method = Sinv.method |
| 67 |
) |
|
| 68 | ! |
logdet <- attr(res.cov.inv, "logdet") |
| 69 | ||
| 70 | ! |
RES <- Y - X %*% Beta |
| 71 |
# TOTAL <- TR( (Y - X%*%Beta) %*% res.cov.inv %*% t(Y - X%*%Beta) ) |
|
| 72 | ! |
TOTAL <- sum(rowSums(RES %*% res.cov.inv * RES)) |
| 73 | ! |
loglik <- -(N * Q / 2) * log(2 * pi) - (N / 2) * logdet - (1 / 2) * TOTAL |
| 74 |
} |
|
| 75 | ||
| 76 | ! |
loglik |
| 77 |
} |
|
| 78 | ||
| 79 | ||
| 80 |
# 2b. input are sample statistics (res.int, res.slopes, res.cov, N) only |
|
| 81 |
lav_mvreg_loglik_samplestats <- function(sample.res.int = NULL, |
|
| 82 |
sample.res.slopes = NULL, |
|
| 83 |
sample.res.cov = NULL, |
|
| 84 |
sample.mean.x = NULL, |
|
| 85 |
sample.cov.x = NULL, |
|
| 86 |
sample.nobs = NULL, |
|
| 87 |
Beta = NULL, # optional |
|
| 88 |
res.int = NULL, |
|
| 89 |
res.slopes = NULL, |
|
| 90 |
res.cov = NULL, |
|
| 91 |
Sinv.method = "eigen", |
|
| 92 |
res.cov.inv = NULL) {
|
|
| 93 | ! |
Q <- NCOL(sample.res.cov) |
| 94 | ! |
N <- sample.nobs |
| 95 | ! |
LOG.2PI <- log(2 * pi) |
| 96 | ||
| 97 |
# construct model-implied Beta |
|
| 98 | ! |
if (is.null(Beta)) {
|
| 99 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 100 |
} |
|
| 101 | ||
| 102 |
# construct 'saturated' (sample-based) B |
|
| 103 | ! |
sample.B <- rbind(matrix(sample.res.int, nrow = 1), t(sample.res.slopes)) |
| 104 | ||
| 105 |
# construct sample.xx = 1/N*crossprod(X1) (including intercept) |
|
| 106 | ! |
sample.xx <- rbind( |
| 107 | ! |
cbind(1, matrix(sample.mean.x, nrow = 1, )), |
| 108 | ! |
cbind( |
| 109 | ! |
matrix(sample.mean.x, ncol = 1), |
| 110 | ! |
sample.cov.x + tcrossprod(sample.mean.x) |
| 111 |
) |
|
| 112 |
) |
|
| 113 | ||
| 114 |
# res.cov.inv |
|
| 115 | ! |
if (is.null(res.cov.inv)) {
|
| 116 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 117 | ! |
S = res.cov, logdet = TRUE, |
| 118 | ! |
Sinv.method = Sinv.method |
| 119 |
) |
|
| 120 | ! |
logdet <- attr(res.cov.inv, "logdet") |
| 121 |
} else {
|
|
| 122 | ! |
logdet <- attr(res.cov.inv, "logdet") |
| 123 | ! |
if (is.null(logdet)) {
|
| 124 |
# compute - ln|res.cov.inv| |
|
| 125 | ! |
ev <- eigen(res.cov.inv, symmetric = TRUE, only.values = TRUE) |
| 126 | ! |
logdet <- -1 * sum(log(ev$values)) |
| 127 |
} |
|
| 128 |
} |
|
| 129 | ||
| 130 |
# tr(res.cov^{-1} %*% S)
|
|
| 131 | ! |
DIST1 <- sum(res.cov.inv * sample.res.cov) |
| 132 | ||
| 133 |
# tr( res.cov^{-1} (B-beta)' X'X (B-beta)
|
|
| 134 | ! |
Diff <- sample.B - Beta |
| 135 | ! |
DIST2 <- sum(res.cov.inv * crossprod(Diff, sample.xx) %*% Diff) |
| 136 | ||
| 137 | ! |
loglik <- -(N / 2) * (Q * log(2 * pi) + logdet + DIST1 + DIST2) |
| 138 | ||
| 139 | ! |
loglik |
| 140 |
} |
|
| 141 | ||
| 142 | ||
| 143 | ||
| 144 | ||
| 145 |
# 2. Derivatives |
|
| 146 | ||
| 147 |
# 2a. derivative logl with respect to Beta (=intercepts and slopes) |
|
| 148 |
lav_mvreg_dlogl_dbeta <- function(Y = NULL, |
|
| 149 |
eXo = NULL, |
|
| 150 |
Beta = NULL, |
|
| 151 |
res.int = NULL, |
|
| 152 |
res.slopes = NULL, |
|
| 153 |
res.cov = NULL, |
|
| 154 |
Sinv.method = "eigen", |
|
| 155 |
res.cov.inv = NULL) {
|
|
| 156 | ! |
Y <- unname(Y) |
| 157 | ! |
X <- cbind(1, unname(eXo)) |
| 158 | ||
| 159 |
# construct model-implied Beta |
|
| 160 | ! |
if (is.null(Beta)) {
|
| 161 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 162 |
} |
|
| 163 | ||
| 164 |
# res.cov.inv |
|
| 165 | ! |
if (is.null(res.cov.inv)) {
|
| 166 |
# invert res.cov |
|
| 167 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 168 | ! |
S = res.cov, logdet = FALSE, |
| 169 | ! |
Sinv.method = Sinv.method |
| 170 |
) |
|
| 171 |
} |
|
| 172 | ||
| 173 |
# substract 'X %*% Beta' from Y |
|
| 174 | ! |
RES <- Y - X %*% Beta |
| 175 | ||
| 176 |
# derivative |
|
| 177 | ! |
dbeta <- as.numeric(t(X) %*% RES %*% res.cov.inv) |
| 178 | ||
| 179 | ! |
dbeta |
| 180 |
} |
|
| 181 | ||
| 182 |
# 2b: derivative logl with respect to res.cov (full matrix, ignoring symmetry) |
|
| 183 |
lav_mvreg_dlogl_drescov <- function(Y = NULL, |
|
| 184 |
eXo = NULL, |
|
| 185 |
Beta = NULL, |
|
| 186 |
res.cov = NULL, |
|
| 187 |
res.int = NULL, |
|
| 188 |
res.slopes = NULL, |
|
| 189 |
Sinv.method = "eigen", |
|
| 190 |
res.cov.inv = NULL) {
|
|
| 191 | ! |
Y <- unname(Y) |
| 192 | ! |
N <- NROW(Y) |
| 193 | ! |
X <- cbind(1, unname(eXo)) |
| 194 | ||
| 195 |
# construct model-implied Beta |
|
| 196 | ! |
if (is.null(Beta)) {
|
| 197 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 198 |
} |
|
| 199 | ||
| 200 |
# res.cov.in |
|
| 201 | ! |
if (is.null(res.cov.inv)) {
|
| 202 |
# invert res.cov |
|
| 203 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 204 | ! |
S = res.cov, logdet = FALSE, |
| 205 | ! |
Sinv.method = Sinv.method |
| 206 |
) |
|
| 207 |
} |
|
| 208 | ||
| 209 |
# substract 'X %*% Beta' from Y |
|
| 210 | ! |
RES <- Y - X %*% Beta |
| 211 | ||
| 212 |
# W.tilde |
|
| 213 | ! |
W.tilde <- crossprod(RES) / N |
| 214 | ||
| 215 |
# derivative |
|
| 216 | ! |
dres.cov <- -(N / 2) * (res.cov.inv - (res.cov.inv %*% W.tilde %*% res.cov.inv)) |
| 217 | ||
| 218 | ! |
dres.cov |
| 219 |
} |
|
| 220 | ||
| 221 |
# 2c: derivative logl with respect to vech(res.cov) |
|
| 222 |
lav_mvreg_dlogl_dvechrescov <- function(Y = NULL, |
|
| 223 |
eXo = NULL, |
|
| 224 |
Beta = NULL, |
|
| 225 |
res.int = NULL, |
|
| 226 |
res.slopes = NULL, |
|
| 227 |
res.cov = NULL, |
|
| 228 |
Sinv.method = "eigen", |
|
| 229 |
res.cov.inv = NULL) {
|
|
| 230 | ! |
Y <- unname(Y) |
| 231 | ! |
N <- NROW(Y) |
| 232 | ! |
X <- cbind(1, unname(eXo)) |
| 233 | ||
| 234 |
# construct model-implied Beta |
|
| 235 | ! |
if (is.null(Beta)) {
|
| 236 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 237 |
} |
|
| 238 | ||
| 239 |
# res.cov.inv |
|
| 240 | ! |
if (is.null(res.cov.inv)) {
|
| 241 |
# invert res.cov |
|
| 242 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 243 | ! |
S = res.cov, logdet = FALSE, |
| 244 | ! |
Sinv.method = Sinv.method |
| 245 |
) |
|
| 246 |
} |
|
| 247 | ||
| 248 |
# substract 'X %*% Beta' from Y |
|
| 249 | ! |
RES <- Y - X %*% Beta |
| 250 | ||
| 251 |
# W.tilde |
|
| 252 | ! |
W.tilde <- crossprod(RES) / N |
| 253 | ||
| 254 |
# derivative |
|
| 255 | ! |
dres.cov <- -(N / 2) * (res.cov.inv - (res.cov.inv %*% W.tilde %*% res.cov.inv)) |
| 256 | ! |
dvechres.cov <- as.numeric(lav_matrix_duplication_pre( |
| 257 | ! |
as.matrix(lav_matrix_vec(dres.cov)) |
| 258 |
)) |
|
| 259 | ||
| 260 | ! |
dvechres.cov |
| 261 |
} |
|
| 262 | ||
| 263 | ||
| 264 |
# 3. Casewise scores |
|
| 265 | ||
| 266 |
# 3a: casewise scores with respect to Beta (=intercepts and slopes) |
|
| 267 |
# column order: Y1_int, Y1_x1, Y1_x2, ...| Y2_int, Y2_x1, Y2_x2, ... | |
|
| 268 |
lav_mvreg_scores_beta <- function(Y = NULL, |
|
| 269 |
eXo = NULL, |
|
| 270 |
Beta = NULL, |
|
| 271 |
res.int = NULL, |
|
| 272 |
res.slopes = NULL, |
|
| 273 |
res.cov = NULL, |
|
| 274 |
Sinv.method = "eigen", |
|
| 275 |
res.cov.inv = NULL) {
|
|
| 276 | ! |
Y <- unname(Y) |
| 277 | ! |
Q <- NCOL(Y) |
| 278 | ! |
X <- cbind(1, unname(eXo)) |
| 279 | ! |
P <- NCOL(X) |
| 280 | ||
| 281 |
# construct model-implied Beta |
|
| 282 | ! |
if (is.null(Beta)) {
|
| 283 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 284 |
} |
|
| 285 | ||
| 286 |
# res.cov.inv |
|
| 287 | ! |
if (is.null(res.cov.inv)) {
|
| 288 |
# invert res.cov |
|
| 289 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 290 | ! |
S = res.cov, logdet = FALSE, |
| 291 | ! |
Sinv.method = Sinv.method |
| 292 |
) |
|
| 293 |
} |
|
| 294 | ||
| 295 |
# substract Mu |
|
| 296 | ! |
RES <- Y - X %*% Beta |
| 297 | ||
| 298 |
# post-multiply with res.cov.inv |
|
| 299 | ! |
RES <- RES %*% res.cov.inv |
| 300 | ||
| 301 | ! |
SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] * |
| 302 | ! |
RES[, rep(1:Q, each = P), drop = FALSE] |
| 303 | ||
| 304 | ! |
SC.Beta |
| 305 |
} |
|
| 306 | ||
| 307 | ||
| 308 |
# 3b: casewise scores with respect to vech(res.cov) |
|
| 309 |
lav_mvreg_scores_vech_sigma <- function(Y = NULL, |
|
| 310 |
eXo = NULL, |
|
| 311 |
Beta = NULL, |
|
| 312 |
res.int = NULL, |
|
| 313 |
res.slopes = NULL, |
|
| 314 |
res.cov = NULL, |
|
| 315 |
Sinv.method = "eigen", |
|
| 316 |
res.cov.inv = NULL) {
|
|
| 317 | ! |
Y <- unname(Y) |
| 318 | ! |
Q <- NCOL(Y) |
| 319 | ! |
X <- cbind(1, unname(eXo)) |
| 320 | ||
| 321 |
# construct model-implied Beta |
|
| 322 | ! |
if (is.null(Beta)) {
|
| 323 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 324 |
} |
|
| 325 | ||
| 326 |
# res.cov.inv |
|
| 327 | ! |
if (is.null(res.cov.inv)) {
|
| 328 |
# invert res.cov |
|
| 329 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 330 | ! |
S = res.cov, logdet = FALSE, |
| 331 | ! |
Sinv.method = Sinv.method |
| 332 |
) |
|
| 333 |
} |
|
| 334 | ||
| 335 |
# vech(res.cov.inv) |
|
| 336 | ! |
isigma <- lav_matrix_vech(res.cov.inv) |
| 337 | ||
| 338 |
# substract X %*% Beta |
|
| 339 | ! |
RES <- Y - X %*% Beta |
| 340 | ||
| 341 |
# postmultiply with res.cov.inv |
|
| 342 | ! |
RES <- RES %*% res.cov.inv |
| 343 | ||
| 344 |
# tcrossprod |
|
| 345 | ! |
idx1 <- lav_matrix_vech_col_idx(Q) |
| 346 | ! |
idx2 <- lav_matrix_vech_row_idx(Q) |
| 347 | ! |
Z <- RES[, idx1] * RES[, idx2] |
| 348 | ||
| 349 |
# substract isigma from each row |
|
| 350 | ! |
SC <- t(t(Z) - isigma) |
| 351 | ||
| 352 |
# adjust for vech (and avoiding the 1/2 factor) |
|
| 353 | ! |
SC[, lav_matrix_diagh_idx(Q)] <- SC[, lav_matrix_diagh_idx(Q)] / 2 |
| 354 | ||
| 355 | ! |
SC |
| 356 |
} |
|
| 357 | ||
| 358 | ||
| 359 |
# 3c: casewise scores with respect to beta + vech(res.cov) |
|
| 360 |
lav_mvreg_scores_beta_vech_sigma <- function(Y = NULL, |
|
| 361 |
eXo = NULL, |
|
| 362 |
Beta = NULL, |
|
| 363 |
res.int = NULL, |
|
| 364 |
res.slopes = NULL, |
|
| 365 |
res.cov = NULL, |
|
| 366 |
Sinv.method = "eigen", |
|
| 367 |
res.cov.inv = NULL) {
|
|
| 368 | ! |
Y <- unname(Y) |
| 369 | ! |
Q <- NCOL(Y) |
| 370 | ! |
X <- cbind(1, unname(eXo)) |
| 371 | ! |
P <- NCOL(X) |
| 372 | ||
| 373 |
# construct model-implied Beta |
|
| 374 | ! |
if (is.null(Beta)) {
|
| 375 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 376 |
} |
|
| 377 | ||
| 378 |
# res.cov.inv |
|
| 379 | ! |
if (is.null(res.cov.inv)) {
|
| 380 |
# invert res.cov |
|
| 381 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 382 | ! |
S = res.cov, logdet = FALSE, |
| 383 | ! |
Sinv.method = Sinv.method |
| 384 |
) |
|
| 385 |
} |
|
| 386 | ||
| 387 |
# vech(res.cov.inv) |
|
| 388 | ! |
isigma <- lav_matrix_vech(res.cov.inv) |
| 389 | ||
| 390 |
# substract X %*% Beta |
|
| 391 | ! |
RES <- Y - X %*% Beta |
| 392 | ||
| 393 |
# postmultiply with res.cov.inv |
|
| 394 | ! |
RES <- RES %*% res.cov.inv |
| 395 | ||
| 396 | ! |
SC.Beta <- X[, rep(1:P, times = Q), drop = FALSE] * |
| 397 | ! |
RES[, rep(1:Q, each = P), drop = FALSE] |
| 398 | ||
| 399 |
# tcrossprod |
|
| 400 | ! |
idx1 <- lav_matrix_vech_col_idx(Q) |
| 401 | ! |
idx2 <- lav_matrix_vech_row_idx(Q) |
| 402 | ! |
Z <- RES[, idx1] * RES[, idx2] |
| 403 | ||
| 404 |
# substract isigma from each row |
|
| 405 | ! |
SC <- t(t(Z) - isigma) |
| 406 | ||
| 407 |
# adjust for vech (and avoiding the 1/2 factor) |
|
| 408 | ! |
SC[, lav_matrix_diagh_idx(Q)] <- SC[, lav_matrix_diagh_idx(Q)] / 2 |
| 409 | ||
| 410 | ! |
cbind(SC.Beta, SC) |
| 411 |
} |
|
| 412 | ||
| 413 |
# 4. hessian of logl |
|
| 414 | ||
| 415 |
# 4a. hessian logl Beta and vech(res.cov) from raw data |
|
| 416 |
lav_mvreg_logl_hessian_data <- function(Y = NULL, |
|
| 417 |
eXo = NULL, # no int |
|
| 418 |
Beta = NULL, # int+slopes |
|
| 419 |
res.int = NULL, |
|
| 420 |
res.slopes = NULL, |
|
| 421 |
res.cov = NULL, |
|
| 422 |
res.cov.inv = NULL, |
|
| 423 |
Sinv.method = "eigen") {
|
|
| 424 |
# sample size |
|
| 425 | ! |
N <- NROW(Y) |
| 426 | ||
| 427 |
# observed information |
|
| 428 | ! |
observed <- lav_mvreg_information_observed_data( |
| 429 | ! |
Y = Y, eXo = eXo, |
| 430 | ! |
Beta = Beta, res.int = res.int, res.slopes = res.slopes, |
| 431 | ! |
res.cov = res.cov, res.cov.inv = res.cov.inv, |
| 432 | ! |
Sinv.method = Sinv.method |
| 433 |
) |
|
| 434 | ||
| 435 |
# hessian |
|
| 436 | ! |
-N * observed |
| 437 |
} |
|
| 438 | ||
| 439 |
# 4b. hessian logl Beta and vech(res.cov) from samplestats |
|
| 440 |
lav_mvreg_logl_hessian_samplestats <- function(sample.res.int = NULL, |
|
| 441 |
sample.res.slopes = NULL, |
|
| 442 |
sample.res.cov = NULL, |
|
| 443 |
sample.mean.x = NULL, |
|
| 444 |
sample.cov.x = NULL, |
|
| 445 |
sample.nobs = NULL, |
|
| 446 |
Beta = NULL, # int + slopes |
|
| 447 |
res.int = NULL, # intercepts only |
|
| 448 |
res.slopes = NULL, # slopes only (y x x) |
|
| 449 |
res.cov = NULL, # res.cov |
|
| 450 |
Sinv.method = "eigen", |
|
| 451 |
res.cov.inv = NULL) {
|
|
| 452 |
# sample size |
|
| 453 | ! |
N <- sample.nobs |
| 454 | ||
| 455 |
# information |
|
| 456 | ! |
observed <- lav_mvreg_information_observed_samplestats( |
| 457 | ! |
sample.res.int = sample.res.int, sample.res.slopes = sample.res.slopes, |
| 458 | ! |
sample.res.cov = sample.res.cov, sample.mean.x = sample.mean.x, |
| 459 | ! |
sample.cov.x = sample.cov.x, Beta = Beta, res.int = res.int, |
| 460 | ! |
res.slopes = res.slopes, res.cov = res.cov, Sinv.method = Sinv.method, |
| 461 | ! |
res.cov.inv = res.cov.inv |
| 462 |
) |
|
| 463 | ||
| 464 |
# hessian |
|
| 465 | ! |
-N * observed |
| 466 |
} |
|
| 467 | ||
| 468 | ||
| 469 |
# Information h0 |
|
| 470 | ||
| 471 |
# 5a: unit expected information h0 Beta and vech(res.cov) |
|
| 472 |
lav_mvreg_information_expected <- function(Y = NULL, # not used |
|
| 473 |
eXo = NULL, # not used |
|
| 474 |
sample.mean.x = NULL, |
|
| 475 |
sample.cov.x = NULL, |
|
| 476 |
sample.nobs = NULL, |
|
| 477 |
Beta = NULL, # not used |
|
| 478 |
res.int = NULL, # not used |
|
| 479 |
res.slopes = NULL, # not used |
|
| 480 |
res.cov = NULL, |
|
| 481 |
res.cov.inv = NULL, |
|
| 482 |
Sinv.method = "eigen") {
|
|
| 483 | ! |
eXo <- unname(eXo) |
| 484 | ||
| 485 |
# res.cov.inv |
|
| 486 | ! |
if (is.null(res.cov.inv)) {
|
| 487 |
# invert res.cov |
|
| 488 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 489 | ! |
S = res.cov, logdet = FALSE, |
| 490 | ! |
Sinv.method = Sinv.method |
| 491 |
) |
|
| 492 |
} |
|
| 493 | ||
| 494 |
# N |
|
| 495 | ! |
if (is.null(sample.nobs)) {
|
| 496 | ! |
sample.nobs <- nrow(eXo) # hopefully not NULL either |
| 497 |
} else {
|
|
| 498 | ! |
N <- sample.nobs |
| 499 |
} |
|
| 500 | ||
| 501 |
# sample.mean.x + sample.cov.x |
|
| 502 | ! |
if (is.null(sample.mean.x)) {
|
| 503 | ! |
sample.mean.x <- base::.colMeans(eXo, m = NROW(eXo), n = NCOL(eXo)) |
| 504 |
} |
|
| 505 | ! |
if (is.null(sample.cov.x)) {
|
| 506 | ! |
sample.cov.x <- lav_matrix_cov(eXo) |
| 507 |
} |
|
| 508 | ||
| 509 |
# construct sample.xx = 1/N*crossprod(X1) (including intercept) |
|
| 510 | ! |
sample.xx <- rbind( |
| 511 | ! |
cbind(1, matrix(sample.mean.x, nrow = 1, )), |
| 512 | ! |
cbind( |
| 513 | ! |
matrix(sample.mean.x, ncol = 1), |
| 514 | ! |
sample.cov.x + tcrossprod(sample.mean.x) |
| 515 |
) |
|
| 516 |
) |
|
| 517 | ||
| 518 |
# expected information |
|
| 519 | ! |
I11 <- res.cov.inv %x% sample.xx |
| 520 |
# if (lav_use_lavaanC()) {
|
|
| 521 |
# I22 <- lavaanC::m_kronecker_dup_pre_post(res.cov.inv, multiplicator = 0.5) |
|
| 522 |
# } else {
|
|
| 523 | ! |
I22 <- 0.5 * lav_matrix_duplication_pre_post(res.cov.inv %x% res.cov.inv) |
| 524 |
# } |
|
| 525 | ||
| 526 | ! |
lav_matrix_bdiag(I11, I22) |
| 527 |
} |
|
| 528 | ||
| 529 |
# 5b: unit observed information h0 |
|
| 530 |
lav_mvreg_information_observed_data <- function(Y = NULL, |
|
| 531 |
eXo = NULL, # no int |
|
| 532 |
Beta = NULL, # int+slopes |
|
| 533 |
res.int = NULL, |
|
| 534 |
res.slopes = NULL, |
|
| 535 |
res.cov = NULL, |
|
| 536 |
res.cov.inv = NULL, |
|
| 537 |
Sinv.method = "eigen") {
|
|
| 538 |
# create sample statistics |
|
| 539 | ! |
Y <- unname(Y) |
| 540 | ! |
X1 <- cbind(1, unname(eXo)) |
| 541 | ! |
N <- NROW(Y) |
| 542 | ||
| 543 |
# find 'B' |
|
| 544 | ! |
QR <- qr(X1) |
| 545 | ! |
sample.B <- qr.coef(QR, Y) |
| 546 | ||
| 547 | ! |
sample.res.int <- as.numeric(sample.B[1, ]) |
| 548 | ! |
sample.res.slopes <- t(sample.B[-1, , drop = FALSE]) # transpose! |
| 549 | ! |
sample.res.cov <- cov(qr.resid(QR, Y)) * (N - 1) / N |
| 550 | ! |
sample.mean.x <- base::.colMeans(eXo, m = NROW(eXo), n = NCOL(eXo)) |
| 551 | ! |
sample.cov.x <- lav_matrix_cov(eXo) |
| 552 | ||
| 553 | ! |
lav_mvreg_information_observed_samplestats( |
| 554 | ! |
sample.res.int = sample.res.int, |
| 555 | ! |
sample.res.slopes = sample.res.slopes, sample.res.cov = sample.res.cov, |
| 556 | ! |
sample.mean.x = sample.mean.x, sample.cov.x = sample.cov.x, |
| 557 | ! |
Beta = Beta, res.int = res.int, res.slopes = res.slopes, |
| 558 | ! |
res.cov = res.cov, Sinv.method = Sinv.method, res.cov.inv = res.cov.inv |
| 559 |
) |
|
| 560 |
} |
|
| 561 | ||
| 562 | ||
| 563 |
# 5b-bis: observed information h0 from sample statistics |
|
| 564 |
lav_mvreg_information_observed_samplestats <- |
|
| 565 |
function(sample.res.int = NULL, |
|
| 566 |
sample.res.slopes = NULL, |
|
| 567 |
sample.res.cov = NULL, |
|
| 568 |
sample.mean.x = NULL, |
|
| 569 |
sample.cov.x = NULL, |
|
| 570 |
Beta = NULL, # int + slopes |
|
| 571 |
res.int = NULL, # intercepts only |
|
| 572 |
res.slopes = NULL, # slopes only (y x x) |
|
| 573 |
res.cov = NULL, # res.cov |
|
| 574 |
Sinv.method = "eigen", |
|
| 575 |
res.cov.inv = NULL) {
|
|
| 576 |
# construct model-implied Beta |
|
| 577 | ! |
if (is.null(Beta)) {
|
| 578 | ! |
Beta <- rbind(matrix(res.int, nrow = 1), t(res.slopes)) |
| 579 |
} |
|
| 580 | ||
| 581 |
# construct 'saturated' (sample-based) B |
|
| 582 | ! |
sample.B <- rbind(matrix(sample.res.int, nrow = 1), t(sample.res.slopes)) |
| 583 | ||
| 584 |
# construct sample.xx = 1/N*crossprod(X1) (including intercept) |
|
| 585 | ! |
sample.xx <- rbind( |
| 586 | ! |
cbind(1, matrix(sample.mean.x, nrow = 1, )), |
| 587 | ! |
cbind( |
| 588 | ! |
matrix(sample.mean.x, ncol = 1), |
| 589 | ! |
sample.cov.x + tcrossprod(sample.mean.x) |
| 590 |
) |
|
| 591 |
) |
|
| 592 | ||
| 593 |
# W.tilde = S + t(B - Beta) %*% (1/N)*X'X %*% (B - Beta) |
|
| 594 | ! |
W.tilde <- (sample.res.cov + |
| 595 | ! |
t(sample.B - Beta) %*% sample.xx %*% (sample.B - Beta)) |
| 596 | ||
| 597 |
# res.cov.inv |
|
| 598 | ! |
if (is.null(res.cov.inv)) {
|
| 599 |
# invert res.cov |
|
| 600 | ! |
res.cov.inv <- lav_matrix_symmetric_inverse( |
| 601 | ! |
S = res.cov, logdet = FALSE, |
| 602 | ! |
Sinv.method = Sinv.method |
| 603 |
) |
|
| 604 |
} |
|
| 605 | ||
| 606 | ! |
H11 <- res.cov.inv %x% sample.xx |
| 607 | ! |
H21 <- lav_matrix_duplication_pre(res.cov.inv %x% |
| 608 | ! |
(res.cov.inv %*% (crossprod(sample.B - Beta, sample.xx)))) |
| 609 | ! |
H12 <- t(H21) |
| 610 | ||
| 611 | ! |
AAA <- res.cov.inv %*% (2 * W.tilde - res.cov) %*% res.cov.inv |
| 612 |
# if (lav_use_lavaanC()) {
|
|
| 613 |
# H22 <- lavaanC::m_kronecker_dup_pre_post(res.cov.inv, AAA, 0.5) |
|
| 614 |
# } else {
|
|
| 615 | ! |
H22 <- (1 / 2) * lav_matrix_duplication_pre_post(res.cov.inv %x% AAA) |
| 616 |
# } |
|
| 617 | ||
| 618 | ! |
out <- rbind( |
| 619 | ! |
cbind(H11, H12), |
| 620 | ! |
cbind(H21, H22) |
| 621 |
) |
|
| 622 | ! |
out |
| 623 |
} |
|
| 624 | ||
| 625 | ||
| 626 |
# 5c: unit first-order information h0 |
|
| 627 |
lav_mvreg_information_firstorder <- function(Y = NULL, |
|
| 628 |
eXo = NULL, # no int |
|
| 629 |
Beta = NULL, # int+slopes |
|
| 630 |
res.int = NULL, |
|
| 631 |
res.slopes = NULL, |
|
| 632 |
res.cov = NULL, |
|
| 633 |
res.cov.inv = NULL, |
|
| 634 |
Sinv.method = "eigen") {
|
|
| 635 | ! |
N <- NROW(Y) |
| 636 | ||
| 637 |
# scores |
|
| 638 | ! |
SC <- lav_mvreg_scores_beta_vech_sigma( |
| 639 | ! |
Y = Y, eXo = eXo, Beta = Beta, |
| 640 | ! |
res.int = res.int, res.slopes = res.slopes, res.cov = res.cov, |
| 641 | ! |
Sinv.method = Sinv.method, res.cov.inv = res.cov.inv |
| 642 |
) |
|
| 643 | ||
| 644 | ! |
crossprod(SC) / N |
| 645 |
} |
|
| 646 | ||
| 647 | ||
| 648 |
# 6: inverted information h0 |
|
| 649 | ||
| 650 |
# 6a: inverted unit expected information h0 Beta and vech(res.cov) |
|
| 651 |
# |
|
| 652 |
# lav_mvreg_inverted_information_expected <- function(Y = NULL, # unused! |
|
| 653 |
# } |
| 1 |
# `methods' for fitted lavaan objects |
|
| 2 |
# |
|
| 3 |
# standard (S4) methods: |
|
| 4 |
# - show() |
|
| 5 |
# - summary() |
|
| 6 |
# - coef() |
|
| 7 |
# - fitted.values() + fitted() |
|
| 8 |
# - vcov() |
|
| 9 |
# - logLik() |
|
| 10 |
# - nobs() |
|
| 11 |
# - update() |
|
| 12 |
# - anova() |
|
| 13 | ||
| 14 |
# lavaan-specific methods: |
|
| 15 |
# |
|
| 16 |
# - lavParameterEstimates() |
|
| 17 |
# - standardizedSolution() |
|
| 18 |
# - parameterTable() |
|
| 19 |
# - varTable() |
|
| 20 | ||
| 21 | ||
| 22 |
setMethod( |
|
| 23 |
"show", "lavaan", |
|
| 24 |
function(object) {
|
|
| 25 |
# efa? |
|
| 26 | ! |
efa.flag <- object@Options$model.type == "efa" |
| 27 | ||
| 28 |
# show only basic information |
|
| 29 | ! |
res <- lav_object_summary(object, |
| 30 | ! |
fit.measures = FALSE, |
| 31 | ! |
estimates = FALSE, |
| 32 | ! |
modindices = FALSE, |
| 33 | ! |
efa = efa.flag |
| 34 |
) |
|
| 35 | ! |
if (efa.flag) {
|
| 36 |
# print (standardized) loadings only |
|
| 37 | ! |
class(res) <- c("lavaan.efa", "list")
|
| 38 | ! |
print(res) |
| 39 |
} else {
|
|
| 40 |
# print lavaan header |
|
| 41 | ! |
print(res) |
| 42 |
} |
|
| 43 | ! |
invisible(res) |
| 44 |
} |
|
| 45 |
) |
|
| 46 | ||
| 47 |
setMethod( |
|
| 48 |
"summary", "lavaan", |
|
| 49 |
function(object, header = TRUE, |
|
| 50 |
fit.measures = FALSE, |
|
| 51 |
estimates = TRUE, |
|
| 52 |
ci = FALSE, |
|
| 53 |
fmi = FALSE, |
|
| 54 |
standardized = FALSE, |
|
| 55 |
std = standardized, |
|
| 56 |
std.nox = FALSE, # TODO: remove deprecated argument in early 2025 |
|
| 57 |
remove.system.eq = TRUE, |
|
| 58 |
remove.eq = TRUE, |
|
| 59 |
remove.ineq = TRUE, |
|
| 60 |
remove.def = FALSE, |
|
| 61 |
remove.nonfree = FALSE, |
|
| 62 |
remove.step1 = TRUE, |
|
| 63 |
remove.unused = TRUE, |
|
| 64 |
plabel = FALSE, |
|
| 65 |
cov.std = TRUE, |
|
| 66 |
rsquare = FALSE, |
|
| 67 |
baseline.model = NULL, |
|
| 68 |
h1.model = NULL, |
|
| 69 |
fm.args = list( |
|
| 70 |
standard.test = "default", |
|
| 71 |
scaled.test = "default", |
|
| 72 |
rmsea.ci.level = 0.90, |
|
| 73 |
rmsea.h0.closefit = 0.05, |
|
| 74 |
rmsea.h0.notclosefit = 0.08, |
|
| 75 |
robust = TRUE, |
|
| 76 |
cat.check.pd = TRUE |
|
| 77 |
), |
|
| 78 |
modindices = FALSE, |
|
| 79 |
srmr.close.h0 = NULL, |
|
| 80 |
nd = 3L, cutoff = 0.3, dot.cutoff = 0.1, ...) {
|
|
| 81 | 20x |
dotdotdot <- list(...) |
| 82 | 20x |
if (length(dotdotdot) > 0L) {
|
| 83 | ! |
for (j in seq_along(dotdotdot)) {
|
| 84 | ! |
lav_msg_warn(gettextf( |
| 85 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 86 | ! |
sQuote("summary"))
|
| 87 |
) |
|
| 88 |
} |
|
| 89 |
} |
|
| 90 |
# efa? |
|
| 91 | 20x |
efa.flag <- object@Options$model.type == "efa" |
| 92 | ||
| 93 | 20x |
if (is.logical(fit.measures)) {
|
| 94 | 20x |
if (fit.measures) {
|
| 95 | ! |
fit.measures <- "default" |
| 96 |
} else {
|
|
| 97 | 20x |
fit.measures <- "none" |
| 98 |
} |
|
| 99 |
} |
|
| 100 | 20x |
if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures) |
| 101 | 20x |
if (!missing(fm.args)) {
|
| 102 | ! |
lav_deprecated_args("fit.measures", "fm.args")
|
| 103 | ! |
fit.measures <- c(fit.measures, fm.args) |
| 104 |
} |
|
| 105 | 20x |
res <- lav_object_summary( |
| 106 | 20x |
object = object, header = header, |
| 107 | 20x |
fit.measures = fit.measures, estimates = estimates, |
| 108 | 20x |
baseline.model = baseline.model, |
| 109 | 20x |
h1.model = h1.model, |
| 110 | 20x |
ci = ci, fmi = fmi, std = std, standardized = standardized, |
| 111 | 20x |
remove.system.eq = remove.system.eq, |
| 112 | 20x |
remove.eq = remove.eq, remove.ineq = remove.ineq, |
| 113 | 20x |
remove.def = remove.def, remove.nonfree = remove.nonfree, |
| 114 | 20x |
remove.step1 = remove.step1, remove.unused = remove.unused, |
| 115 | 20x |
plabel = plabel, cov.std = cov.std, |
| 116 | 20x |
rsquare = rsquare, efa = efa.flag, |
| 117 | 20x |
modindices = modindices, |
| 118 | 20x |
srmr.close.h0 = srmr.close.h0 |
| 119 |
) |
|
| 120 |
# res has class c("lavaan.summary", "list")
|
|
| 121 | ||
| 122 |
# what about nd? only used if we actually print; save as attribute |
|
| 123 | 20x |
attr(res, "nd") <- nd |
| 124 | ||
| 125 |
# if efa, add cutoff and dot.cutoff, and change class |
|
| 126 | 20x |
if (efa.flag) {
|
| 127 |
# class(res) <- c("lavaan.summary.efa", "list")
|
|
| 128 | ! |
attr(res, "cutoff") <- cutoff |
| 129 | ! |
attr(res, "dot.cutoff") <- dot.cutoff |
| 130 |
} |
|
| 131 | ||
| 132 | 20x |
res |
| 133 |
} |
|
| 134 |
) |
|
| 135 | ||
| 136 | ||
| 137 |
setMethod( |
|
| 138 |
"coef", "lavaan", |
|
| 139 |
function(object, type = "free", labels = TRUE, ...) {
|
|
| 140 | 40x |
dotdotdot <- list(...) |
| 141 | 40x |
if (length(dotdotdot) > 0L) {
|
| 142 | ! |
for (j in seq_along(dotdotdot)) {
|
| 143 | ! |
lav_msg_warn(gettextf( |
| 144 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 145 | ! |
sQuote("coef"))
|
| 146 |
) |
|
| 147 |
} |
|
| 148 |
} |
|
| 149 |
# check object |
|
| 150 | 40x |
object <- lav_object_check_version(object) |
| 151 | ||
| 152 | 40x |
lav_object_inspect_coef( |
| 153 | 40x |
object = object, type = type, |
| 154 | 40x |
add.labels = labels, add.class = TRUE |
| 155 |
) |
|
| 156 |
} |
|
| 157 |
) |
|
| 158 | ||
| 159 |
standardizedSolution <- # nolint |
|
| 160 |
standardizedsolution <- function(object, # nolint |
|
| 161 |
type = "std.all", |
|
| 162 |
se = TRUE, |
|
| 163 |
zstat = TRUE, |
|
| 164 |
pvalue = TRUE, |
|
| 165 |
ci = TRUE, |
|
| 166 |
level = 0.95, |
|
| 167 |
cov.std = TRUE, |
|
| 168 |
remove.eq = TRUE, |
|
| 169 |
remove.ineq = TRUE, |
|
| 170 |
remove.def = FALSE, |
|
| 171 |
partable = NULL, |
|
| 172 |
GLIST = NULL, # nolint |
|
| 173 |
est = NULL, |
|
| 174 |
output = "data.frame") {
|
|
| 175 | ||
| 176 |
# check object |
|
| 177 | 29x |
object <- lav_object_check_version(object) |
| 178 | ||
| 179 |
# check type |
|
| 180 | 29x |
stopifnot(type %in% c("std.all", "std.lv", "std.nox"))
|
| 181 | ||
| 182 |
# check output= argument |
|
| 183 | 29x |
output <- tolower(output) |
| 184 | 29x |
if (output %in% c("data.frame", "table")) {
|
| 185 | 29x |
output <- "data.frame" |
| 186 | ! |
} else if (output %in% c("text", "pretty")) {
|
| 187 | ! |
output <- "text" |
| 188 |
} else {
|
|
| 189 | ! |
lav_msg_stop(gettextf( |
| 190 | ! |
"output must be %s or %s", sQuote("data.frame"), sQuote("text"))
|
| 191 |
) |
|
| 192 |
} |
|
| 193 | ||
| 194 |
# no zstat + pvalue if estimator is Bayes |
|
| 195 | 29x |
if (object@Options$estimator == "Bayes") {
|
| 196 | ! |
zstat <- pvalue <- FALSE |
| 197 |
} |
|
| 198 | ||
| 199 |
# no se if class is not lavaan |
|
| 200 |
# using class() -- can't use inherits(), as this includes blavaan |
|
| 201 | 29x |
if (class(object)[1L] != "lavaan") {
|
| 202 | ! |
if (missing(se) || !se) {
|
| 203 | ! |
se <- FALSE |
| 204 | ! |
zstat <- FALSE |
| 205 | ! |
pvalue <- FALSE |
| 206 |
} |
|
| 207 |
} |
|
| 208 | ||
| 209 | 29x |
if (is.null(partable)) {
|
| 210 | 29x |
tmp.partable <- lavInspect(object, "list") |
| 211 |
} else {
|
|
| 212 | ! |
tmp.partable <- partable |
| 213 |
} |
|
| 214 | 29x |
tmp.list <- tmp.partable[, c("lhs", "op", "rhs", "exo")]
|
| 215 | 29x |
if (!is.null(tmp.partable$group)) {
|
| 216 | 29x |
tmp.list$group <- tmp.partable$group |
| 217 |
} |
|
| 218 | 29x |
if (!is.null(tmp.partable$block)) {
|
| 219 | 29x |
tmp.list$block <- tmp.partable$block |
| 220 |
} |
|
| 221 | 29x |
if (sum(nchar(tmp.partable$label)) != 0L) {
|
| 222 | 9x |
tmp.list$label <- tmp.partable$label |
| 223 |
} |
|
| 224 | ||
| 225 |
# add std and std.all columns |
|
| 226 | 29x |
if (type == "std.lv") {
|
| 227 | ! |
tmp.list$est.std <- lav_standardize_lv(object, |
| 228 | ! |
est = est, GLIST = GLIST, |
| 229 | ! |
partable = partable, cov.std = cov.std |
| 230 |
) |
|
| 231 | 29x |
} else if (type == "std.all") {
|
| 232 | 29x |
tmp.list$est.std <- lav_standardize_all(object, |
| 233 | 29x |
est = est, GLIST = GLIST, |
| 234 | 29x |
partable = partable, cov.std = cov.std |
| 235 |
) |
|
| 236 | ! |
} else if (type == "std.nox") {
|
| 237 | ! |
tmp.list$est.std <- lav_standardize_all_nox(object, |
| 238 | ! |
est = est, GLIST = GLIST, |
| 239 | ! |
partable = partable, cov.std = cov.std |
| 240 |
) |
|
| 241 |
} |
|
| 242 | ||
| 243 | 29x |
if (object@Options$se != "none" && se) {
|
| 244 |
# add 'se' for standardized parameters |
|
| 245 | 29x |
tmp.vcov <- try(lav_object_inspect_vcov(object, |
| 246 | 29x |
standardized = TRUE, |
| 247 | 29x |
type = type, free.only = FALSE, |
| 248 | 29x |
add.labels = FALSE, |
| 249 | 29x |
add.class = FALSE |
| 250 |
)) |
|
| 251 | 29x |
if (inherits(tmp.vcov, "try-error") || is.null(tmp.vcov)) {
|
| 252 | ! |
tmp.list$se <- rep(NA, length(tmp.list$lhs)) |
| 253 | ! |
if (zstat) {
|
| 254 | ! |
tmp.list$z <- rep(NA, length(tmp.list$lhs)) |
| 255 |
} |
|
| 256 | ! |
if (pvalue) {
|
| 257 | ! |
tmp.list$pvalue <- rep(NA, length(tmp.list$lhs)) |
| 258 |
} |
|
| 259 |
} else {
|
|
| 260 | 29x |
tmp <- diag(tmp.vcov) |
| 261 |
# catch negative values |
|
| 262 | 29x |
min.idx <- which(tmp < 0) |
| 263 | 29x |
if (length(min.idx) > 0L) {
|
| 264 | ! |
tmp[min.idx] <- as.numeric(NA) |
| 265 |
} |
|
| 266 |
# now, we can safely take the square root |
|
| 267 | 29x |
tmp <- sqrt(tmp) |
| 268 | ||
| 269 |
# catch near-zero SEs |
|
| 270 | 29x |
zero.idx <- which(tmp < .Machine$double.eps^(1 / 4)) # was 1/2 < 0.6 |
| 271 |
# was 1/3 < 0.6-9 |
|
| 272 | 29x |
if (length(zero.idx) > 0L) {
|
| 273 | 29x |
tmp[zero.idx] <- 0.0 |
| 274 |
} |
|
| 275 | 29x |
tmp.list$se <- tmp |
| 276 | ||
| 277 |
# add 'z' column |
|
| 278 | 29x |
if (zstat) {
|
| 279 | 29x |
tmp.se <- ifelse(tmp.list$se == 0.0, NA, tmp.list$se) |
| 280 | 29x |
tmp.list$z <- tmp.list$est.std / tmp.se |
| 281 |
} |
|
| 282 | 29x |
if (zstat && pvalue) {
|
| 283 | 29x |
tmp.list$pvalue <- 2 * (1 - pnorm(abs(tmp.list$z))) |
| 284 |
} |
|
| 285 |
} |
|
| 286 |
} |
|
| 287 | ||
| 288 |
# simple symmetric confidence interval |
|
| 289 | 29x |
if (se && object@Options$se != "none" && ci) {
|
| 290 |
# next three lines based on confint.lm |
|
| 291 | 29x |
a <- (1 - level) / 2 |
| 292 | 29x |
a <- c(a, 1 - a) |
| 293 | 29x |
fac <- qnorm(a) |
| 294 |
# if(object@Options$se != "bootstrap") {
|
|
| 295 | 29x |
ci <- tmp.list$est.std + tmp.list$se %o% fac |
| 296 |
# } else {
|
|
| 297 |
# ci <- rep(as.numeric(NA), length(tmp.list$est.std)) + |
|
| 298 |
# tmp.list$se %o% fac |
|
| 299 |
# } |
|
| 300 | ||
| 301 | 29x |
tmp.list$ci.lower <- ci[, 1] |
| 302 | 29x |
tmp.list$ci.upper <- ci[, 2] |
| 303 |
} |
|
| 304 | ||
| 305 | ||
| 306 |
# if single group, remove group column |
|
| 307 | 27x |
if (object@Data@ngroups == 1L) tmp.list$group <- NULL |
| 308 | ||
| 309 |
# remove == rows? |
|
| 310 | 29x |
if (remove.eq) {
|
| 311 | 25x |
eq.idx <- which(tmp.list$op == "==") |
| 312 | 25x |
if (length(eq.idx) > 0L) {
|
| 313 | 5x |
tmp.list <- tmp.list[-eq.idx, ] |
| 314 |
} |
|
| 315 |
} |
|
| 316 |
# remove <> rows? |
|
| 317 | 29x |
if (remove.ineq) {
|
| 318 | 25x |
ineq.idx <- which(tmp.list$op %in% c("<", ">"))
|
| 319 | 25x |
if (length(ineq.idx) > 0L) {
|
| 320 | 1x |
tmp.list <- tmp.list[-ineq.idx, ] |
| 321 |
} |
|
| 322 |
} |
|
| 323 |
# remove := rows? |
|
| 324 | 29x |
if (remove.def) {
|
| 325 | ! |
def.idx <- which(tmp.list$op == ":=") |
| 326 | ! |
if (length(def.idx) > 0L) {
|
| 327 | ! |
tmp.list <- tmp.list[-def.idx, ] |
| 328 |
} |
|
| 329 |
} |
|
| 330 | ||
| 331 |
# remove attribute for data order |
|
| 332 | 29x |
attr(tmp.list, "ovda") <- NULL |
| 333 | ||
| 334 | 29x |
if (output == "text") {
|
| 335 | ! |
class(tmp.list) <- c( |
| 336 | ! |
"lavaan.parameterEstimates", "lavaan.data.frame", |
| 337 | ! |
"data.frame" |
| 338 |
) |
|
| 339 |
# tmp.list$exo is needed for printing, don't remove it |
|
| 340 | ! |
attr(tmp.list, "group.label") <- object@Data@group.label |
| 341 | ! |
attr(tmp.list, "level.label") <- object@Data@level.label |
| 342 |
# attr(tmp.list, "header") <- FALSE |
|
| 343 |
} else {
|
|
| 344 | 29x |
tmp.list$exo <- NULL |
| 345 | 29x |
tmp.list$block <- NULL |
| 346 | 29x |
class(tmp.list) <- c("lavaan.data.frame", "data.frame")
|
| 347 |
} |
|
| 348 | ||
| 349 | 29x |
tmp.list |
| 350 |
} |
|
| 351 | ||
| 352 |
lavParameterEstimates <- function(object, # nolint |
|
| 353 |
# select columns |
|
| 354 |
se = TRUE, |
|
| 355 |
zstat = TRUE, |
|
| 356 |
pvalue = TRUE, |
|
| 357 |
ci = TRUE, |
|
| 358 |
standardized = FALSE, |
|
| 359 |
fmi = FALSE, |
|
| 360 |
plabel = FALSE, |
|
| 361 |
# control |
|
| 362 |
level = 0.95, |
|
| 363 |
boot.ci.type = "perc", |
|
| 364 |
cov.std = TRUE, |
|
| 365 |
fmi.options = list(), |
|
| 366 |
# add rows |
|
| 367 |
rsquare = FALSE, |
|
| 368 |
# remove rows |
|
| 369 |
remove.system.eq = TRUE, |
|
| 370 |
remove.eq = TRUE, |
|
| 371 |
remove.ineq = TRUE, |
|
| 372 |
remove.def = FALSE, |
|
| 373 |
remove.nonfree = FALSE, |
|
| 374 |
remove.step1 = TRUE, |
|
| 375 |
remove.unused = FALSE, |
|
| 376 |
# output |
|
| 377 |
add.attributes = FALSE, |
|
| 378 |
output = "data.frame", |
|
| 379 |
header = FALSE) {
|
|
| 380 | ||
| 381 |
# lavaan.fsr? |
|
| 382 | 44x |
if (inherits(object, "lavaan.fsr")) {
|
| 383 | ! |
return(object$PE) |
| 384 |
} |
|
| 385 | ||
| 386 |
# check object |
|
| 387 | 44x |
object <- lav_object_check_version(object) |
| 388 | ||
| 389 |
# deprecated add.attributes (for psycho/blavaan) |
|
| 390 | 44x |
if (add.attributes) {
|
| 391 | ! |
output <- "text" |
| 392 |
} |
|
| 393 | ||
| 394 | ||
| 395 |
# no se if class is not lavaan |
|
| 396 |
# can't use inherits(), as this would return TRUE if object is from blavaan |
|
| 397 | 44x |
if (class(object)[1L] != "lavaan") {
|
| 398 | ! |
if (missing(se) || !se) {
|
| 399 | ! |
se <- FALSE |
| 400 | ! |
zstat <- FALSE |
| 401 | ! |
pvalue <- FALSE |
| 402 |
} |
|
| 403 |
} |
|
| 404 | ||
| 405 |
# check output= argument |
|
| 406 | 44x |
output <- tolower(output) |
| 407 | 44x |
if (output %in% c("data.frame", "table")) {
|
| 408 | 20x |
output <- "data.frame" |
| 409 | 20x |
header <- FALSE |
| 410 | 24x |
} else if (output %in% c("text", "pretty")) {
|
| 411 | 24x |
output <- "text" |
| 412 |
} else {
|
|
| 413 | ! |
lav_msg_stop(gettextf( |
| 414 | ! |
"output must be %s or %s", sQuote("data.frame"), sQuote("text"))
|
| 415 |
) |
|
| 416 |
} |
|
| 417 | ||
| 418 |
# check fmi |
|
| 419 | 44x |
if (fmi) {
|
| 420 | ! |
if (inherits(object, "lavaanList")) {
|
| 421 | ! |
lav_msg_warn(gettext( |
| 422 | ! |
"fmi not available for object of class \"lavaanList\"")) |
| 423 | ! |
fmi <- FALSE |
| 424 |
} |
|
| 425 | ! |
if (object@Options$se != "standard") {
|
| 426 | ! |
lav_msg_warn(gettext( |
| 427 | ! |
"fmi only available if se = \"standard\"")) |
| 428 | ! |
fmi <- FALSE |
| 429 |
} |
|
| 430 | ! |
if (object@Options$estimator != "ML") {
|
| 431 | ! |
lav_msg_warn(gettext( |
| 432 | ! |
"fmi only available if estimator = \"ML\"")) |
| 433 | ! |
fmi <- FALSE |
| 434 |
} |
|
| 435 | ! |
if (!object@SampleStats@missing.flag) {
|
| 436 | ! |
lav_msg_warn(gettext( |
| 437 | ! |
"fmi only available if missing = \"(fi)ml\"")) |
| 438 | ! |
fmi <- FALSE |
| 439 |
} |
|
| 440 | ! |
if (!object@optim$converged) {
|
| 441 | ! |
lav_msg_warn(gettext( |
| 442 | ! |
"fmi not available; model did not converge")) |
| 443 | ! |
fmi <- FALSE |
| 444 |
} |
|
| 445 |
} |
|
| 446 | ||
| 447 |
# no zstat + pvalue if estimator is Bayes |
|
| 448 | 44x |
if (object@Options$estimator == "Bayes") {
|
| 449 | ! |
zstat <- pvalue <- FALSE |
| 450 |
} |
|
| 451 | ||
| 452 | 44x |
tmp.partable <- as.data.frame(object@ParTable, stringsAsFactors = FALSE) |
| 453 | 44x |
tmp.list <- tmp.partable[, c("lhs", "op", "rhs", "free")]
|
| 454 | 44x |
if (!is.null(tmp.partable$user)) {
|
| 455 | 44x |
tmp.list$user <- tmp.partable$user |
| 456 |
} |
|
| 457 | 44x |
if (!is.null(tmp.partable$block)) {
|
| 458 | 44x |
tmp.list$block <- tmp.partable$block |
| 459 |
} else {
|
|
| 460 | ! |
tmp.list$block <- rep(1L, length(tmp.list$lhs)) |
| 461 |
} |
|
| 462 | 44x |
if (!is.null(tmp.partable$level)) {
|
| 463 | 2x |
tmp.list$level <- tmp.partable$level |
| 464 |
} else {
|
|
| 465 | 42x |
tmp.list$level <- rep(1L, length(tmp.list$lhs)) |
| 466 |
} |
|
| 467 | 44x |
if (!is.null(tmp.partable$group)) {
|
| 468 | 44x |
tmp.list$group <- tmp.partable$group |
| 469 |
} else {
|
|
| 470 | ! |
tmp.list$group <- rep(1L, length(tmp.list$lhs)) |
| 471 |
} |
|
| 472 | 44x |
if (!is.null(tmp.partable$step)) {
|
| 473 | ! |
tmp.list$step <- tmp.partable$step |
| 474 |
} |
|
| 475 | 44x |
if (!is.null(tmp.partable$efa)) {
|
| 476 | 4x |
tmp.list$efa <- tmp.partable$efa |
| 477 |
} |
|
| 478 | 44x |
if (!is.null(tmp.partable$label)) {
|
| 479 | 44x |
tmp.list$label <- tmp.partable$label |
| 480 |
} else {
|
|
| 481 | ! |
tmp.list$label <- rep("", length(tmp.list$lhs))
|
| 482 |
} |
|
| 483 | 44x |
if (!is.null(tmp.partable$exo)) {
|
| 484 | 44x |
tmp.list$exo <- tmp.partable$exo |
| 485 |
} else {
|
|
| 486 | ! |
tmp.list$exo <- rep(0L, length(tmp.list$lhs)) |
| 487 |
} |
|
| 488 | 44x |
if (inherits(object, "lavaanList")) {
|
| 489 |
# per default: nothing! |
|
| 490 |
# if("partable" %in% object@meta$store.slots) {
|
|
| 491 |
# COF <- sapply(object@ParTableList, "[[", "est") |
|
| 492 |
# tmp.list$est <- rowMeans(COF) |
|
| 493 |
# } |
|
| 494 | ! |
tmp.list$est <- NULL |
| 495 | 44x |
} else if (!is.null(tmp.partable$est)) {
|
| 496 | 44x |
tmp.list$est <- tmp.partable$est |
| 497 |
} else {
|
|
| 498 | ! |
tmp.list$est <- lav_model_get_parameters(object@Model, |
| 499 | ! |
type = "user", |
| 500 | ! |
extra = TRUE |
| 501 |
) |
|
| 502 |
} |
|
| 503 | 44x |
if (!is.null(tmp.partable$lower)) {
|
| 504 | 4x |
tmp.list$lower <- tmp.partable$lower |
| 505 |
} |
|
| 506 | 44x |
if (!is.null(tmp.partable$upper)) {
|
| 507 | 4x |
tmp.list$upper <- tmp.partable$upper |
| 508 |
} |
|
| 509 | ||
| 510 | ||
| 511 |
# add se, zstat, pvalue |
|
| 512 | 44x |
if (se && object@Options$se != "none") {
|
| 513 | 44x |
tmp.list$se <- lav_object_inspect_se(object) |
| 514 |
# handle tiny SEs |
|
| 515 | 44x |
tmp.list$se <- ifelse(tmp.list$se < sqrt(.Machine$double.eps), |
| 516 | 44x |
0, tmp.list$se |
| 517 |
) |
|
| 518 | 44x |
tmp.se <- ifelse(tmp.list$se < sqrt(.Machine$double.eps), NA, tmp.list$se) |
| 519 | 44x |
if (zstat) {
|
| 520 | 44x |
tmp.list$z <- tmp.list$est / tmp.se |
| 521 | 44x |
if (pvalue) {
|
| 522 | 44x |
tmp.list$pvalue <- 2 * (1 - pnorm(abs(tmp.list$z))) |
| 523 |
# remove p-value if bounds have been used |
|
| 524 | 44x |
if (!is.null(tmp.partable$lower)) {
|
| 525 | 4x |
b.idx <- which(abs(tmp.partable$lower - tmp.partable$est) < |
| 526 | 4x |
sqrt(.Machine$double.eps) & |
| 527 | 4x |
tmp.partable$free > 0L) |
| 528 | 4x |
if (length(b.idx) > 0L) {
|
| 529 | ! |
tmp.list$pvalue[b.idx] <- as.numeric(NA) |
| 530 |
} |
|
| 531 |
} |
|
| 532 | 44x |
if (!is.null(tmp.partable$upper)) {
|
| 533 | 4x |
b.idx <- which(abs(tmp.partable$upper - tmp.partable$est) < |
| 534 | 4x |
sqrt(.Machine$double.eps) & |
| 535 | 4x |
tmp.partable$free > 0L) |
| 536 | 4x |
if (length(b.idx) > 0L) {
|
| 537 | ! |
tmp.list$pvalue[b.idx] <- as.numeric(NA) |
| 538 |
} |
|
| 539 |
} |
|
| 540 |
} |
|
| 541 |
} |
|
| 542 |
} |
|
| 543 | ||
| 544 |
# extract bootstrap data (if any) |
|
| 545 | 44x |
if (object@Options$se == "bootstrap" || |
| 546 | 44x |
"bootstrap" %in% object@Options$test || |
| 547 | 44x |
"bollen.stine" %in% object@Options$test) {
|
| 548 | ! |
tmp.boot <- lav_object_inspect_boot(object) |
| 549 | ! |
bootstrap.seed <- attr(tmp.boot, "seed") # for bca |
| 550 | ! |
error.idx <- attr(tmp.boot, "error.idx") |
| 551 | ! |
if (length(error.idx) > 0L) {
|
| 552 | ! |
tmp.boot <- tmp.boot[-error.idx, , drop = FALSE] # drops attributes |
| 553 |
} |
|
| 554 |
} else {
|
|
| 555 | 44x |
tmp.boot <- NULL |
| 556 |
} |
|
| 557 | ||
| 558 | 44x |
bootstrap.successful <- NROW(tmp.boot) # should be zero if NULL |
| 559 | ||
| 560 |
# confidence interval |
|
| 561 | 44x |
if (se && object@Options$se != "none" && ci) {
|
| 562 |
# next three lines based on confint.lm |
|
| 563 | 20x |
a <- (1 - level) / 2 |
| 564 | 20x |
a <- c(a, 1 - a) |
| 565 | 20x |
if (object@Options$se != "bootstrap") {
|
| 566 | 20x |
fac <- qnorm(a) |
| 567 | 20x |
ci <- tmp.list$est + tmp.list$se %o% fac |
| 568 | ! |
} else if (object@Options$se == "bootstrap") {
|
| 569 |
# local copy of 'norm.inter' from boot package (not exported!) |
|
| 570 | ! |
norm.inter <- function(t, alpha) {
|
| 571 | ! |
t <- t[is.finite(t)] |
| 572 | ! |
tmp.r <- length(t) |
| 573 | ! |
rk <- (tmp.r + 1) * alpha |
| 574 | ! |
if (!all(rk > 1 & rk < tmp.r)) {
|
| 575 | ! |
lav_msg_warn(gettext("extreme order statistics used as endpoints"))
|
| 576 |
} |
|
| 577 | ! |
k <- trunc(rk) |
| 578 | ! |
inds <- seq_along(k) |
| 579 | ! |
out <- inds |
| 580 | ! |
kvs <- k[k > 0 & k < tmp.r] |
| 581 | ! |
tstar <- sort(t, partial = sort(union(c(1, tmp.r), c(kvs, kvs + 1)))) |
| 582 | ! |
ints <- (k == rk) |
| 583 | ! |
if (any(ints)) out[inds[ints]] <- tstar[k[inds[ints]]] |
| 584 | ! |
out[k == 0] <- tstar[1L] |
| 585 | ! |
out[k == tmp.r] <- tstar[tmp.r] |
| 586 | ! |
not <- function(v) xor(rep(TRUE, length(v)), v) |
| 587 | ! |
temp <- inds[not(ints) & k != 0 & k != tmp.r] |
| 588 | ! |
temp1 <- qnorm(alpha[temp]) |
| 589 | ! |
temp2 <- qnorm(k[temp] / (tmp.r + 1)) |
| 590 | ! |
temp3 <- qnorm((k[temp] + 1) / (tmp.r + 1)) |
| 591 | ! |
tk <- tstar[k[temp]] |
| 592 | ! |
tk1 <- tstar[k[temp] + 1L] |
| 593 | ! |
out[temp] <- tk + (temp1 - temp2) / (temp3 - temp2) * (tk1 - tk) |
| 594 | ! |
cbind(round(rk, 2), out) |
| 595 |
} |
|
| 596 | ||
| 597 | ! |
stopifnot(!is.null(tmp.boot)) |
| 598 | ! |
stopifnot(boot.ci.type %in% c( |
| 599 | ! |
"norm", "basic", "perc", |
| 600 | ! |
"bca.simple", "bca" |
| 601 |
)) |
|
| 602 | ! |
if (boot.ci.type == "norm") {
|
| 603 | ! |
fac <- qnorm(a) |
| 604 | ! |
boot.x <- colMeans(tmp.boot, na.rm = TRUE) |
| 605 | ! |
boot.est <- |
| 606 | ! |
lav_model_get_parameters(object@Model, |
| 607 | ! |
GLIST = lav_model_x2glist(object@Model, boot.x), |
| 608 | ! |
type = "user", extra = TRUE |
| 609 |
) |
|
| 610 | ! |
bias.est <- (boot.est - tmp.list$est) |
| 611 | ! |
ci <- (tmp.list$est - bias.est) + tmp.list$se %o% fac |
| 612 | ! |
} else if (boot.ci.type == "basic") {
|
| 613 | ! |
ci <- cbind(tmp.list$est, tmp.list$est) |
| 614 | ! |
alpha <- (1 + c(level, -level)) / 2 |
| 615 | ||
| 616 |
# free.idx only |
|
| 617 | ! |
qq <- apply(tmp.boot, 2, norm.inter, alpha) |
| 618 | ! |
free.idx <- which(object@ParTable$free & |
| 619 | ! |
!duplicated(object@ParTable$free)) |
| 620 | ! |
ci[free.idx, ] <- 2 * ci[free.idx, ] - t(qq[c(3, 4), ]) |
| 621 | ||
| 622 |
# def.idx |
|
| 623 | ! |
def.idx <- which(object@ParTable$op == ":=") |
| 624 | ! |
if (length(def.idx) > 0L) {
|
| 625 | ! |
boot.def <- apply(tmp.boot, 1, object@Model@def.function) |
| 626 | ! |
if (length(def.idx) == 1L) {
|
| 627 | ! |
boot.def <- as.matrix(boot.def) |
| 628 |
} else {
|
|
| 629 | ! |
boot.def <- t(boot.def) |
| 630 |
} |
|
| 631 | ! |
qq <- apply(boot.def, 2, norm.inter, alpha) |
| 632 | ! |
ci[def.idx, ] <- 2 * ci[def.idx, ] - t(qq[c(3, 4), ]) |
| 633 |
} |
|
| 634 | ||
| 635 |
# TODO: add cin/ceq? |
|
| 636 | ! |
} else if (boot.ci.type == "perc") {
|
| 637 | ! |
ci <- cbind(tmp.list$est, tmp.list$est) |
| 638 | ! |
alpha <- (1 + c(-level, level)) / 2 |
| 639 | ||
| 640 |
# free.idx only |
|
| 641 | ! |
qq <- apply(tmp.boot, 2, norm.inter, alpha) |
| 642 | ! |
free.idx <- which(object@ParTable$free & |
| 643 | ! |
!duplicated(object@ParTable$free)) |
| 644 | ! |
ci[free.idx, ] <- t(qq[c(3, 4), ]) |
| 645 | ||
| 646 |
# def.idx |
|
| 647 | ! |
def.idx <- which(object@ParTable$op == ":=") |
| 648 | ! |
if (length(def.idx) > 0L) {
|
| 649 | ! |
boot.def <- apply(tmp.boot, 1, object@Model@def.function) |
| 650 | ! |
if (length(def.idx) == 1L) {
|
| 651 | ! |
boot.def <- as.matrix(boot.def) |
| 652 |
} else {
|
|
| 653 | ! |
boot.def <- t(boot.def) |
| 654 |
} |
|
| 655 | ! |
qq <- apply(boot.def, 2, norm.inter, alpha) |
| 656 | ! |
def.idx <- which(object@ParTable$op == ":=") |
| 657 | ! |
ci[def.idx, ] <- t(qq[c(3, 4), ]) |
| 658 |
} |
|
| 659 | ||
| 660 |
# TODO: add cin/ceq? |
|
| 661 | ! |
} else if (boot.ci.type == "bca.simple") {
|
| 662 |
# no adjustment for scale!! only bias!! |
|
| 663 | ! |
alpha <- (1 + c(-level, level)) / 2 |
| 664 | ! |
zalpha <- qnorm(alpha) |
| 665 | ! |
ci <- cbind(tmp.list$est, tmp.list$est) |
| 666 | ||
| 667 |
# free.idx only |
|
| 668 | ! |
free.idx <- which(object@ParTable$free & |
| 669 | ! |
!duplicated(object@ParTable$free)) |
| 670 | ! |
x <- tmp.list$est[free.idx] |
| 671 | ! |
for (i in seq_along(free.idx)) {
|
| 672 | ! |
t <- tmp.boot[, i] |
| 673 | ! |
t <- t[is.finite(t)] |
| 674 | ! |
t0 <- x[i] |
| 675 |
# check if we have variance (perhaps constrained to 0?) |
|
| 676 |
# new in 0.6-3 |
|
| 677 | ! |
if (var(t) == 0) {
|
| 678 | ! |
next |
| 679 |
} |
|
| 680 | ! |
w <- qnorm(sum(t < t0) / length(t)) |
| 681 | ! |
a <- 0.0 #### !!! #### |
| 682 | ! |
adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha))) |
| 683 | ! |
qq <- norm.inter(t, adj.alpha) |
| 684 | ! |
ci[free.idx[i], ] <- qq[, 2] |
| 685 |
} |
|
| 686 | ||
| 687 |
# def.idx |
|
| 688 | ! |
def.idx <- which(object@ParTable$op == ":=") |
| 689 | ! |
if (length(def.idx) > 0L) {
|
| 690 | ! |
x.def <- object@Model@def.function(x) |
| 691 | ! |
boot.def <- apply(tmp.boot, 1, object@Model@def.function) |
| 692 | ! |
if (length(def.idx) == 1L) {
|
| 693 | ! |
boot.def <- as.matrix(boot.def) |
| 694 |
} else {
|
|
| 695 | ! |
boot.def <- t(boot.def) |
| 696 |
} |
|
| 697 | ! |
for (i in seq_along(def.idx)) {
|
| 698 | ! |
t <- boot.def[, i] |
| 699 | ! |
t <- t[is.finite(t)] |
| 700 | ! |
t0 <- x.def[i] |
| 701 | ! |
w <- qnorm(sum(t < t0) / length(t)) |
| 702 | ! |
a <- 0.0 #### !!! #### |
| 703 | ! |
adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha))) |
| 704 | ! |
qq <- norm.inter(t, adj.alpha) |
| 705 | ! |
ci[def.idx[i], ] <- qq[, 2] |
| 706 |
} |
|
| 707 |
} |
|
| 708 | ||
| 709 |
# TODO: |
|
| 710 |
# - add cin/ceq |
|
| 711 | ! |
} else if (boot.ci.type == "bca") { # new in 0.6-12
|
| 712 |
# we assume that the 'ordinary' (nonparametric) was used |
|
| 713 | ||
| 714 | ! |
lavoptions <- object@Options |
| 715 | ! |
nobs <- object@SampleStats@nobs |
| 716 | ! |
ntotal <- object@SampleStats@ntotal |
| 717 | ||
| 718 |
# we need enough bootstrap runs |
|
| 719 | ! |
if (nrow(tmp.boot) < ntotal) {
|
| 720 | ! |
lav_msg_stop(gettextf( |
| 721 | ! |
"BCa confidence intervals require more (successful) bootstrap runs |
| 722 | ! |
(%1$s) than the number of observations (%2$s).", |
| 723 | ! |
nrow(tmp.boot), ntotal)) |
| 724 |
} |
|
| 725 | ||
| 726 |
# does not work with sampling weights (yet) |
|
| 727 | ! |
if (!is.null(object@Data@weights[[1]])) {
|
| 728 | ! |
lav_msg_stop( |
| 729 | ! |
gettext("BCa confidence intervals not available in
|
| 730 | ! |
the presence of sampling weights.")) |
| 731 |
} |
|
| 732 | ||
| 733 |
# check if we have a seed |
|
| 734 | ! |
if (is.null(bootstrap.seed)) {
|
| 735 | ! |
lav_msg_stop(gettext("seed not available in tmp.boot object."))
|
| 736 |
} |
|
| 737 | ||
| 738 |
# compute 'X' matrix with frequency indices (to compute |
|
| 739 |
# the empirical influence values using regression) |
|
| 740 | ! |
tmp.freq <- lav_bootstrap_indices( |
| 741 | ! |
R = lavoptions$bootstrap, |
| 742 | ! |
nobs = nobs, parallel = lavoptions$parallel[1], |
| 743 | ! |
ncpus = lavoptions$ncpus, cl = lavoptions[["cl"]], |
| 744 | ! |
iseed = bootstrap.seed, return.freq = TRUE, |
| 745 | ! |
merge.groups = TRUE |
| 746 |
) |
|
| 747 | ! |
if (length(error.idx) > 0L) {
|
| 748 | ! |
tmp.freq <- tmp.freq[-error.idx, , drop = FALSE] |
| 749 |
} |
|
| 750 | ! |
stopifnot(nrow(tmp.freq) == nrow(tmp.boot)) |
| 751 | ||
| 752 |
# compute empirical influence values (using regression) |
|
| 753 |
# remove first column per group |
|
| 754 | ! |
first.idx <- sapply(object@Data@case.idx, "[[", 1L) |
| 755 | ! |
tmp.lm <- lm.fit(x = cbind(1, tmp.freq[, -first.idx]), y = tmp.boot) |
| 756 | ! |
tmp.beta <- unname(tmp.lm$coefficients)[-1, , drop = FALSE] |
| 757 | ! |
tmp.ll <- rbind(0, tmp.beta) |
| 758 | ||
| 759 |
# compute 'a' for all parameters at once |
|
| 760 | ! |
tmp.aa <- apply(tmp.ll, 2L, function(x) {
|
| 761 | ! |
tmp.l <- x - mean(x) |
| 762 | ! |
sum(tmp.l^3) / (6 * sum(tmp.l^2)^1.5) |
| 763 |
}) |
|
| 764 | ||
| 765 |
# adjustment for both bias AND scale |
|
| 766 | ! |
alpha <- (1 + c(-level, level)) / 2 |
| 767 | ! |
zalpha <- qnorm(alpha) |
| 768 | ! |
ci <- cbind(tmp.list$est, tmp.list$est) |
| 769 | ||
| 770 |
# free.idx only |
|
| 771 | ! |
free.idx <- which(object@ParTable$free & |
| 772 | ! |
!duplicated(object@ParTable$free)) |
| 773 | ! |
stopifnot(length(free.idx) == ncol(tmp.boot)) |
| 774 | ! |
x <- tmp.list$est[free.idx] |
| 775 | ! |
for (i in seq_along(free.idx)) {
|
| 776 | ! |
t <- tmp.boot[, i] |
| 777 | ! |
t <- t[is.finite(t)] |
| 778 | ! |
t0 <- x[i] |
| 779 |
# check if we have variance (perhaps constrained to 0?) |
|
| 780 |
# new in 0.6-3 |
|
| 781 | ! |
if (var(t) == 0) {
|
| 782 | ! |
next |
| 783 |
} |
|
| 784 | ! |
w <- qnorm(sum(t < t0) / length(t)) |
| 785 | ! |
a <- tmp.aa[i] |
| 786 | ! |
adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha))) |
| 787 | ! |
qq <- norm.inter(t, adj.alpha) |
| 788 | ! |
ci[free.idx[i], ] <- qq[, 2] |
| 789 |
} |
|
| 790 | ||
| 791 |
# def.idx |
|
| 792 | ! |
def.idx <- which(object@ParTable$op == ":=") |
| 793 | ! |
if (length(def.idx) > 0L) {
|
| 794 | ! |
x.def <- object@Model@def.function(x) |
| 795 | ! |
boot.def <- apply(tmp.boot, 1, object@Model@def.function) |
| 796 | ! |
if (length(def.idx) == 1L) {
|
| 797 | ! |
boot.def <- as.matrix(boot.def) |
| 798 |
} else {
|
|
| 799 | ! |
boot.def <- t(boot.def) |
| 800 |
} |
|
| 801 | ||
| 802 |
# recompute empirical influence values |
|
| 803 | ! |
tmp.lm <- lm.fit(x = cbind(1, tmp.freq[, -1]), y = boot.def) |
| 804 | ! |
tmp.beta <- unname(tmp.lm$coefficients)[-1, , drop = FALSE] |
| 805 | ! |
tmp.ll <- rbind(0, tmp.beta) |
| 806 | ||
| 807 |
# compute 'a' values for all def.idx parameters |
|
| 808 | ! |
tmp.aa <- apply(tmp.ll, 2L, function(x) {
|
| 809 | ! |
tmp.l <- x - mean(x) |
| 810 | ! |
sum(tmp.l^3) / (6 * sum(tmp.l^2)^1.5) |
| 811 |
}) |
|
| 812 | ||
| 813 |
# compute bca ci |
|
| 814 | ! |
for (i in seq_along(def.idx)) {
|
| 815 | ! |
t <- boot.def[, i] |
| 816 | ! |
t <- t[is.finite(t)] |
| 817 | ! |
t0 <- x.def[i] |
| 818 | ! |
w <- qnorm(sum(t < t0) / length(t)) |
| 819 | ! |
a <- tmp.aa[i] |
| 820 | ! |
adj.alpha <- pnorm(w + (w + zalpha) / (1 - a * (w + zalpha))) |
| 821 | ! |
qq <- norm.inter(t, adj.alpha) |
| 822 | ! |
ci[def.idx[i], ] <- qq[, 2] |
| 823 |
} |
|
| 824 |
} |
|
| 825 | ||
| 826 |
# TODO: |
|
| 827 |
# - add cin/ceq |
|
| 828 |
} |
|
| 829 |
} |
|
| 830 | ||
| 831 | 20x |
tmp.list$ci.lower <- ci[, 1] |
| 832 | 20x |
tmp.list$ci.upper <- ci[, 2] |
| 833 |
} |
|
| 834 | ||
| 835 |
# standardized estimates? |
|
| 836 |
# 28 March 2024: TDJ adds option to select specific types |
|
| 837 | 44x |
if (is.logical(standardized)) {
|
| 838 | 44x |
if (standardized) {
|
| 839 | ! |
standardized <- c("std.lv", "std.all")
|
| 840 | ! |
if (length(lav_object_vnames(object, "ov.x")) && object@Options$fixed.x) {
|
| 841 | ! |
standardized <- c(standardized, "std.nox") |
| 842 |
} |
|
| 843 |
} else {
|
|
| 844 | 44x |
standardized <- character(0) |
| 845 |
} # corresponds to standardized=FALSE |
|
| 846 |
} else {
|
|
| 847 |
# !is.logical(standardized) |
|
| 848 | ! |
standardized <- tolower(as.character(standardized)) |
| 849 | ! |
if ("std.nox" %in% standardized) {
|
| 850 |
# sanity checks |
|
| 851 | ! |
if (length(lav_object_vnames(object, "ov.x")) == 0) {
|
| 852 | ! |
lav_msg_note(gettext( |
| 853 | ! |
"`std.nox' unavailable without fixed exogenous predictors")) |
| 854 | ! |
standardized <- setdiff(standardized, "std.nox") |
| 855 | ! |
} else if (!object@Options$fixed.x) {
|
| 856 | ! |
lav_msg_note(gettext("`std.nox' unavailable when fixed.x = FALSE"))
|
| 857 | ! |
standardized <- setdiff(standardized, "std.nox") |
| 858 |
} |
|
| 859 |
} |
|
| 860 |
} |
|
| 861 |
# Then add each requested type |
|
| 862 |
# (original source code, but now independently conditional) |
|
| 863 | 44x |
if ("std.lv" %in% standardized) {
|
| 864 | ! |
tmp.list$std.lv <- lav_standardize_lv(object, cov.std = cov.std) |
| 865 |
} |
|
| 866 | 44x |
if ("std.all" %in% standardized) {
|
| 867 | ! |
tmp.list$std.all <- lav_standardize_all(object, |
| 868 | ! |
est.std = tmp.list$est.std, |
| 869 | ! |
cov.std = cov.std |
| 870 |
) |
|
| 871 |
} |
|
| 872 | 44x |
if ("std.nox" %in% standardized) {
|
| 873 | ! |
tmp.list$std.nox <- lav_standardize_all_nox(object, |
| 874 | ! |
est.std = tmp.list$est.std, |
| 875 | ! |
cov.std = cov.std |
| 876 |
) |
|
| 877 |
} |
|
| 878 | ||
| 879 |
# rsquare? |
|
| 880 | 44x |
if (rsquare) {
|
| 881 | ! |
r2 <- lavTech(object, "rsquare", add.labels = TRUE) |
| 882 | ! |
tmp.names <- unlist(lapply(r2, names)) |
| 883 | ! |
nel <- length(tmp.names) |
| 884 | ! |
if (nel == 0L) {
|
| 885 | ! |
lav_msg_warn( |
| 886 | ! |
gettext("rsquare = TRUE, but there are no dependent variables"))
|
| 887 |
} else {
|
|
| 888 | ! |
if (lav_partable_nlevels(tmp.list) == 1L) {
|
| 889 | ! |
block <- rep(seq_along(r2), sapply(r2, length)) |
| 890 | ! |
first.block.idx <- which(!duplicated(tmp.list$block) & |
| 891 | ! |
tmp.list$block > 0L) |
| 892 | ! |
gval <- tmp.list$group[first.block.idx] |
| 893 | ! |
if (length(gval) > 0L) {
|
| 894 | ! |
group <- rep(gval, sapply(r2, length)) |
| 895 |
} else {
|
|
| 896 |
# single block, single group |
|
| 897 | ! |
group <- rep(1L, length(block)) |
| 898 |
} |
|
| 899 | ! |
r2 <- data.frame( |
| 900 | ! |
lhs = tmp.names, op = rep("r2", nel),
|
| 901 | ! |
rhs = tmp.names, block = block, group = group, |
| 902 | ! |
est = unlist(r2), stringsAsFactors = FALSE |
| 903 |
) |
|
| 904 |
} else {
|
|
| 905 |
# add level column |
|
| 906 | ! |
block <- rep(seq_along(r2), sapply(r2, length)) |
| 907 | ! |
first.block.idx <- which(!duplicated(tmp.list$block) & |
| 908 | ! |
tmp.list$block > 0L) |
| 909 |
# always at least two blocks |
|
| 910 | ! |
gval <- tmp.list$group[first.block.idx] |
| 911 | ! |
group <- rep(gval, sapply(r2, length)) |
| 912 | ! |
lval <- tmp.list$level[first.block.idx] |
| 913 | ! |
level <- rep(lval, sapply(r2, length)) |
| 914 | ! |
r2 <- data.frame( |
| 915 | ! |
lhs = tmp.names, op = rep("r2", nel),
|
| 916 | ! |
rhs = tmp.names, |
| 917 | ! |
block = block, group = group, |
| 918 | ! |
level = level, |
| 919 | ! |
est = unlist(r2), stringsAsFactors = FALSE |
| 920 |
) |
|
| 921 |
} |
|
| 922 |
# add step column if needed |
|
| 923 | ! |
if (!is.null(tmp.list$step)) {
|
| 924 | ! |
r2$step <- 2L # per default |
| 925 |
# simplification: we assume that only the |
|
| 926 |
# observed indicators of latent variables are step 1 |
|
| 927 | ! |
ov.ind <- unlist(object@pta$vnames$ov.ind) |
| 928 | ! |
step1.idx <- which(r2$lhs %in% ov.ind) |
| 929 | ! |
r2$step[step1.idx] <- 1L |
| 930 |
} |
|
| 931 | ! |
tmp.list <- lav_partable_merge(pt1 = tmp.list, pt2 = r2, warn = FALSE) |
| 932 |
} |
|
| 933 |
} |
|
| 934 | ||
| 935 |
# fractional missing information (if estimator="fiml") |
|
| 936 | 44x |
if (fmi) {
|
| 937 | ! |
se.orig <- tmp.list$se |
| 938 | ||
| 939 |
# new in 0.6-6, use 'EM' based (unstructured) sample statistics |
|
| 940 |
# otherwise, it would be as if we use expected info, while the |
|
| 941 |
# original use observed, producing crazy results |
|
| 942 | ! |
if (object@Data@ngroups > 1L) {
|
| 943 | ! |
em.cov <- lapply(lavInspect(object, "sampstat.h1"), "[[", "cov") |
| 944 | ! |
em.mean <- lapply(lavInspect(object, "sampstat.h1"), "[[", "mean") |
| 945 |
} else {
|
|
| 946 | ! |
em.cov <- lavInspect(object, "sampstat.h1")$cov |
| 947 | ! |
em.mean <- lavInspect(object, "sampstat.h1")$mean |
| 948 |
} |
|
| 949 | ||
| 950 | ! |
tmp.pt <- parTable(object) |
| 951 | ! |
tmp.pt$ustart <- tmp.pt$est |
| 952 | ! |
tmp.pt$start <- tmp.pt$est <- NULL |
| 953 | ||
| 954 | ! |
this.options <- object@Options |
| 955 | ! |
if (!is.null(fmi.options) && is.list(fmi.options)) {
|
| 956 |
# modify original options |
|
| 957 | ! |
this.options <- modifyList(this.options, fmi.options) |
| 958 |
} |
|
| 959 |
# override |
|
| 960 | ! |
this.options$optim.method <- "none" |
| 961 | ! |
this.options$sample.cov.rescale <- FALSE |
| 962 | ! |
this.options$check.gradient <- FALSE |
| 963 | ! |
this.options$baseline <- FALSE |
| 964 | ! |
this.options$h1 <- FALSE |
| 965 | ! |
this.options$test <- FALSE |
| 966 | ||
| 967 | ! |
fit.complete <- lavaan( |
| 968 | ! |
model = tmp.pt, |
| 969 | ! |
sample.cov = em.cov, |
| 970 | ! |
sample.mean = em.mean, |
| 971 | ! |
sample.nobs = lavInspect(object, "nobs"), |
| 972 | ! |
slotOptions = this.options |
| 973 |
) |
|
| 974 | ||
| 975 | ! |
se.comp <- lavParameterEstimates(fit.complete, |
| 976 | ! |
ci = FALSE, fmi = FALSE, |
| 977 | ! |
zstat = FALSE, pvalue = FALSE, remove.system.eq = FALSE, |
| 978 | ! |
remove.eq = FALSE, remove.ineq = FALSE, |
| 979 | ! |
remove.def = FALSE, remove.nonfree = FALSE, remove.unused = FALSE, |
| 980 | ! |
rsquare = rsquare, add.attributes = FALSE |
| 981 | ! |
)$se |
| 982 | ||
| 983 | ! |
se.comp <- ifelse(se.comp == 0.0, as.numeric(NA), se.comp) |
| 984 | ! |
tmp.list$fmi <- 1 - (se.comp * se.comp) / (se.orig * se.orig) |
| 985 |
} |
|
| 986 | ||
| 987 |
# if single level, remove level column |
|
| 988 | 42x |
if (object@Data@nlevels == 1L) tmp.list$level <- NULL |
| 989 | ||
| 990 |
# if single group, remove group column |
|
| 991 | 40x |
if (object@Data@ngroups == 1L) tmp.list$group <- NULL |
| 992 | ||
| 993 |
# if single everything, remove block column |
|
| 994 | 44x |
if (object@Data@nlevels == 1L && |
| 995 | 44x |
object@Data@ngroups == 1L) {
|
| 996 | 40x |
tmp.list$block <- NULL |
| 997 |
} |
|
| 998 | ||
| 999 |
# if no user-defined labels, remove label column |
|
| 1000 | 44x |
if (sum(nchar(object@ParTable$label)) == 0L) {
|
| 1001 | 26x |
tmp.list$label <- NULL |
| 1002 |
} |
|
| 1003 | ||
| 1004 |
# if plabel = TRUE, add it (new in 0.6-20) |
|
| 1005 | 44x |
if (plabel) {
|
| 1006 | ! |
if (!is.null(tmp.partable$plabel)) {
|
| 1007 | ! |
tmp.list$plabel <- tmp.partable$plabel |
| 1008 |
} else {
|
|
| 1009 | ! |
if (!is.null(tmp.partable$id)) {
|
| 1010 | ! |
tmp.list$plabel <- paste(".p", tmp.list$id, ".", sep = "")
|
| 1011 |
} else {
|
|
| 1012 | ! |
tmp.list$plabel <- paste(".p", seq_along(tmp.list$plabel),
|
| 1013 | ! |
".", sep = "") |
| 1014 |
} |
|
| 1015 |
} |
|
| 1016 |
} |
|
| 1017 | ||
| 1018 |
# remove non-free parameters? (but keep ==, >, < and :=) |
|
| 1019 | 44x |
if (remove.nonfree) {
|
| 1020 | ! |
nonfree.idx <- which(tmp.list$free == 0L & |
| 1021 | ! |
!tmp.list$op %in% c("==", ">", "<", ":="))
|
| 1022 | ! |
if (length(nonfree.idx) > 0L) {
|
| 1023 | ! |
tmp.list <- tmp.list[-nonfree.idx, ] |
| 1024 |
} |
|
| 1025 |
} |
|
| 1026 | ||
| 1027 |
# remove 'unused' parameters |
|
| 1028 |
# these are parameters that are automatically added (user == 0), |
|
| 1029 |
# but with their final (est) values fixed to their default values |
|
| 1030 |
# (typically 1 or 0). |
|
| 1031 |
# currently only intercepts and scaling-factors (for now) |
|
| 1032 |
# should we also remove fixed-to-1 variances? (parameterization = theta)? |
|
| 1033 | 44x |
if (remove.unused) {
|
| 1034 |
# intercepts |
|
| 1035 | 24x |
int.idx <- which(tmp.list$op == "~1" & |
| 1036 | 24x |
tmp.list$user == 0L & |
| 1037 | 24x |
tmp.list$free == 0L & |
| 1038 | 24x |
tmp.list$est == 0) |
| 1039 | 24x |
if (length(int.idx) > 0L) {
|
| 1040 | 6x |
tmp.list <- tmp.list[-int.idx, ] |
| 1041 |
} |
|
| 1042 | ||
| 1043 |
# scaling factors |
|
| 1044 | 24x |
scaling.idx <- which(tmp.list$op == "~*~" & |
| 1045 | 24x |
tmp.list$user == 0L & |
| 1046 | 24x |
tmp.list$free == 0L & |
| 1047 | 24x |
tmp.list$est == 1) |
| 1048 | 24x |
if (length(scaling.idx) > 0L) {
|
| 1049 | 1x |
tmp.list <- tmp.list[-scaling.idx, ] |
| 1050 |
} |
|
| 1051 |
} |
|
| 1052 | ||
| 1053 | ||
| 1054 |
# remove 'free' column |
|
| 1055 | 44x |
tmp.list$free <- NULL |
| 1056 | ||
| 1057 |
# remove == rows? |
|
| 1058 | 44x |
if (remove.eq) {
|
| 1059 | 44x |
eq.idx <- which(tmp.list$op == "==" & tmp.list$user == 1L) |
| 1060 | 44x |
if (length(eq.idx) > 0L) {
|
| 1061 | ! |
tmp.list <- tmp.list[-eq.idx, ] |
| 1062 |
} |
|
| 1063 |
} |
|
| 1064 | 44x |
if (remove.system.eq) {
|
| 1065 | 44x |
eq.idx <- which(tmp.list$op == "==" & tmp.list$user != 1L) |
| 1066 | 44x |
if (length(eq.idx) > 0L) {
|
| 1067 | 10x |
tmp.list <- tmp.list[-eq.idx, ] |
| 1068 |
} |
|
| 1069 |
} |
|
| 1070 |
# remove <> rows? |
|
| 1071 | 44x |
if (remove.ineq) {
|
| 1072 | 44x |
ineq.idx <- which(tmp.list$op %in% c("<", ">"))
|
| 1073 | 44x |
if (length(ineq.idx) > 0L) {
|
| 1074 | 2x |
tmp.list <- tmp.list[-ineq.idx, ] |
| 1075 |
} |
|
| 1076 |
} |
|
| 1077 |
# remove := rows? |
|
| 1078 | 44x |
if (remove.def) {
|
| 1079 | ! |
def.idx <- which(tmp.list$op == ":=") |
| 1080 | ! |
if (length(def.idx) > 0L) {
|
| 1081 | ! |
tmp.list <- tmp.list[-def.idx, ] |
| 1082 |
} |
|
| 1083 |
} |
|
| 1084 | ||
| 1085 |
# remove step 1 rows? |
|
| 1086 | 44x |
if (remove.step1 && !is.null(tmp.list$step)) {
|
| 1087 | ! |
step1.idx <- which(tmp.list$step == 1L) |
| 1088 | ! |
if (length(step1.idx) > 0L) {
|
| 1089 | ! |
tmp.list <- tmp.list[-step1.idx, ] |
| 1090 |
} |
|
| 1091 |
# remove step column |
|
| 1092 | ! |
tmp.list$step <- NULL |
| 1093 |
} |
|
| 1094 | ||
| 1095 |
# remove attribute for data order |
|
| 1096 | 44x |
attr(tmp.list, "ovda") <- NULL |
| 1097 | ||
| 1098 |
# remove tmp.list$user |
|
| 1099 | 44x |
tmp.list$user <- NULL |
| 1100 | ||
| 1101 | 44x |
if (output == "text") {
|
| 1102 | 24x |
class(tmp.list) <- c( |
| 1103 | 24x |
"lavaan.parameterEstimates", "lavaan.data.frame", |
| 1104 | 24x |
"data.frame" |
| 1105 |
) |
|
| 1106 | 24x |
if (header) {
|
| 1107 | 24x |
attr(tmp.list, "categorical") <- object@Model@categorical |
| 1108 | 24x |
attr(tmp.list, "parameterization") <- object@Model@parameterization |
| 1109 | 24x |
attr(tmp.list, "information") <- object@Options$information[1] |
| 1110 | 24x |
attr(tmp.list, "information.meat") <- object@Options$information.meat |
| 1111 | 24x |
attr(tmp.list, "se") <- object@Options$se |
| 1112 | 24x |
attr(tmp.list, "group.label") <- object@Data@group.label |
| 1113 | 24x |
attr(tmp.list, "level.label") <- object@Data@level.label |
| 1114 | 24x |
attr(tmp.list, "bootstrap") <- object@Options$bootstrap |
| 1115 | 24x |
attr(tmp.list, "bootstrap.successful") <- bootstrap.successful |
| 1116 | 24x |
attr(tmp.list, "missing") <- object@Options$missing |
| 1117 | 24x |
attr(tmp.list, "observed.information") <- |
| 1118 | 24x |
object@Options$observed.information[1] |
| 1119 | 24x |
attr(tmp.list, "h1.information") <- object@Options$h1.information[1] |
| 1120 | 24x |
attr(tmp.list, "h1.information.meat") <- |
| 1121 | 24x |
object@Options$h1.information.meat |
| 1122 | 24x |
attr(tmp.list, "header") <- header |
| 1123 |
# FIXME: add more!! |
|
| 1124 |
} |
|
| 1125 |
} else {
|
|
| 1126 | 20x |
tmp.list$exo <- NULL |
| 1127 | 20x |
tmp.list$lower <- tmp.list$upper <- NULL |
| 1128 | 20x |
class(tmp.list) <- c("lavaan.data.frame", "data.frame")
|
| 1129 |
} |
|
| 1130 | ||
| 1131 | 44x |
tmp.list |
| 1132 |
} |
|
| 1133 |
parameterEstimates <- lavParameterEstimates # synonym # nolint |
|
| 1134 | ||
| 1135 |
parameterTable <- parametertable <- parTable <- partable <- # nolint |
|
| 1136 |
function(object) {
|
|
| 1137 |
# check object |
|
| 1138 | 91x |
object <- lav_object_check_version(object) |
| 1139 | ||
| 1140 |
# convert to data.frame |
|
| 1141 | 91x |
out <- as.data.frame(object@ParTable, stringsAsFactors = FALSE) |
| 1142 | ||
| 1143 | 91x |
class(out) <- c("lavaan.data.frame", "data.frame")
|
| 1144 | 91x |
out |
| 1145 |
} |
|
| 1146 | ||
| 1147 |
varTable <- vartable <- function(object, ov.names = names(object), # nolint |
|
| 1148 |
ov.names.x = NULL, |
|
| 1149 |
ordered = NULL, factor = NULL, |
|
| 1150 |
as.data.frame. = TRUE) { # nolint
|
|
| 1151 | ||
| 1152 | 20x |
if (inherits(object, "lavaan")) {
|
| 1153 |
# check object |
|
| 1154 | 20x |
object <- lav_object_check_version(object) |
| 1155 | 20x |
tmp.var <- object@Data@ov |
| 1156 | ! |
} else if (inherits(object, "lavData")) {
|
| 1157 | ! |
tmp.var <- object@ov |
| 1158 | ! |
} else if (inherits(object, "data.frame")) {
|
| 1159 | ! |
tmp.var <- lav_dataframe_vartable( |
| 1160 | ! |
frame = object, ov.names = ov.names, |
| 1161 | ! |
ov.names.x = ov.names.x, |
| 1162 | ! |
ordered = ordered, factor = factor, |
| 1163 | ! |
as.data.frame. = FALSE |
| 1164 |
) |
|
| 1165 |
} else {
|
|
| 1166 | ! |
lav_msg_stop(gettext("object must of class lavaan or a data.frame"))
|
| 1167 |
} |
|
| 1168 | ||
| 1169 | 20x |
if (as.data.frame.) {
|
| 1170 | 20x |
tmp.var <- as.data.frame(tmp.var, |
| 1171 | 20x |
stringsAsFactors = FALSE, |
| 1172 | 20x |
row.names = seq_along(tmp.var$name) |
| 1173 |
) |
|
| 1174 | 20x |
class(tmp.var) <- c("lavaan.data.frame", "data.frame")
|
| 1175 |
} |
|
| 1176 | ||
| 1177 | 20x |
tmp.var |
| 1178 |
} |
|
| 1179 | ||
| 1180 | ||
| 1181 |
setMethod( |
|
| 1182 |
"fitted.values", "lavaan", |
|
| 1183 |
function(object, type = "moments", labels = TRUE, ...) {
|
|
| 1184 | 44x |
dotdotdot <- list(...) |
| 1185 | 44x |
if (length(dotdotdot) > 0L) {
|
| 1186 | ! |
for (j in seq_along(dotdotdot)) {
|
| 1187 | ! |
lav_msg_warn(gettextf( |
| 1188 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 1189 | ! |
sQuote("fitted.values"))
|
| 1190 |
) |
|
| 1191 |
} |
|
| 1192 |
} |
|
| 1193 |
# lowercase type |
|
| 1194 | 44x |
type <- tolower(type) |
| 1195 | ||
| 1196 |
# check object |
|
| 1197 | 44x |
object <- lav_object_check_version(object) |
| 1198 | ||
| 1199 |
# catch type="casewise" |
|
| 1200 | 44x |
if (type %in% c("casewise", "case", "obs", "observations", "ov")) {
|
| 1201 | ! |
return(lavPredict(object, type = "ov", label = labels)) |
| 1202 |
} |
|
| 1203 | ||
| 1204 | 44x |
lav_object_inspect_implied(object, |
| 1205 | 44x |
add.labels = labels, add.class = TRUE, |
| 1206 | 44x |
drop.list.single.group = TRUE |
| 1207 |
) |
|
| 1208 |
} |
|
| 1209 |
) |
|
| 1210 | ||
| 1211 | ||
| 1212 |
setMethod( |
|
| 1213 |
"fitted", "lavaan", |
|
| 1214 |
function(object, type = "moments", labels = TRUE, ...) {
|
|
| 1215 | 24x |
dotdotdot <- list(...) |
| 1216 | 24x |
if (length(dotdotdot) > 0L) {
|
| 1217 | ! |
for (j in seq_along(dotdotdot)) {
|
| 1218 | ! |
lav_msg_warn(gettextf( |
| 1219 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 1220 | ! |
sQuote("fitted"))
|
| 1221 |
) |
|
| 1222 |
} |
|
| 1223 |
} |
|
| 1224 | 24x |
fitted.values(object, type = type, labels = labels) |
| 1225 |
} |
|
| 1226 |
) |
|
| 1227 | ||
| 1228 |
setMethod( |
|
| 1229 |
"vcov", "lavaan", |
|
| 1230 |
function(object, type = "free", labels = TRUE, remove.duplicated = FALSE, |
|
| 1231 |
standardized = NULL, free.only = TRUE, ...) {
|
|
| 1232 | 20x |
dotdotdot <- list(...) |
| 1233 | 20x |
if (length(dotdotdot) > 0L) {
|
| 1234 | ! |
for (j in seq_along(dotdotdot)) {
|
| 1235 | ! |
lav_msg_warn(gettextf( |
| 1236 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 1237 | ! |
sQuote("vcov"))
|
| 1238 |
) |
|
| 1239 |
} |
|
| 1240 |
} |
|
| 1241 |
# check object |
|
| 1242 | 20x |
object <- lav_object_check_version(object) |
| 1243 | ||
| 1244 |
# check for convergence first! |
|
| 1245 | 20x |
if (object@optim$npar > 0L && !object@optim$converged) {
|
| 1246 | ! |
lav_msg_stop(gettext("model did not converge"))
|
| 1247 |
} |
|
| 1248 | ||
| 1249 | 20x |
if (object@Options$se == "none") {
|
| 1250 | ! |
lav_msg_stop(gettext("vcov not available if se=\"none\""))
|
| 1251 |
} |
|
| 1252 | ||
| 1253 |
## verify there are any user-defined parameters |
|
| 1254 |
#FIXME? smarter to check @ParTable for $op == ":="? |
|
| 1255 | 20x |
if (is.null(formals(object@Model@def.function))) {
|
| 1256 | 19x |
type <- "free" # avoids error in lav_object_inspect_vcov_def() |
| 1257 |
} |
|
| 1258 | ||
| 1259 | 20x |
if (!is.null(standardized)) {
|
| 1260 | ! |
standardized <- tolower(standardized[1]) |
| 1261 | ! |
stopifnot(standardized %in% c("std.lv","std.all","std.nox"))
|
| 1262 |
} |
|
| 1263 | ||
| 1264 | 20x |
if (type == "user" || type == "joint" || type == "all" || type == "full" || |
| 1265 | 20x |
type == "complete") {
|
| 1266 | ! |
if (remove.duplicated) {
|
| 1267 | ! |
lav_msg_stop(gettext( |
| 1268 | ! |
"argument \"remove.duplicated\" not supported if type = \"user\"" |
| 1269 |
)) |
|
| 1270 |
} |
|
| 1271 | ! |
tmp.varcov <- lav_object_inspect_vcov_def(object, |
| 1272 | ! |
joint = TRUE, |
| 1273 | ! |
standardized = !is.null(standardized), |
| 1274 | ! |
type = ifelse(is.null(standardized), "std.all", standardized), |
| 1275 | ! |
add.labels = labels, |
| 1276 | ! |
add.class = TRUE |
| 1277 |
) |
|
| 1278 | 20x |
} else if (type == "free") {
|
| 1279 | 20x |
tmp.varcov <- lav_object_inspect_vcov(object, |
| 1280 | 20x |
standardized = !is.null(standardized), |
| 1281 | 20x |
type = ifelse(is.null(standardized), "std.all", standardized), |
| 1282 | 20x |
free.only = free.only, |
| 1283 | 20x |
add.labels = labels, |
| 1284 | 20x |
add.class = TRUE, |
| 1285 | 20x |
remove.duplicated = remove.duplicated |
| 1286 |
) |
|
| 1287 |
} else {
|
|
| 1288 | ! |
lav_msg_stop(gettext("type argument should be \"user\" or \"free\""))
|
| 1289 |
} |
|
| 1290 | ||
| 1291 | 20x |
tmp.varcov |
| 1292 |
} |
|
| 1293 |
) |
|
| 1294 | ||
| 1295 | ||
| 1296 |
# logLik (so that we can use the default AIC/BIC functions from stats4( |
|
| 1297 |
setMethod( |
|
| 1298 |
"logLik", "lavaan", |
|
| 1299 |
function(object, ...) {
|
|
| 1300 | 120x |
dotdotdot <- list(...) |
| 1301 | 120x |
if (length(dotdotdot) > 0L) {
|
| 1302 | ! |
for (j in seq_along(dotdotdot)) {
|
| 1303 | ! |
lav_msg_warn(gettextf( |
| 1304 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 1305 | ! |
sQuote("logLik"))
|
| 1306 |
) |
|
| 1307 |
} |
|
| 1308 |
} |
|
| 1309 |
# check object |
|
| 1310 | 120x |
object <- lav_object_check_version(object) |
| 1311 | ||
| 1312 | 120x |
if (object@Options$estimator != "ML") {
|
| 1313 | 15x |
lav_msg_warn(gettext("logLik only available if estimator is ML"))
|
| 1314 |
} |
|
| 1315 | 120x |
if (object@optim$npar > 0L && !object@optim$converged) {
|
| 1316 | ! |
lav_msg_warn(gettext("model did not converge"))
|
| 1317 |
} |
|
| 1318 | ||
| 1319 |
# new in 0.6-1: we use the @loglik slot (instead of fitMeasures) |
|
| 1320 | 120x |
tmp.logl <- object@loglik |
| 1321 | 120x |
logl <- tmp.logl$loglik |
| 1322 | 120x |
attr(logl, "df") <- tmp.logl$npar ### note: must be npar, not df!! |
| 1323 | 120x |
attr(logl, "nobs") <- tmp.logl$ntotal |
| 1324 | 120x |
class(logl) <- "logLik" |
| 1325 | 120x |
logl |
| 1326 |
} |
|
| 1327 |
) |
|
| 1328 | ||
| 1329 |
# nobs |
|
| 1330 |
if (!exists("nobs", envir = asNamespace("stats4"))) {
|
|
| 1331 |
setGeneric("nobs", function(object, ...) standardGeneric("nobs"))
|
|
| 1332 |
} |
|
| 1333 |
setMethod( |
|
| 1334 |
"nobs", signature(object = "lavaan"), |
|
| 1335 |
function(object, ...) {
|
|
| 1336 | 3x |
dotdotdot <- list(...) |
| 1337 | 3x |
if (length(dotdotdot) > 0L) {
|
| 1338 | ! |
for (j in seq_along(dotdotdot)) {
|
| 1339 | ! |
lav_msg_warn(gettextf( |
| 1340 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 1341 | ! |
sQuote("nobs"))
|
| 1342 |
) |
|
| 1343 |
} |
|
| 1344 |
} |
|
| 1345 | 3x |
object@SampleStats@ntotal |
| 1346 |
} |
|
| 1347 |
) |
|
| 1348 | ||
| 1349 |
# see: src/library/stats/R/update.R |
|
| 1350 |
setMethod( |
|
| 1351 |
"update", signature(object = "lavaan"), |
|
| 1352 |
function(object, model, add, ..., evaluate = TRUE) {
|
|
| 1353 |
# check object |
|
| 1354 | 20x |
object <- lav_object_check_version(object) |
| 1355 | ||
| 1356 | 20x |
call <- object@call |
| 1357 | 20x |
if (is.null(call)) {
|
| 1358 | ! |
lav_msg_stop(gettext("need an object with call slot"))
|
| 1359 |
} |
|
| 1360 | ||
| 1361 | 20x |
extras <- match.call(expand.dots = FALSE)$... |
| 1362 | ||
| 1363 | 20x |
if (!missing(model)) {
|
| 1364 |
# call$formula <- update.formula(formula(object), formula.) |
|
| 1365 | ! |
call$model <- model |
| 1366 | 20x |
} else if (exists(as.character(call$model))) {
|
| 1367 | ! |
call$model <- eval(call$model, parent.frame()) |
| 1368 | 20x |
} else if (is.character(call$model)) {
|
| 1369 |
## do nothing |
|
| 1370 |
## call$model <- call$model |
|
| 1371 |
} else {
|
|
| 1372 | ! |
call$model <- parTable(object) |
| 1373 | ! |
call$model$est <- NULL |
| 1374 | ! |
call$model$se <- NULL |
| 1375 |
} |
|
| 1376 | 20x |
if (!is.null(call$slotParTable) && is.list(call$model)) {
|
| 1377 | ! |
call$slotParTable <- call$model |
| 1378 |
} |
|
| 1379 | ||
| 1380 | 20x |
if (length(extras) > 0) {
|
| 1381 |
## check for call$slotOptions conflicts |
|
| 1382 | 20x |
if (!is.null(call$slotOptions)) {
|
| 1383 | ! |
same.names <- intersect(names(lavOptions()), names(extras)) |
| 1384 | ! |
for (i in same.names) {
|
| 1385 | ! |
call$slotOptions[[i]] <- extras[[i]] |
| 1386 | ! |
extras[i] <- NULL # not needed if they are in slotOptions |
| 1387 |
} |
|
| 1388 |
} |
|
| 1389 | 20x |
existing <- !is.na(match(names(extras), names(call))) |
| 1390 | ! |
for (a in names(extras)[existing]) call[[a]] <- extras[[a]] |
| 1391 | 20x |
if (any(!existing)) {
|
| 1392 | 20x |
call <- c(as.list(call), extras[!existing]) |
| 1393 | 20x |
call <- as.call(call) |
| 1394 |
} |
|
| 1395 |
} |
|
| 1396 | ||
| 1397 | 20x |
if (missing(add) && !evaluate) {
|
| 1398 | ! |
return(call) |
| 1399 |
} |
|
| 1400 |
## for any of the other 3 scenarios, we need the updated fit |
|
| 1401 | ||
| 1402 |
## Check if "add" and "model" are both strings; combine them |
|
| 1403 | 20x |
if (missing(add)) {
|
| 1404 | 20x |
add.allready.in.partable <- TRUE # because nothing to add |
| 1405 |
} else {
|
|
| 1406 | ! |
if (is.character(add) && is.character(call$model)) {
|
| 1407 | ! |
call$model <- c(call$model, add) |
| 1408 | ! |
add.allready.in.partable <- TRUE |
| 1409 |
} else {
|
|
| 1410 | ! |
add.allready.in.partable <- FALSE |
| 1411 |
} |
|
| 1412 |
} |
|
| 1413 | 20x |
newfit <- eval(call, parent.frame()) |
| 1414 | 20x |
if (add.allready.in.partable && evaluate) {
|
| 1415 | 20x |
return(newfit) |
| 1416 |
} |
|
| 1417 | ||
| 1418 |
## only remaining situations: "add" exists, but either "add" or "model" |
|
| 1419 |
## is a parameter table, so update the parameter table in the call |
|
| 1420 | ! |
if (!(mode(add) %in% c("list", "character"))) {
|
| 1421 | ! |
lav_msg_stop( |
| 1422 | ! |
gettext("'add' argument must be model syntax or parameter table.
|
| 1423 | ! |
See ?lav_model_partable help page.") |
| 1424 |
) |
|
| 1425 |
} |
|
| 1426 | ! |
tmp.pt <- lav_object_extended(newfit, add = add)@ParTable |
| 1427 | ! |
tmp.pt$user <- NULL # get rid of "10" category used in lavTestScore() |
| 1428 |
## group == 0L in new rows |
|
| 1429 | ! |
tmp.pt$group[tmp.pt$group == 0L] <- tmp.pt$block[tmp.pt$group == 0L] |
| 1430 |
# tmp.pt$plabel == "" in new rows. Consequences? |
|
| 1431 | ! |
tmp.pt$est <- NULL |
| 1432 | ! |
tmp.pt$se <- NULL |
| 1433 | ! |
call$model <- tmp.pt |
| 1434 | ||
| 1435 | ! |
if (evaluate) {
|
| 1436 | ! |
eval(call, parent.frame()) |
| 1437 |
} else {
|
|
| 1438 | ! |
call |
| 1439 |
} |
|
| 1440 |
} |
|
| 1441 |
) |
|
| 1442 | ||
| 1443 |
setMethod( |
|
| 1444 |
"anova", signature(object = "lavaan"), |
|
| 1445 |
function(object, ...) {
|
|
| 1446 |
# NOTE: if we add additional arguments, it is not the same generic |
|
| 1447 |
# anova() function anymore, and match.call will be screwed up |
|
| 1448 | ||
| 1449 |
# NOTE: we need to extract the names of the models from match.call here, |
|
| 1450 |
# otherwise, we loose them in the call stack |
|
| 1451 | ||
| 1452 | 20x |
mcall <- match.call(expand.dots = TRUE) |
| 1453 | 20x |
dots <- list(...) |
| 1454 | ||
| 1455 | 20x |
modp <- if (length(dots)) {
|
| 1456 | ! |
sapply(dots, inherits, "lavaan") |
| 1457 |
} else {
|
|
| 1458 | 20x |
logical(0) |
| 1459 |
} |
|
| 1460 | 20x |
tmp.names <- sapply(as.list(mcall)[c(FALSE, TRUE, modp)], deparse) |
| 1461 | ||
| 1462 | 20x |
lavTestLRT(object = object, ..., model.names = tmp.names) |
| 1463 |
} |
|
| 1464 |
) |
| 1 |
# YR 21 March 2015 |
|
| 2 |
# new approach to compute 'Gamma': the asymptotic variance matrix of |
|
| 3 |
# sqrt{N} times the
|
|
| 4 |
# observed sample statistics (means + varcov) |
|
| 5 |
# |
|
| 6 |
# Gamma = N x ACOV[ ybar, vech(S) ] |
|
| 7 |
# = NACOV[ ybar, vech(S) ] |
|
| 8 |
# |
|
| 9 |
# - one single function for mean + cov |
|
| 10 |
# - handle 'fixed.x' exogenous covariates |
|
| 11 | ||
| 12 | ||
| 13 |
# - YR 3 Dec 2015: allow for conditional.x = TRUE |
|
| 14 |
# - YR 22 Jan 2023: add model.based= argument (if object is lavaan object) |
|
| 15 |
# - YR 30 May 2024: add lav_samplestats_cor_Gamma(_NT) |
|
| 16 | ||
| 17 |
# generic public function (not exported yet) |
|
| 18 |
# input for lavGamma can be lavobject, lavdata, data.frame, or matrix |
|
| 19 |
lavGamma <- function(object, group = NULL, missing = "listwise", |
|
| 20 |
ov.names.x = NULL, fixed.x = FALSE, conditional.x = FALSE, |
|
| 21 |
meanstructure = FALSE, slopestructure = FALSE, |
|
| 22 |
gamma.n.minus.one = FALSE, gamma.unbiased = FALSE, |
|
| 23 |
ADF = TRUE, model.based = FALSE, NT.rescale = FALSE, |
|
| 24 |
Mplus.WLS = FALSE, add.labels = FALSE) {
|
|
| 25 |
# check object |
|
| 26 | ||
| 27 |
# 1. object is lavaan object |
|
| 28 | ! |
if (inherits(object, "lavaan")) {
|
| 29 | ! |
object <- lav_object_check_version(object) |
| 30 | ! |
lav_object_gamma( |
| 31 | ! |
lavobject = object, ADF = ADF, |
| 32 | ! |
model.based = model.based, Mplus.WLS = Mplus.WLS |
| 33 |
) |
|
| 34 | ! |
} else if (inherits(object, "lavData")) {
|
| 35 | ! |
lavdata <- object |
| 36 | ! |
model.based <- FALSE |
| 37 | ! |
} else if (inherits(object, "data.frame") || |
| 38 | ! |
inherits(object, "matrix")) {
|
| 39 | ! |
model.based <- FALSE |
| 40 | ! |
NAMES <- names(object) |
| 41 | ! |
if (!is.null(NAMES) && !is.null(group)) {
|
| 42 | ! |
NAMES <- NAMES[-match(group, NAMES)] |
| 43 |
} |
|
| 44 | ! |
lavdata <- lav_lavdata( |
| 45 | ! |
data = object, group = group, |
| 46 | ! |
ov.names = NAMES, ordered = NULL, |
| 47 | ! |
ov.names.x = ov.names.x, |
| 48 | ! |
lavoptions = list( |
| 49 | ! |
warn = FALSE, |
| 50 | ! |
missing = missing |
| 51 |
) |
|
| 52 |
) |
|
| 53 |
} else {
|
|
| 54 | ! |
lav_msg_stop( |
| 55 | ! |
gettextf("lavGamma can not handle objects of class %s",
|
| 56 | ! |
lav_msg_view(class(object))) |
| 57 |
) |
|
| 58 |
} |
|
| 59 | ||
| 60 |
# extract data |
|
| 61 | ! |
Y <- lavdata@X |
| 62 | ! |
if (conditional.x) {
|
| 63 | ! |
eXo <- lavdata@eXo |
| 64 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 65 | ! |
Y[[g]] <- cbind(Y[[g]], eXo[[g]]) |
| 66 |
} |
|
| 67 |
} |
|
| 68 | ||
| 69 |
# x.idx |
|
| 70 | ! |
x.idx <- lapply( |
| 71 | ! |
seq_len(lavdata@ngroups), |
| 72 | ! |
function(g) {
|
| 73 | ! |
match( |
| 74 | ! |
lavdata@ov.names.x[[g]], |
| 75 | ! |
lavdata@ov.names[[g]] |
| 76 |
) |
|
| 77 |
} |
|
| 78 |
) |
|
| 79 | ||
| 80 | ! |
OUT <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 81 | ! |
if (length(lavdata@cluster) > 0L) {
|
| 82 | ! |
cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
| 83 |
} else {
|
|
| 84 | ! |
cluster.idx <- NULL |
| 85 |
} |
|
| 86 | ! |
if (ADF) {
|
| 87 | ! |
out <- lav_samplestats_Gamma( |
| 88 | ! |
Y = Y[[g]], |
| 89 | ! |
Mu = NULL, |
| 90 | ! |
Sigma = NULL, |
| 91 | ! |
x.idx = x.idx[[g]], |
| 92 | ! |
cluster.idx = cluster.idx, |
| 93 | ! |
fixed.x = fixed.x, |
| 94 | ! |
conditional.x = conditional.x, |
| 95 | ! |
meanstructure = meanstructure, |
| 96 | ! |
slopestructure = conditional.x, |
| 97 | ! |
gamma.n.minus.one = gamma.n.minus.one, |
| 98 | ! |
unbiased = gamma.unbiased, |
| 99 | ! |
Mplus.WLS = Mplus.WLS |
| 100 |
) |
|
| 101 |
} else {
|
|
| 102 | ! |
out <- lav_samplestats_Gamma_NT( |
| 103 | ! |
Y = Y[[g]], |
| 104 | ! |
wt = NULL, # for now |
| 105 | ! |
rescale = NT.rescale, |
| 106 | ! |
x.idx = x.idx[[g]], |
| 107 | ! |
fixed.x = fixed.x, |
| 108 | ! |
conditional.x = conditional.x, |
| 109 | ! |
meanstructure = meanstructure, |
| 110 | ! |
slopestructure = conditional.x |
| 111 |
) |
|
| 112 |
} |
|
| 113 | ! |
out |
| 114 |
}) |
|
| 115 | ||
| 116 |
# todo: labels |
|
| 117 | ||
| 118 | ! |
OUT |
| 119 |
} |
|
| 120 | ||
| 121 | ||
| 122 | ||
| 123 |
# for internal use -- lavobject or internal slots |
|
| 124 |
lav_object_gamma <- function(lavobject = NULL, |
|
| 125 |
# or individual slots |
|
| 126 |
lavdata = NULL, |
|
| 127 |
lavoptions = NULL, |
|
| 128 |
lavsamplestats = NULL, |
|
| 129 |
lavh1 = NULL, |
|
| 130 |
lavimplied = NULL, |
|
| 131 |
# other options |
|
| 132 |
ADF = TRUE, model.based = FALSE, |
|
| 133 |
Mplus.WLS = FALSE) {
|
|
| 134 |
# extract slots |
|
| 135 | 3x |
if (!is.null(lavobject)) {
|
| 136 | 3x |
lavdata <- lavobject@Data |
| 137 | 3x |
lavoptions <- lavobject@Options |
| 138 | 3x |
lavsamplestats <- lavobject@SampleStats |
| 139 | 3x |
lavh1 <- lavobject@h1 |
| 140 | 3x |
lavimplied <- lavobject@implied |
| 141 |
} |
|
| 142 | ||
| 143 | 3x |
missing <- lavoptions$missing |
| 144 | 3x |
if (!missing %in% c("listwise", "pairwise")) {
|
| 145 | ! |
model.based <- TRUE |
| 146 |
} |
|
| 147 | 3x |
fixed.x <- lavoptions$fixed.x |
| 148 | 3x |
conditional.x <- lavoptions$conditional.x |
| 149 | 3x |
meanstructure <- lavoptions$meanstructure |
| 150 | 3x |
gamma.n.minus.one <- lavoptions$gamma.n.minus.one |
| 151 | 3x |
gamma.unbiased <- lavoptions$gamma.unbiased |
| 152 | ||
| 153 | 3x |
if (ADF && model.based && conditional.x) {
|
| 154 | ! |
lav_msg_stop(gettext( |
| 155 | ! |
"ADF + model.based + conditional.x is not supported yet.")) |
| 156 |
} |
|
| 157 | ||
| 158 |
# output container |
|
| 159 | 3x |
OUT <- vector("list", length = lavdata@ngroups)
|
| 160 | ||
| 161 |
# compute Gamma matrix for each group |
|
| 162 | 3x |
for (g in seq_len(lavdata@ngroups)) {
|
| 163 | 4x |
x.idx <- lavsamplestats@x.idx[[g]] |
| 164 | 4x |
COV <- MEAN <- NULL |
| 165 | 4x |
if (!ADF || model.based) {
|
| 166 | ! |
implied <- lavh1$implied # saturated/unstructured |
| 167 | ! |
if (model.based) {
|
| 168 | ! |
implied <- lavimplied # model-based/structured |
| 169 |
} |
|
| 170 | ! |
if (conditional.x) {
|
| 171 |
# convert to joint COV/MEAN |
|
| 172 | ! |
res.S <- implied$res.cov[[g]] |
| 173 | ! |
res.slopes <- implied$res.slopes[[g]] |
| 174 | ! |
res.int <- implied$res.int[[g]] |
| 175 | ! |
S.xx <- implied$cov.x[[g]] |
| 176 | ! |
M.x <- implied$mean.x[[g]] |
| 177 | ||
| 178 | ! |
S.yy <- res.S + res.slopes %*% S.xx %*% t(res.slopes) |
| 179 | ! |
S.yx <- res.slopes %*% S.xx |
| 180 | ! |
S.xy <- S.xx %*% t(res.slopes) |
| 181 | ! |
M.y <- res.int + res.slopes %*% M.x |
| 182 | ||
| 183 | ! |
COV <- rbind(cbind(S.yy, S.yx), cbind(S.xy, S.xx)) |
| 184 | ! |
MEAN <- c(M.y, M.x) |
| 185 |
} else {
|
|
| 186 |
# not conditional.x |
|
| 187 | ! |
COV <- implied$cov[[g]] |
| 188 | ! |
MEAN <- implied$mean[[g]] |
| 189 |
} |
|
| 190 |
} # COV/MEAN |
|
| 191 | ||
| 192 | 4x |
if (ADF) {
|
| 193 | 4x |
if (conditional.x) {
|
| 194 | ! |
Y <- cbind(lavdata@X[[g]], lavdata@eXo[[g]]) |
| 195 |
} else {
|
|
| 196 | 4x |
Y <- lavdata@X[[g]] |
| 197 |
} |
|
| 198 | 4x |
if (length(lavdata@cluster) > 0L) {
|
| 199 | 2x |
cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
| 200 |
} else {
|
|
| 201 | 2x |
cluster.idx <- NULL |
| 202 |
} |
|
| 203 | 4x |
OUT[[g]] <- lav_samplestats_Gamma( |
| 204 | 4x |
Y = Y, |
| 205 | 4x |
Mu = MEAN, |
| 206 | 4x |
Sigma = COV, |
| 207 | 4x |
x.idx = x.idx, |
| 208 | 4x |
cluster.idx = cluster.idx, |
| 209 | 4x |
fixed.x = fixed.x, |
| 210 | 4x |
conditional.x = conditional.x, |
| 211 | 4x |
meanstructure = meanstructure, |
| 212 | 4x |
slopestructure = conditional.x, |
| 213 | 4x |
gamma.n.minus.one = gamma.n.minus.one, |
| 214 | 4x |
unbiased = gamma.unbiased, |
| 215 | 4x |
Mplus.WLS = Mplus.WLS |
| 216 |
) |
|
| 217 |
} else {
|
|
| 218 | ! |
OUT[[g]] <- lav_samplestats_Gamma_NT( |
| 219 | ! |
COV = COV, # joint! |
| 220 | ! |
MEAN = MEAN, # joint! |
| 221 | ! |
x.idx = x.idx, |
| 222 | ! |
fixed.x = fixed.x, |
| 223 | ! |
conditional.x = conditional.x, |
| 224 | ! |
meanstructure = meanstructure, |
| 225 | ! |
slopestructure = conditional.x |
| 226 |
) |
|
| 227 |
} |
|
| 228 | ||
| 229 |
# group.w.free |
|
| 230 | 4x |
if (lavoptions$group.w.free) {
|
| 231 |
# checkme! |
|
| 232 | ! |
OUT[[g]] <- lav_matrix_bdiag(matrix(1, 1, 1), OUT[[g]]) |
| 233 |
} |
|
| 234 | ||
| 235 |
} # g |
|
| 236 | ||
| 237 | 3x |
OUT |
| 238 |
} |
|
| 239 | ||
| 240 | ||
| 241 | ||
| 242 | ||
| 243 | ||
| 244 |
# NOTE: |
|
| 245 |
# - three types: |
|
| 246 |
# 1) plain (conditional.x = FALSE, fixed.x = FALSE) |
|
| 247 |
# 2) fixed.x (conditional.x = FALSE, fixed.x = TRUE) |
|
| 248 |
# 3) conditional.x (conditional.x = TRUE) |
|
| 249 |
# - if conditional.x = TRUE, we ignore fixed.x (can be TRUE or FALSE) |
|
| 250 | ||
| 251 |
# NORMAL-THEORY |
|
| 252 |
lav_samplestats_Gamma_NT <- function(Y = NULL, # should include |
|
| 253 |
# eXo if |
|
| 254 |
# conditional.x=TRUE |
|
| 255 |
wt = NULL, |
|
| 256 |
COV = NULL, # joint! |
|
| 257 |
MEAN = NULL, # joint! |
|
| 258 |
rescale = FALSE, |
|
| 259 |
x.idx = integer(0L), |
|
| 260 |
fixed.x = FALSE, |
|
| 261 |
conditional.x = FALSE, |
|
| 262 |
meanstructure = FALSE, |
|
| 263 |
slopestructure = FALSE) {
|
|
| 264 |
# check arguments |
|
| 265 | ! |
if (length(x.idx) == 0L) {
|
| 266 | ! |
conditional.x <- FALSE |
| 267 | ! |
fixed.x <- FALSE |
| 268 |
} |
|
| 269 | ||
| 270 |
# compute COV from Y |
|
| 271 | ! |
if (is.null(COV)) {
|
| 272 | ! |
stopifnot(!is.null(Y)) |
| 273 | ||
| 274 |
# coerce to matrix |
|
| 275 | ! |
Y <- unname(as.matrix(Y)) |
| 276 | ! |
N <- nrow(Y) |
| 277 | ! |
if (is.null(wt)) {
|
| 278 | ! |
COV <- cov(Y) |
| 279 | ! |
if (rescale) {
|
| 280 | ! |
COV <- COV * (N - 1) / N # (normal) ML version |
| 281 |
} |
|
| 282 |
} else {
|
|
| 283 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 284 | ! |
COV <- out$cov |
| 285 |
} |
|
| 286 |
} else {
|
|
| 287 | ! |
if (!missing(rescale)) {
|
| 288 | ! |
lav_msg_warn(gettext("rescale= argument has no effect if COV is given"))
|
| 289 |
} |
|
| 290 | ! |
if (!missing(wt)) {
|
| 291 | ! |
lav_msg_warn(gettext("wt= argument has no effect if COV is given"))
|
| 292 |
} |
|
| 293 |
} |
|
| 294 | ||
| 295 |
# if needed, compute MEAN from Y |
|
| 296 | ! |
if (conditional.x && length(x.idx) > 0L && is.null(MEAN) && |
| 297 | ! |
(meanstructure || slopestructure)) {
|
| 298 | ! |
stopifnot(!is.null(Y)) |
| 299 | ! |
if (is.null(wt)) {
|
| 300 | ! |
MEAN <- colMeans(Y, na.rm = TRUE) |
| 301 |
} else {
|
|
| 302 | ! |
MEAN <- out$center |
| 303 |
} |
|
| 304 |
} |
|
| 305 | ||
| 306 |
# rename |
|
| 307 | ! |
S <- COV |
| 308 | ! |
M <- MEAN |
| 309 | ||
| 310 |
# unconditional |
|
| 311 | ! |
if (!conditional.x) {
|
| 312 |
# unconditional - stochastic x |
|
| 313 | ! |
if (!fixed.x) {
|
| 314 |
# if (lav_use_lavaanC()) {
|
|
| 315 |
# Gamma <- lavaanC::m_kronecker_dup_ginv_pre_post(S, multiplicator = 2.0) |
|
| 316 |
# } else {
|
|
| 317 | ! |
Gamma <- 2 * lav_matrix_duplication_ginv_pre_post(S %x% S) |
| 318 |
# } |
|
| 319 | ! |
if (meanstructure) {
|
| 320 | ! |
Gamma <- lav_matrix_bdiag(S, Gamma) |
| 321 |
} |
|
| 322 | ||
| 323 |
# unconditional - fixed x |
|
| 324 |
} else {
|
|
| 325 |
# handle fixed.x = TRUE |
|
| 326 | ||
| 327 |
# cov(Y|X) = A - B C^{-1} B'
|
|
| 328 |
# where A = cov(Y), B = cov(Y,X), C = cov(X) |
|
| 329 | ! |
A <- S[-x.idx, -x.idx, drop = FALSE] |
| 330 | ! |
B <- S[-x.idx, x.idx, drop = FALSE] |
| 331 | ! |
C <- S[x.idx, x.idx, drop = FALSE] |
| 332 | ! |
YbarX <- A - B %*% solve(C, t(B)) |
| 333 | ||
| 334 |
# reinsert YbarX in Y+X (residual) covariance matrix |
|
| 335 | ! |
YbarX.aug <- matrix(0, nrow = NROW(S), ncol = NCOL(S)) |
| 336 | ! |
YbarX.aug[-x.idx, -x.idx] <- YbarX |
| 337 | ||
| 338 |
# take difference |
|
| 339 | ! |
R <- S - YbarX.aug |
| 340 | ||
| 341 |
# if (lav_use_lavaanC()) {
|
|
| 342 |
# Gamma.S <- lavaanC::m_kronecker_dup_ginv_pre_post(S, multiplicator = 2.0) |
|
| 343 |
# Gamma.R <- lavaanC::m_kronecker_dup_ginv_pre_post(R, multiplicator = 2.0) |
|
| 344 |
# } else {
|
|
| 345 | ! |
Gamma.S <- 2 * lav_matrix_duplication_ginv_pre_post(S %x% S) |
| 346 | ! |
Gamma.R <- 2 * lav_matrix_duplication_ginv_pre_post(R %x% R) |
| 347 |
# } |
|
| 348 | ! |
Gamma <- Gamma.S - Gamma.R |
| 349 | ||
| 350 | ! |
if (meanstructure) {
|
| 351 | ! |
Gamma <- lav_matrix_bdiag(YbarX.aug, Gamma) |
| 352 |
} |
|
| 353 |
} |
|
| 354 |
} else {
|
|
| 355 |
# conditional.x |
|
| 356 | ||
| 357 |
# 4 possibilities: |
|
| 358 |
# - no meanstructure, no slopes |
|
| 359 |
# - meanstructure, no slopes |
|
| 360 |
# - no meanstructure, slopes |
|
| 361 |
# - meanstructure, slopes |
|
| 362 | ||
| 363 |
# regress Y on X, and compute covariance of residuals 'R' |
|
| 364 | ! |
A <- S[-x.idx, -x.idx, drop = FALSE] |
| 365 | ! |
B <- S[-x.idx, x.idx, drop = FALSE] |
| 366 | ! |
C <- S[x.idx, x.idx, drop = FALSE] |
| 367 | ! |
Cov.YbarX <- A - B %*% solve(C) %*% t(B) |
| 368 |
# if (lav_use_lavaanC()) {
|
|
| 369 |
# Gamma <- lavaanC::m_kronecker_dup_ginv_pre_post(Cov.YbarX, multiplicator = 2.0) |
|
| 370 |
# } else {
|
|
| 371 | ! |
Gamma <- 2 * lav_matrix_duplication_ginv_pre_post(Cov.YbarX %x% Cov.YbarX) |
| 372 |
# } |
|
| 373 | ||
| 374 | ! |
if (meanstructure || slopestructure) {
|
| 375 | ! |
MY <- M[-x.idx] |
| 376 | ! |
MX <- M[x.idx] |
| 377 | ! |
C3 <- rbind( |
| 378 | ! |
c(1, MX), |
| 379 | ! |
cbind(MX, C + tcrossprod(MX)) |
| 380 |
) |
|
| 381 |
# B3 <- cbind(MY, B + tcrossprod(MY,MX)) |
|
| 382 |
} |
|
| 383 | ||
| 384 | ! |
if (meanstructure) {
|
| 385 | ! |
if (slopestructure) {
|
| 386 |
# A11 <- solve(C3) %x% Cov.YbarX |
|
| 387 | ! |
A11 <- Cov.YbarX %x% solve(C3) |
| 388 |
} else {
|
|
| 389 |
# A11 <- solve(C3)[1, 1, drop=FALSE] %x% Cov.YbarX |
|
| 390 | ! |
A11 <- Cov.YbarX %x% solve(C3)[1, 1, drop = FALSE] |
| 391 |
} |
|
| 392 |
} else {
|
|
| 393 | ! |
if (slopestructure) {
|
| 394 |
# A11 <- solve(C3)[-1, -1, drop=FALSE] %x% Cov.YbarX |
|
| 395 | ! |
A11 <- Cov.YbarX %x% solve(C3)[-1, -1, drop = FALSE] |
| 396 |
} else {
|
|
| 397 | ! |
A11 <- matrix(0, 0, 0) |
| 398 |
} |
|
| 399 |
} |
|
| 400 | ||
| 401 | ! |
Gamma <- lav_matrix_bdiag(A11, Gamma) |
| 402 |
} |
|
| 403 | ||
| 404 | ! |
Gamma |
| 405 |
} |
|
| 406 | ||
| 407 |
# NOTE: |
|
| 408 |
# - three types: |
|
| 409 |
# 1) plain (conditional.x = FALSE, fixed.x = FALSE) |
|
| 410 |
# 2) fixed.x (conditional.x = FALSE, fixed.x = TRUE) |
|
| 411 |
# 3) conditional.x (conditional.x = TRUE) |
|
| 412 |
# - if conditional.x = TRUE, we ignore fixed.x (can be TRUE or FALSE) |
|
| 413 |
# |
|
| 414 |
# - new in 0.6-1: if Mu/Sigma is provided, compute 'model-based' Gamma |
|
| 415 |
# (only if conditional.x = FALSE, for now) |
|
| 416 |
# - new in 0.6-2: if cluster.idx is not NULL, correct for clustering |
|
| 417 |
# - new in 0.6-13: add unbiased = TRUE (for the 'plain' setting only) |
|
| 418 | ||
| 419 |
# ADF THEORY |
|
| 420 |
lav_samplestats_Gamma <- function(Y, # Y+X if cond! |
|
| 421 |
Mu = NULL, |
|
| 422 |
Sigma = NULL, |
|
| 423 |
x.idx = integer(0L), |
|
| 424 |
cluster.idx = NULL, |
|
| 425 |
fixed.x = FALSE, |
|
| 426 |
conditional.x = FALSE, |
|
| 427 |
meanstructure = FALSE, |
|
| 428 |
slopestructure = FALSE, |
|
| 429 |
gamma.n.minus.one = FALSE, |
|
| 430 |
unbiased = FALSE, |
|
| 431 |
Mplus.WLS = FALSE) {
|
|
| 432 |
# coerce to matrix |
|
| 433 | 6x |
Y <- unname(as.matrix(Y)) |
| 434 | 6x |
N <- nrow(Y) |
| 435 | 6x |
p <- ncol(Y) |
| 436 | ||
| 437 |
# unbiased? |
|
| 438 | 6x |
if (unbiased) {
|
| 439 | ! |
if (conditional.x || fixed.x || !is.null(Sigma) || |
| 440 | ! |
!is.null(cluster.idx)) {
|
| 441 | ! |
lav_msg_stop( |
| 442 | ! |
gettext("unbiased Gamma only available for the simple
|
| 443 | ! |
(not conditional.x or fixed.x or model-based or clustered) setting.")) |
| 444 |
} else {
|
|
| 445 |
# data really should be complete |
|
| 446 | ! |
COV <- COV.unbiased <- stats::cov(Y, use = "pairwise.complete.obs") |
| 447 | ! |
COV <- COV * (N - 1) / N |
| 448 | ! |
cov.vech <- lav_matrix_vech(COV) |
| 449 |
} |
|
| 450 |
} |
|
| 451 | ||
| 452 |
# model-based? |
|
| 453 | 6x |
if (!is.null(Sigma)) {
|
| 454 | ! |
stopifnot(!conditional.x) |
| 455 | ! |
model.based <- TRUE |
| 456 | ! |
if (meanstructure) {
|
| 457 | ! |
stopifnot(!is.null(Mu)) |
| 458 | ! |
sigma <- c(as.numeric(Mu), lav_matrix_vech(Sigma)) |
| 459 |
} else {
|
|
| 460 | ! |
Mu <- colMeans(Y, na.rm = TRUE) # for centering! |
| 461 | ! |
sigma <- lav_matrix_vech(Sigma) |
| 462 |
} |
|
| 463 |
} else {
|
|
| 464 | 6x |
model.based <- FALSE |
| 465 |
} |
|
| 466 | ||
| 467 |
# denominator |
|
| 468 | 6x |
if (gamma.n.minus.one) {
|
| 469 | ! |
N <- N - 1 |
| 470 |
} |
|
| 471 | ||
| 472 |
# check arguments |
|
| 473 | 6x |
if (length(x.idx) == 0L) {
|
| 474 | 6x |
conditional.x <- FALSE |
| 475 | 6x |
fixed.x <- FALSE |
| 476 |
} |
|
| 477 | 6x |
if (Mplus.WLS) {
|
| 478 | ! |
stopifnot(!conditional.x, !fixed.x) |
| 479 |
} |
|
| 480 | ||
| 481 | 6x |
if (!conditional.x && !fixed.x) {
|
| 482 |
# center, so we can use crossprod instead of cov |
|
| 483 | 6x |
if (model.based) {
|
| 484 | ! |
Yc <- t(t(Y) - as.numeric(Mu)) |
| 485 |
} else {
|
|
| 486 | 6x |
Yc <- t(t(Y) - colMeans(Y, na.rm = TRUE)) |
| 487 |
} |
|
| 488 | ||
| 489 |
# create Z where the rows_i contain the following elements: |
|
| 490 |
# - Y_i (if meanstructure is TRUE) |
|
| 491 |
# - vech(Yc_i' %*% Yc_i) where Yc_i are the residuals |
|
| 492 | 6x |
idx1 <- lav_matrix_vech_col_idx(p) |
| 493 | 6x |
idx2 <- lav_matrix_vech_row_idx(p) |
| 494 | 6x |
if (meanstructure) {
|
| 495 | 4x |
Z <- cbind(Y, Yc[, idx1, drop = FALSE] * |
| 496 | 4x |
Yc[, idx2, drop = FALSE]) |
| 497 |
} else {
|
|
| 498 | 2x |
Z <- (Yc[, idx1, drop = FALSE] * |
| 499 | 2x |
Yc[, idx2, drop = FALSE]) |
| 500 |
} |
|
| 501 | ||
| 502 | 6x |
if (model.based) {
|
| 503 | ! |
if (meanstructure) {
|
| 504 | ! |
stopifnot(!is.null(Mu)) |
| 505 | ! |
sigma <- c(as.numeric(Mu), lav_matrix_vech(Sigma)) |
| 506 |
} else {
|
|
| 507 | ! |
sigma <- lav_matrix_vech(Sigma) |
| 508 |
} |
|
| 509 | ! |
Zc <- t(t(Z) - sigma) |
| 510 |
} else {
|
|
| 511 | 6x |
Zc <- t(t(Z) - colMeans(Z, na.rm = TRUE)) |
| 512 |
} |
|
| 513 | ||
| 514 |
# clustered? |
|
| 515 | 6x |
if (length(cluster.idx) > 0L) {
|
| 516 | 2x |
Zc <- rowsum(Zc, cluster.idx) |
| 517 |
} |
|
| 518 | ||
| 519 | 6x |
if (anyNA(Zc)) {
|
| 520 | ! |
Gamma <- lav_matrix_crossprod(Zc) / N |
| 521 |
} else {
|
|
| 522 | 6x |
Gamma <- base::crossprod(Zc) / N |
| 523 |
} |
|
| 524 | ! |
} else if (!conditional.x && fixed.x) {
|
| 525 | ! |
if (model.based) {
|
| 526 | ! |
Yc <- t(t(Y) - as.numeric(Mu)) |
| 527 | ! |
Y.bar <- colMeans(Y, na.rm = TRUE) |
| 528 | ! |
res.cov <- (Sigma[-x.idx, -x.idx, drop = FALSE] - |
| 529 | ! |
Sigma[-x.idx, x.idx, drop = FALSE] %*% |
| 530 | ! |
solve(Sigma[x.idx, x.idx, drop = FALSE]) %*% |
| 531 | ! |
Sigma[x.idx, -x.idx, drop = FALSE]) |
| 532 | ! |
res.slopes <- (solve(Sigma[x.idx, x.idx, drop = FALSE]) %*% |
| 533 | ! |
Sigma[x.idx, -x.idx, drop = FALSE]) |
| 534 | ! |
res.int <- (Y.bar[-x.idx] - |
| 535 | ! |
as.numeric(colMeans(Y[, x.idx, drop = FALSE], |
| 536 | ! |
na.rm = TRUE |
| 537 | ! |
) %*% res.slopes)) |
| 538 | ! |
x.bar <- Y.bar[x.idx] |
| 539 | ! |
yhat.bar <- as.numeric(res.int + as.numeric(x.bar) %*% res.slopes) |
| 540 | ! |
YHAT.bar <- numeric(p) |
| 541 | ! |
YHAT.bar[-x.idx] <- yhat.bar |
| 542 | ! |
YHAT.bar[x.idx] <- x.bar |
| 543 | ! |
YHAT.cov <- Sigma |
| 544 | ! |
YHAT.cov[-x.idx, -x.idx] <- Sigma[-x.idx, -x.idx] - res.cov |
| 545 | ||
| 546 | ||
| 547 | ! |
yhat <- cbind(1, Y[, x.idx]) %*% rbind(res.int, res.slopes) |
| 548 | ! |
YHAT <- Y |
| 549 | ! |
YHAT[, -x.idx] <- yhat |
| 550 |
# YHAT <- cbind(yhat, Y[,x.idx]) |
|
| 551 | ! |
YHATc <- t(t(YHAT) - YHAT.bar) |
| 552 | ! |
idx1 <- lav_matrix_vech_col_idx(p) |
| 553 | ! |
idx2 <- lav_matrix_vech_row_idx(p) |
| 554 | ! |
if (meanstructure) {
|
| 555 | ! |
Z <- (cbind(Y, Yc[, idx1, drop = FALSE] * |
| 556 | ! |
Yc[, idx2, drop = FALSE]) - |
| 557 | ! |
cbind(YHAT, YHATc[, idx1, drop = FALSE] * |
| 558 | ! |
YHATc[, idx2, drop = FALSE])) |
| 559 | ! |
sigma1 <- c(Mu, lav_matrix_vech(Sigma)) |
| 560 | ! |
sigma2 <- c(YHAT.bar, lav_matrix_vech(YHAT.cov)) |
| 561 |
} else {
|
|
| 562 | ! |
Z <- (Yc[, idx1, drop = FALSE] * |
| 563 | ! |
Yc[, idx2, drop = FALSE] - |
| 564 | ! |
YHATc[, idx1, drop = FALSE] * |
| 565 | ! |
YHATc[, idx2, drop = FALSE]) |
| 566 | ! |
sigma1 <- lav_matrix_vech(Sigma) |
| 567 | ! |
sigma2 <- lav_matrix_vech(YHAT.cov) |
| 568 |
} |
|
| 569 | ! |
Zc <- t(t(Z) - (sigma1 - sigma2)) |
| 570 |
} else {
|
|
| 571 | ! |
QR <- qr(cbind(1, Y[, x.idx, drop = FALSE])) |
| 572 | ! |
yhat <- qr.fitted(QR, Y[, -x.idx, drop = FALSE]) |
| 573 |
# YHAT <- cbind(yhat, Y[,x.idx]) |
|
| 574 | ! |
YHAT <- Y |
| 575 | ! |
YHAT[, -x.idx] <- yhat |
| 576 | ||
| 577 | ! |
Yc <- t(t(Y) - colMeans(Y, na.rm = TRUE)) |
| 578 | ! |
YHATc <- t(t(YHAT) - colMeans(YHAT, na.rm = TRUE)) |
| 579 | ! |
idx1 <- lav_matrix_vech_col_idx(p) |
| 580 | ! |
idx2 <- lav_matrix_vech_row_idx(p) |
| 581 | ! |
if (meanstructure) {
|
| 582 | ! |
Z <- (cbind(Y, Yc[, idx1, drop = FALSE] * |
| 583 | ! |
Yc[, idx2, drop = FALSE]) - |
| 584 | ! |
cbind(YHAT, YHATc[, idx1, drop = FALSE] * |
| 585 | ! |
YHATc[, idx2, drop = FALSE])) |
| 586 |
} else {
|
|
| 587 | ! |
Z <- (Yc[, idx1, drop = FALSE] * |
| 588 | ! |
Yc[, idx2, drop = FALSE] - |
| 589 | ! |
YHATc[, idx1, drop = FALSE] * |
| 590 | ! |
YHATc[, idx2, drop = FALSE]) |
| 591 |
} |
|
| 592 | ! |
Zc <- t(t(Z) - colMeans(Z, na.rm = TRUE)) |
| 593 |
} |
|
| 594 | ||
| 595 |
# clustered? |
|
| 596 | ! |
if (length(cluster.idx) > 0L) {
|
| 597 | ! |
Zc <- rowsum(Zc, cluster.idx) |
| 598 |
} |
|
| 599 | ||
| 600 | ! |
if (anyNA(Zc)) {
|
| 601 | ! |
Gamma <- lav_matrix_crossprod(Zc) / N |
| 602 |
} else {
|
|
| 603 | ! |
Gamma <- base::crossprod(Zc) / N |
| 604 |
} |
|
| 605 |
} else {
|
|
| 606 |
# conditional.x |
|
| 607 | ||
| 608 |
# 4 possibilities: |
|
| 609 |
# - no meanstructure, no slopes |
|
| 610 |
# - meanstructure, no slopes |
|
| 611 |
# - no meanstructure, slopes |
|
| 612 |
# - meanstructure, slopes |
|
| 613 | ||
| 614 |
# regress Y on X, and compute residuals |
|
| 615 | ! |
X <- cbind(1, Y[, x.idx, drop = FALSE]) |
| 616 | ! |
QR <- qr(X) |
| 617 | ! |
RES <- qr.resid(QR, Y[, -x.idx, drop = FALSE]) |
| 618 | ! |
p <- ncol(RES) |
| 619 | ||
| 620 | ! |
idx1 <- lav_matrix_vech_col_idx(p) |
| 621 | ! |
idx2 <- lav_matrix_vech_row_idx(p) |
| 622 | ||
| 623 | ! |
if (meanstructure || slopestructure) {
|
| 624 | ! |
XtX.inv <- unname(solve(crossprod(X))) |
| 625 | ! |
Xi <- (X %*% XtX.inv) * N ## FIXME, shorter way? |
| 626 | ! |
ncX <- NCOL(X) |
| 627 | ! |
ncY <- NCOL(RES) |
| 628 |
} |
|
| 629 | ||
| 630 | ! |
if (meanstructure) {
|
| 631 | ! |
if (slopestructure) {
|
| 632 |
# Xi.idx <- rep(seq_len(ncX), each = ncY) |
|
| 633 |
# Res.idx <- rep(seq_len(ncY), times = ncX) |
|
| 634 | ! |
Xi.idx <- rep(seq_len(ncX), times = ncY) |
| 635 | ! |
Res.idx <- rep(seq_len(ncY), each = ncX) |
| 636 | ! |
Z <- cbind( |
| 637 | ! |
Xi[, Xi.idx, drop = FALSE] * |
| 638 | ! |
RES[, Res.idx, drop = FALSE], |
| 639 | ! |
RES[, idx1, drop = FALSE] * |
| 640 | ! |
RES[, idx2, drop = FALSE] |
| 641 |
) |
|
| 642 |
} else {
|
|
| 643 | ! |
Xi.idx <- rep(1L, each = ncY) |
| 644 | ! |
Z <- cbind( |
| 645 | ! |
Xi[, Xi.idx, drop = FALSE] * |
| 646 | ! |
RES, |
| 647 | ! |
RES[, idx1, drop = FALSE] * |
| 648 | ! |
RES[, idx2, drop = FALSE] |
| 649 |
) |
|
| 650 |
} |
|
| 651 |
} else {
|
|
| 652 | ! |
if (slopestructure) {
|
| 653 |
# Xi.idx <- rep(seq_len(ncX), each = ncY) |
|
| 654 |
# Xi.idx <- Xi.idx[ -seq_len(ncY) ] |
|
| 655 | ! |
Xi.idx <- rep(seq(2, ncX), times = ncY) |
| 656 |
# Res.idx <- rep(seq_len(ncY), times = (ncX - 1L)) |
|
| 657 | ! |
Res.idx <- rep(seq_len(ncY), each = (ncX - 1L)) |
| 658 | ! |
Z <- cbind( |
| 659 | ! |
Xi[, Xi.idx, drop = FALSE] * |
| 660 | ! |
RES[, Res.idx, drop = FALSE], |
| 661 | ! |
RES[, idx1, drop = FALSE] * |
| 662 | ! |
RES[, idx2, drop = FALSE] |
| 663 |
) |
|
| 664 |
} else {
|
|
| 665 | ! |
Z <- RES[, idx1, drop = FALSE] * RES[, idx2, drop = FALSE] |
| 666 |
} |
|
| 667 |
} |
|
| 668 | ||
| 669 | ! |
if (model.based) {
|
| 670 | ! |
Zc <- t(t(Z) - sigma) |
| 671 |
} else {
|
|
| 672 | ! |
Zc <- t(t(Z) - colMeans(Z, na.rm = TRUE)) |
| 673 |
} |
|
| 674 | ||
| 675 |
# clustered? |
|
| 676 | ! |
if (length(cluster.idx) > 0L) {
|
| 677 | ! |
Zc <- rowsum(Zc, cluster.idx) |
| 678 |
} |
|
| 679 | ||
| 680 | ! |
if (anyNA(Zc)) {
|
| 681 | ! |
Gamma <- lav_matrix_crossprod(Zc) / N |
| 682 |
} else {
|
|
| 683 | ! |
Gamma <- base::crossprod(Zc) / N |
| 684 |
} |
|
| 685 |
} |
|
| 686 | ||
| 687 | ||
| 688 |
# only to mimic Mplus when estimator = "WLS" |
|
| 689 | 6x |
if (Mplus.WLS && !fixed.x && !conditional.x) {
|
| 690 |
# adjust G_22 (the varcov part) |
|
| 691 | ! |
S <- cov(Y, use = "pairwise") |
| 692 | ! |
w <- lav_matrix_vech(S) |
| 693 | ! |
w.biased <- (N - 1) / N * w |
| 694 | ! |
diff <- outer(w, w) - outer(w.biased, w.biased) |
| 695 | ! |
if (meanstructure) {
|
| 696 | ! |
Gamma[-seq_len(p), -seq_len(p)] <- |
| 697 | ! |
Gamma[-seq_len(p), -seq_len(p), drop = FALSE] - diff |
| 698 |
} else {
|
|
| 699 | ! |
Gamma <- Gamma - diff |
| 700 |
} |
|
| 701 | ||
| 702 | ! |
if (meanstructure) {
|
| 703 |
# adjust G_12/G_21 (third-order) |
|
| 704 |
# strange rescaling? |
|
| 705 | ! |
N1 <- (N - 1) / N |
| 706 | ! |
Gamma[seq_len(p), -seq_len(p)] <- Gamma[seq_len(p), -seq_len(p)] * N1 |
| 707 | ! |
Gamma[-seq_len(p), seq_len(p)] <- Gamma[-seq_len(p), seq_len(p)] * N1 |
| 708 |
} |
|
| 709 |
} |
|
| 710 | ||
| 711 |
# clustered? |
|
| 712 | 6x |
if (length(cluster.idx) > 0L) {
|
| 713 | 2x |
nC <- nrow(Zc) |
| 714 | 2x |
Gamma <- Gamma * nC / (nC - 1) |
| 715 |
} |
|
| 716 | ||
| 717 |
# unbiased? |
|
| 718 | 6x |
if (unbiased) {
|
| 719 |
# normal-theory Gamma (cov only) |
|
| 720 |
# if (lav_use_lavaanC()) {
|
|
| 721 |
# GammaNT.cov <- lavaanC::m_kronecker_dup_ginv_pre_post(COV, |
|
| 722 |
# multiplicator = 2.0) |
|
| 723 |
# } else {
|
|
| 724 | ! |
GammaNT.cov <- 2 * lav_matrix_duplication_ginv_pre_post(COV %x% COV) |
| 725 |
# } |
|
| 726 | ||
| 727 | ! |
if (meanstructure) {
|
| 728 | ! |
Gamma.cov <- Gamma[-(1:p), -(1:p), drop = FALSE] |
| 729 | ! |
Gamma.mean.cov <- Gamma[1:p, -(1:p), drop = FALSE] |
| 730 |
} else {
|
|
| 731 | ! |
Gamma.cov <- Gamma |
| 732 |
} |
|
| 733 | ||
| 734 |
# Browne's unbiased DF estimator (COV part) |
|
| 735 | ! |
Gamma.u <- (N * (N - 1) / (N - 2) / (N - 3) * Gamma.cov - |
| 736 | ! |
N / (N - 2) / (N - 3) * (GammaNT.cov - |
| 737 | ! |
2 / (N - 1) * tcrossprod(cov.vech))) |
| 738 | ! |
if (meanstructure) {
|
| 739 | ! |
Gamma <- lav_matrix_bdiag(COV, Gamma.u) |
| 740 | ||
| 741 |
# 3-rd order: |
|
| 742 | ! |
Gamma[1:p, (p + 1):ncol(Gamma)] <- Gamma.mean.cov * N / (N - 2) |
| 743 | ! |
Gamma[(p + 1):ncol(Gamma), 1:p] <- t(Gamma.mean.cov * N / (N - 2)) |
| 744 |
} else {
|
|
| 745 | ! |
Gamma <- Gamma.u |
| 746 |
} |
|
| 747 |
} # unbiased |
|
| 748 | ||
| 749 | 6x |
Gamma |
| 750 |
} |
|
| 751 | ||
| 752 |
# ADF Gamma for correlations |
|
| 753 |
# |
|
| 754 |
# 30 May 2024: basic version: fixed.x=FALSE, conditional.x=FALSE, ... |
|
| 755 |
lav_samplestats_cor_Gamma <- function(Y, meanstructure = FALSE) {
|
|
| 756 | ||
| 757 |
# coerce to matrix |
|
| 758 | ! |
Y <- unname(as.matrix(Y)) |
| 759 | ! |
N <- nrow(Y) |
| 760 | ! |
P <- ncol(Y) |
| 761 | ||
| 762 |
# compute S and R |
|
| 763 | ! |
S <- cov(Y) * (N - 1) / N |
| 764 | ! |
R <- cov2cor(S) |
| 765 | ||
| 766 |
# create z-scores |
|
| 767 | ! |
SD <- sqrt(diag(S)) |
| 768 | ! |
Yz <- t( (t(Y) - colMeans(Y))/SD ) |
| 769 | ||
| 770 |
# create squared z-scores |
|
| 771 | ! |
Yz2 <- Yz*Yz |
| 772 | ||
| 773 |
# find indices so we avoid 1) double subscripts (diagonal!), and |
|
| 774 |
# 2) duplicated subscripts (symmetric!) |
|
| 775 | ! |
idx1 <- lav_matrix_vech_col_idx(P, diagonal = FALSE) |
| 776 | ! |
idx2 <- lav_matrix_vech_row_idx(P, diagonal = FALSE) |
| 777 | ||
| 778 | ! |
ZR1 <- (Yz[, idx1, drop = FALSE] * Yz[, idx2, drop = FALSE]) |
| 779 | ! |
ZR2 <- (Yz2[, idx1, drop = FALSE] + Yz2[, idx2, drop = FALSE]) |
| 780 | ! |
ZR2 <- t( t(ZR2) * lav_matrix_vech(R, diagonal = FALSE) ) |
| 781 | ! |
ZRR <- ZR1 - 0.5*ZR2 |
| 782 | ! |
if(meanstructure) {
|
| 783 | ! |
ZRR <- cbind(Yz, ZRR) |
| 784 |
} |
|
| 785 | ! |
Gamma <- crossprod(ZRR)/N |
| 786 | ||
| 787 | ! |
Gamma |
| 788 |
} |
|
| 789 | ||
| 790 |
# normal theory version |
|
| 791 |
# 30 May 2024: basic version: fixed.x=FALSE, conditional.x=FALSE, ... |
|
| 792 |
lav_samplestats_cor_Gamma_NT <- function(Y = NULL, |
|
| 793 |
wt = NULL, |
|
| 794 |
COV = NULL, # joint! |
|
| 795 |
MEAN = NULL, # joint! |
|
| 796 |
rescale = FALSE, |
|
| 797 |
x.idx = integer(0L), |
|
| 798 |
fixed.x = FALSE, |
|
| 799 |
conditional.x = FALSE, |
|
| 800 |
meanstructure = FALSE, |
|
| 801 |
slopestructure = FALSE) {
|
|
| 802 |
# check arguments |
|
| 803 | ! |
if (length(x.idx) == 0L) {
|
| 804 | ! |
conditional.x <- FALSE |
| 805 | ! |
fixed.x <- FALSE |
| 806 |
} else {
|
|
| 807 | ! |
lav_msg_stop(gettext("x.idx not supported (yet) for correlations; use
|
| 808 | ! |
fixed.x = FALSE (for now)")) |
| 809 |
} |
|
| 810 | ! |
if(conditional.x) {
|
| 811 | ! |
lav_msg_stop(gettext("conditional.x = TRUE not supported (yet) for
|
| 812 | ! |
correlations")) |
| 813 |
} |
|
| 814 | ||
| 815 |
# compute COV from Y |
|
| 816 | ! |
if (is.null(COV)) {
|
| 817 | ! |
stopifnot(!is.null(Y)) |
| 818 | ||
| 819 |
# coerce to matrix |
|
| 820 | ! |
Y <- unname(as.matrix(Y)) |
| 821 | ! |
N <- nrow(Y) |
| 822 | ! |
if (is.null(wt)) {
|
| 823 | ! |
COV <- cov(Y) |
| 824 | ! |
if (rescale) {
|
| 825 | ! |
COV <- COV * (N - 1) / N # (normal) ML version |
| 826 |
} |
|
| 827 |
} else {
|
|
| 828 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 829 | ! |
COV <- out$cov |
| 830 |
} |
|
| 831 |
} else {
|
|
| 832 | ! |
if (!missing(rescale)) {
|
| 833 | ! |
lav_msg_warn(gettext("rescale= argument has no effect if COV is given"))
|
| 834 |
} |
|
| 835 | ! |
if (!missing(wt)) {
|
| 836 | ! |
lav_msg_warn(gettext("wt= argument has no effect if COV is given"))
|
| 837 |
} |
|
| 838 |
} |
|
| 839 | ||
| 840 |
# if needed, compute MEAN from Y |
|
| 841 | ! |
if (conditional.x && length(x.idx) > 0L && is.null(MEAN) && |
| 842 | ! |
(meanstructure || slopestructure)) {
|
| 843 | ! |
stopifnot(!is.null(Y)) |
| 844 | ! |
if (is.null(wt)) {
|
| 845 | ! |
MEAN <- colMeans(Y, na.rm = TRUE) |
| 846 |
} else {
|
|
| 847 | ! |
MEAN <- out$center |
| 848 |
} |
|
| 849 |
} |
|
| 850 | ||
| 851 |
# rename |
|
| 852 | ! |
S <- COV |
| 853 | ! |
R <- cov2cor(S) |
| 854 | ! |
M <- MEAN |
| 855 | ! |
P <- nrow(S) |
| 856 | ||
| 857 |
# unconditional |
|
| 858 | ! |
if (!conditional.x) {
|
| 859 |
# unconditional - stochastic x |
|
| 860 | ! |
if (!fixed.x) {
|
| 861 | ! |
IP <- diag(P) %x% R |
| 862 | ! |
RR <- R %x% R |
| 863 | ! |
Gamma.Z.NT <- RR + lav_matrix_commutation_pre(RR) |
| 864 | ! |
tmp <- (IP + lav_matrix_commutation_pre(IP))/2 |
| 865 | ! |
zero.idx <- seq_len(P*P)[-lav_matrix_diag_idx(P)] |
| 866 | ! |
tmp[, zero.idx] <- 0 |
| 867 | ! |
A <- -tmp |
| 868 | ! |
diag(A) <- 1 - diag(tmp) |
| 869 | ! |
Gamma.NT.big <- A %*% Gamma.Z.NT %*% t(A) |
| 870 | ! |
r.idx <- lav_matrix_vech_idx(P, diagonal = FALSE) |
| 871 | ! |
Gamma <- Gamma.NT.big[r.idx, r.idx] |
| 872 | ||
| 873 | ! |
if (meanstructure) {
|
| 874 | ! |
Gamma <- lav_matrix_bdiag(R, Gamma) |
| 875 |
} |
|
| 876 | ||
| 877 |
# unconditional - fixed x |
|
| 878 |
} else {
|
|
| 879 |
# TODO |
|
| 880 |
} |
|
| 881 |
} else {
|
|
| 882 |
# conditional.x |
|
| 883 |
# TODO |
|
| 884 |
} |
|
| 885 | ||
| 886 | ! |
Gamma |
| 887 |
} |
| 1 |
# LDW 26 Mar 2024: use option settings and store in cache environment |
|
| 2 | ||
| 3 |
lavaan_cache_env <- new.env(parent = emptyenv()) |
|
| 4 | ||
| 5 |
# # function to get or set the switch to use c++ code in lavaanC |
|
| 6 |
# lav_use_lavaanC <- uselavaanC <- function(x) {
|
|
| 7 |
# if (missing(x)) {
|
|
| 8 |
# if (!exists("opt.lavaanC", lavaan_cache_env)) {
|
|
| 9 |
# assign("opt.lavaanC", requireNamespace("lavaanC", quietly = TRUE), lavaan_cache_env)
|
|
| 10 |
# } |
|
| 11 |
# return(get("opt.lavaanC", lavaan_cache_env))
|
|
| 12 |
# } else {
|
|
| 13 |
# if (!is.logical(x) || length(x) != 1L) |
|
| 14 |
# lav_msg_stop(gettext("'x' must be a scalar logical"))
|
|
| 15 |
# if (x) {
|
|
| 16 |
# if (!requireNamespace("lavaanC", quietly = TRUE)) {
|
|
| 17 |
# lav_msg_warn(gettext("cannot use lavaanC, package not found."))
|
|
| 18 |
# assign("opt.lavaanC", FALSE, lavaan_cache_env)
|
|
| 19 |
# return(invisible(NULL)) |
|
| 20 |
# } |
|
| 21 |
# } |
|
| 22 |
# assign("opt.lavaanC", x, lavaan_cache_env)
|
|
| 23 |
# return(invisible(NULL)) |
|
| 24 |
# } |
|
| 25 |
# } |
|
| 26 | ||
| 27 |
# functions to handle warn/debug/verbose options |
|
| 28 |
# (no longer in 'standard' options) |
|
| 29 |
# if x not present returns the current value of opt.warn/debug/verbose |
|
| 30 |
# if x present |
|
| 31 |
# if x different from current value, assign x to current value and return TRUE |
|
| 32 |
# else return FALSE |
|
| 33 |
lav_warn <- function(x) {
|
|
| 34 | 46784x |
optwarn <- get0("opt.warn", lavaan_cache_env, ifnotfound = TRUE)
|
| 35 | 46784x |
if (missing(x)) {
|
| 36 | 15892x |
return(optwarn) |
| 37 |
} else {
|
|
| 38 | 30892x |
setwarn <- as.logical(x) |
| 39 | 30892x |
if (setwarn != optwarn) {
|
| 40 | 30276x |
if (setwarn) {
|
| 41 |
# because default TRUE, removing value is the same as setting to TRUE |
|
| 42 | 15138x |
rm("opt.warn", envir = lavaan_cache_env)
|
| 43 |
} else {
|
|
| 44 | 15138x |
assign("opt.warn", FALSE, lavaan_cache_env)
|
| 45 |
} |
|
| 46 | 30276x |
return(TRUE) |
| 47 |
} else {
|
|
| 48 | 616x |
return(FALSE) |
| 49 |
} |
|
| 50 |
} |
|
| 51 |
} |
|
| 52 |
lav_debug <- function(x) {
|
|
| 53 | 29055x |
optdebug <- get0("opt.debug", lavaan_cache_env, ifnotfound = FALSE)
|
| 54 | 29055x |
if (missing(x)) {
|
| 55 | 28623x |
return(optdebug) |
| 56 |
} else {
|
|
| 57 | 432x |
setdebug <- as.logical(x) |
| 58 | 432x |
if (setdebug != optdebug) {
|
| 59 | ! |
if (setdebug) {
|
| 60 | ! |
assign("opt.debug", TRUE, lavaan_cache_env)
|
| 61 |
} else {
|
|
| 62 |
# because default FALSE, removing value is the same as setting to FALSE |
|
| 63 | ! |
rm("opt.debug", envir = lavaan_cache_env)
|
| 64 |
} |
|
| 65 | ! |
return(TRUE) |
| 66 |
} else {
|
|
| 67 | 432x |
return(FALSE) |
| 68 |
} |
|
| 69 |
} |
|
| 70 |
} |
|
| 71 |
lav_verbose <- function(x) {
|
|
| 72 | 9839x |
optverbose <- get0("opt.verbose", lavaan_cache_env, ifnotfound = FALSE)
|
| 73 | 9839x |
if (missing(x)) {
|
| 74 | 9718x |
return(optverbose) |
| 75 |
} else {
|
|
| 76 | 121x |
setverbose <- as.logical(x) |
| 77 | 121x |
if (setverbose != optverbose) {
|
| 78 | ! |
if (setverbose) {
|
| 79 | ! |
assign("opt.verbose", TRUE, lavaan_cache_env)
|
| 80 |
} else {
|
|
| 81 |
# because default FALSE, removing value is the same as setting to FALSE |
|
| 82 | ! |
rm("opt.verbose", envir = lavaan_cache_env)
|
| 83 |
} |
|
| 84 | ! |
return(TRUE) |
| 85 |
} else {
|
|
| 86 | 121x |
return(FALSE) |
| 87 |
} |
|
| 88 |
} |
|
| 89 |
} |
|
| 90 | ||
| 91 |
# set the default options (including unspecified values "default") |
|
| 92 |
lav_options_default <- function() {
|
|
| 93 | 232x |
if (exists("opt.default", lavaan_cache_env)) {
|
| 94 | 231x |
opt <- get("opt.default", lavaan_cache_env)
|
| 95 | 231x |
return(opt) |
| 96 |
} |
|
| 97 |
# ---------------- preparation ----------------- |
|
| 98 | 1x |
opt.default <- list() |
| 99 | 1x |
opt.check <- list() |
| 100 | 1x |
elm <- function( |
| 101 | 1x |
name = NULL, # name of option, if length 2 first is sublist name |
| 102 | 1x |
dflt = NULL, # default value |
| 103 | 1x |
chr = NULL, # valid strings (names) and replacement values |
| 104 | 1x |
nm = NULL, # valid numeric interval |
| 105 | 1x |
bl = FALSE, # logical OK? |
| 106 | 1x |
oklen = c(1L, 1L), # lengte > 1 OK, second negative to have a warning |
| 107 |
# and not an error when length greater then abs(oklen[2]) |
|
| 108 | 1x |
num2int = FALSE # should numerical values be converted to int? |
| 109 |
) {
|
|
| 110 | 144x |
stopifnot(any(length(name) == 1:2)) |
| 111 | 144x |
stopifnot(is.null(nm) || (length(nm) == 1 && grepl("^[][].*,.*[][]$", nm)))
|
| 112 | 144x |
stopifnot(length(bl) == 1, is.logical(bl)) |
| 113 | 144x |
stopifnot(is.null(chr) || is.character(chr)) |
| 114 | 144x |
stopifnot(length(oklen) == 2, oklen[1] <= abs(oklen[2])) |
| 115 | 144x |
stopifnot(length(num2int) == 1, is.logical(num2int)) |
| 116 | ||
| 117 |
# prepare list to store for checking option |
|
| 118 | 144x |
list2store <- list(oklen = oklen) |
| 119 | 144x |
if (!is.null(chr)) {
|
| 120 | 35x |
if (is.null(names(chr))) names(chr) <- chr |
| 121 | 49x |
list2store$chr <- chr |
| 122 |
} |
|
| 123 | 144x |
if (!is.null(nm)) {
|
| 124 | 26x |
first.in <- grepl("^\\[", nm)
|
| 125 | 26x |
last.in <- grepl("\\]$", nm)
|
| 126 | 26x |
elems <- as.numeric(strsplit(gsub("[][ ]", "", nm), ",")[[1]])
|
| 127 | 26x |
if (num2int) {
|
| 128 | 6x |
elems[elems == -Inf] <- -2e9 |
| 129 | 6x |
elems[elems == Inf] <- 2e9 |
| 130 | 6x |
elems <- as.integer(elems) |
| 131 |
} |
|
| 132 | 26x |
list2store$nm <- list(bounds = elems, |
| 133 | 26x |
first.in = first.in, last.in = last.in) |
| 134 |
} |
|
| 135 | 67x |
if (bl) list2store$bl <- TRUE |
| 136 | 6x |
if (num2int) list2store$num2int <- TRUE |
| 137 | ||
| 138 |
# store default and list for checking |
|
| 139 | 120x |
if (length(name) == 1) name <- c("", name)
|
| 140 | 144x |
if (name[1] != "") {
|
| 141 | 24x |
if (is.null(opt.default[[name[1]]])) { # make sure sublists exist
|
| 142 | 1x |
opt.default[[name[1]]] <<- list() |
| 143 | 1x |
sublist <- list() |
| 144 | 1x |
attr(sublist, "SUB") <- TRUE # indicate as sublist |
| 145 | 1x |
opt.check[[name[1]]] <<- sublist |
| 146 |
} |
|
| 147 | 24x |
opt.default[[name[1]]][[name[2]]] <<- dflt |
| 148 | ! |
if (is.null(dflt)) opt.default[[name[1]]][name[2]] <<- list(NULL) |
| 149 | 24x |
opt.check[[name[1]]][[name[2]]] <<- list2store |
| 150 |
} else {
|
|
| 151 | 120x |
opt.default[[name[2]]] <<- dflt |
| 152 | 4x |
if (is.null(dflt)) opt.default[name[2]] <<- list(NULL) |
| 153 | 120x |
opt.check[[name[2]]] <<- list2store |
| 154 |
} |
|
| 155 | 144x |
NULL |
| 156 |
} |
|
| 157 | 1x |
elmdup <- function( |
| 158 | 1x |
name = NULL, # name(s) of option |
| 159 | 1x |
from = NULL # name(s) of option to duplicatie |
| 160 |
) {
|
|
| 161 | 1x |
if (length(name) == 1) name <- c("", name)
|
| 162 | 1x |
if (length(from) == 1) from <- c("", from)
|
| 163 | 1x |
if (from[1] != "") {
|
| 164 | ! |
from.default <- opt.default[[from[1]]][[from[2]]] |
| 165 | ! |
from.check <- opt.check[[from[1]]][[from[2]]] |
| 166 |
} else {
|
|
| 167 | 1x |
from.default <- opt.default[[from[2]]] |
| 168 | 1x |
from.check <- opt.check[[from[2]]] |
| 169 |
} |
|
| 170 | 1x |
if (name[1] != "") {
|
| 171 | ! |
if (is.null(opt.default[[name[1]]])) { # make sure sublists exist
|
| 172 | ! |
opt.default[[name[1]]] <<- list() |
| 173 | ! |
sublist <- list() |
| 174 | ! |
attr(sublist, "SUB") <- TRUE # indicate as sublist |
| 175 | ! |
opt.check[[name[1]]] <<- sublist |
| 176 |
} |
|
| 177 | ! |
opt.default[[name[1]]][[name[2]]] <<- from.default |
| 178 | ! |
opt.check[[name[1]]][[name[2]]] <<- from.check |
| 179 |
} else {
|
|
| 180 | 1x |
opt.default[[name[2]]] <<- from.default |
| 181 | 1x |
opt.check[[name[2]]] <<- from.check |
| 182 |
} |
|
| 183 |
} |
|
| 184 |
# ------------------------- store options -------------------------- |
|
| 185 | 1x |
elm("model.type", "sem", chr = c(lavaan = "lavaan", cfa = "cfa",
|
| 186 | 1x |
growth = "growth", sem = "sem", efa = "efa", path = "path", |
| 187 | 1x |
unrestricted = "unrestricted")) |
| 188 | ||
| 189 |
# global |
|
| 190 | 1x |
elm("mimic", "lavaan", chr = c(default = "lavaan", lavaan = "lavaan",
|
| 191 | 1x |
regression = "lm", lisrel = "EQS", |
| 192 | 1x |
eqs = "EQS", lm = "lm", mplus = "Mplus" |
| 193 |
)) |
|
| 194 | 1x |
elm("gls.v11.mplus", "default", chr = "default", bl = TRUE)
|
| 195 | 1x |
elm("gamma.vcov.mplus", "default", chr = "default", bl = TRUE)
|
| 196 | 1x |
elm("gamma.wls.mplus", "default", chr = "default", bl = TRUE)
|
| 197 | 1x |
elm("information.expected.mplus", "default", chr = "default", bl = TRUE)
|
| 198 | ||
| 199 |
# model modifiers |
|
| 200 | 1x |
elm("meanstructure", "default", chr = "default", bl = TRUE)
|
| 201 | 1x |
elm("int.ov.free", FALSE, bl = TRUE)
|
| 202 | 1x |
elm("int.lv.free", FALSE, bl = TRUE)
|
| 203 | 1x |
elm("marker.int.zero", FALSE, bl = TRUE) # fix maker intercepts
|
| 204 |
# free lv means |
|
| 205 | 1x |
elm("conditional.x", "default", chr = "default", bl = TRUE)
|
| 206 | 1x |
elm("fixed.x", "default", chr = "default", bl = TRUE)
|
| 207 | 1x |
elm("orthogonal", FALSE, bl = TRUE)
|
| 208 | 1x |
elm("orthogonal.x", FALSE, bl = TRUE)
|
| 209 | 1x |
elm("orthogonal.y", FALSE, bl = TRUE)
|
| 210 | 1x |
elm("std.lv", FALSE, bl = TRUE)
|
| 211 | 1x |
elm("correlation", FALSE, bl = TRUE) # correlation structure
|
| 212 | 1x |
elm("effect.coding", FALSE, chr = c("",
|
| 213 | 1x |
"loadings", "intercepts", |
| 214 | 1x |
"mg.lv.efa.variances", "mg.lv.variances", |
| 215 | 1x |
"mg.lv.means", "mg.lv.intercepts"), |
| 216 | 1x |
bl = TRUE, oklen = c(0L, 6L)) |
| 217 | 1x |
elm("ceq.simple", FALSE, bl = TRUE) # treat simple eq cons special?
|
| 218 | 1x |
elm("parameterization", "default", c(
|
| 219 | 1x |
"default", "mml", "delta", "theta")) |
| 220 | 1x |
elm("auto.fix.first", FALSE, bl = TRUE)
|
| 221 | 1x |
elm("auto.fix.single", FALSE, bl = TRUE)
|
| 222 | 1x |
elm("auto.var", FALSE, bl = TRUE)
|
| 223 | 1x |
elm("auto.cov.lv.x", FALSE, bl = TRUE)
|
| 224 | 1x |
elm("auto.cov.y", FALSE, bl = TRUE)
|
| 225 | 1x |
elm("auto.th", FALSE, bl = TRUE)
|
| 226 | 1x |
elm("auto.delta", FALSE, bl = TRUE)
|
| 227 | 1x |
elm("auto.efa", FALSE, bl = TRUE)
|
| 228 | 1x |
elm("composites", TRUE, bl = TRUE)
|
| 229 | ||
| 230 |
# rotation |
|
| 231 | 1x |
elm("rotation", "geomin", chr = c(crawfer = "cf", crawford.ferguson = "cf",
|
| 232 | 1x |
crawfordferguson = "cf", cf = "cf", |
| 233 | 1x |
varimax = "varimax", quartimax = "quartimax", orthomax = "orthomax", |
| 234 | 1x |
oblimin = "oblimin", quartimin = "quartimin", geomin = "geomin", |
| 235 | 1x |
entropy = "entropy", mccammon = "mccammon", infomax = "infomax", |
| 236 | 1x |
tandem1 = "tandem1", tandem2 = "tandem2", none = "none", promax = "promax", |
| 237 | 1x |
oblimax = "oblimax", bentler = "bentler", simplimax = "simplimax", |
| 238 | 1x |
target.strict = "target.strict", target = "pst", pst = "pst", |
| 239 | 1x |
cf.quartimax = "cf-quartimax", cf.varimax = "cf-varimax", |
| 240 | 1x |
cf.equamax = "cf-equamax", cf.parsimax = "cf-parsimax", |
| 241 | 1x |
cf.facparsim = "cf-facparsim", bi.quartimin = "biquartimin", |
| 242 | 1x |
biquartimin = "biquartimin", bi.geomin = "bigeomin", bigeomin = "bigeomin" |
| 243 |
)) |
|
| 244 | 1x |
elm("rotation.se", "bordered", chr = c("delta", "bordered"))
|
| 245 | ||
| 246 |
# rotation-args sublist |
|
| 247 | 1x |
elm(c("rotation.args", "orthogonal"), FALSE, bl = TRUE)
|
| 248 | 1x |
elm(c("rotation.args", "row.weights"), "default", chr = c(
|
| 249 | 1x |
default = "default", kaiser = "kaiser", none = "none", |
| 250 | 1x |
cureton.mulaik = "cm", cm = "cm")) |
| 251 | 1x |
elm(c("rotation.args", "std.ov"), TRUE, bl = TRUE)
|
| 252 | 1x |
elm(c("rotation.args", "geomin.epsilon"), 0.001, nm = "]0, 1.00]")
|
| 253 |
# was 0.01 < 0.6-10 |
|
| 254 | 1x |
elm(c("rotation.args", "orthomax.gamma"), 1, nm = "[0, 1]")
|
| 255 | 1x |
elm(c("rotation.args", "cf.gamma"), 0, nm = "[0, 1]")
|
| 256 | 1x |
elm(c("rotation.args", "oblimin.gamma"), 0, nm = "[0, 1000]")
|
| 257 | 1x |
elm(c("rotation.args", "promax.kappa"), 4, nm = "[0, 1000]")
|
| 258 | 1x |
elm(c("rotation.args", "target"), matrix(0, 0L, 0L), oklen = c(0, 1e+32))
|
| 259 | 1x |
elm(c("rotation.args", "target.mask"), matrix(0, 0L, 0L), oklen = c(0, 1e+32))
|
| 260 | 1x |
elm(c("rotation.args", "rstarts"), 30L, nm = "[0, 1e+07]")
|
| 261 | 1x |
elm(c("rotation.args", "algorithm"), "gpa", chr = c("gpa", "pairwise"))
|
| 262 | 1x |
elm(c("rotation.args", "reflect"), TRUE, bl = TRUE)
|
| 263 | 1x |
elm(c("rotation.args", "order.lv.by"), "index",
|
| 264 | 1x |
chr = c("sumofsquares", "index", "none"))
|
| 265 | 1x |
elm(c("rotation.args", "gpa.tol"), 1e-05, nm = "]0, 0.01]")
|
| 266 | 1x |
elm(c("rotation.args", "tol"), 1e-08, nm = "]0, 0.01]")
|
| 267 | 1x |
elm(c("rotation.args", "warn"), FALSE, bl = TRUE)
|
| 268 | 1x |
elm(c("rotation.args", "verbose"), FALSE, bl = TRUE)
|
| 269 | 1x |
elm(c("rotation.args", "jac.init.rot"), TRUE, bl = TRUE)
|
| 270 | 1x |
elm(c("rotation.args", "max.iter"), 10000L, nm = "[0, 1e+12]")
|
| 271 | 1x |
elm(c("rotation.args", "mg.agreement"), FALSE, bl = TRUE)
|
| 272 | 1x |
elm(c("rotation.args", "mg.agreement.weight"), 0.5, nm = "[0, 1]")
|
| 273 | 1x |
elm(c("rotation.args", "mg.agreement.algorithm"), "pairwise",
|
| 274 | 1x |
chr = c("pairwise", "lg"))
|
| 275 | 1x |
elm(c("rotation.args", "mg.agreement.method"), "procrustes",
|
| 276 | 1x |
chr = c("procrustes", "loading.alignment"))
|
| 277 | ||
| 278 |
# full data |
|
| 279 | 1x |
elm("std.ov", FALSE, bl = TRUE)
|
| 280 | 1x |
elm("missing", "default", chr = c(
|
| 281 | 1x |
default = "default", ml = "ml", direct = "ml", |
| 282 | 1x |
ml.x = "ml.x", direct.x = "ml.x", fiml.x = "ml.x", fiml = "ml", |
| 283 | 1x |
two.stage = "two.stage", twostage = "two.stage", two.step = "two.stage", |
| 284 | 1x |
twostep = "two.stage", robust.two.stage = "robust.two.stage", |
| 285 | 1x |
robust.twostage = "robust.two.stage", |
| 286 | 1x |
robust.two.step = "robust.two.stage", |
| 287 | 1x |
robust.twostep = "robust.two.stage", |
| 288 | 1x |
two.stage.robust = "robust.two.stage", |
| 289 | 1x |
twostage.robust = "robust.two.stage", |
| 290 | 1x |
two.step.robust = "robust.two.stage", |
| 291 | 1x |
twostep.robust = "robust.two.stage", |
| 292 | 1x |
listwise = "listwise", pairwise = "pairwise", |
| 293 | 1x |
available.cases = "available.cases", doubly.robust = "doubly.robust")) |
| 294 | 1x |
elm("sampling.weights.normalization", "total", chr = c(
|
| 295 | 1x |
"total", "group", "none")) |
| 296 | 1x |
elm("samplestats", TRUE, bl = TRUE)
|
| 297 | ||
| 298 |
# summary data |
|
| 299 | 1x |
elm("sample.cov.rescale", "default", bl = TRUE)
|
| 300 | 1x |
elm("sample.cov.robust", FALSE, bl = TRUE)
|
| 301 | 1x |
elm("sample.icov", TRUE, bl = TRUE)
|
| 302 | 1x |
elm("ridge", FALSE, bl = TRUE)
|
| 303 | 1x |
elm("ridge.constant", "default", chr = "default", nm = "[0, Inf[")
|
| 304 | ||
| 305 |
# multiple groups !!! group.label and group.partial capitals OK !!! |
|
| 306 | 1x |
elm("group.label", NULL, oklen = c(0L, 100L)) # no checks
|
| 307 | 1x |
elm("group.equal", "", chr =
|
| 308 | 1x |
c("", "none", "loadings", "intercepts", "means", "composite.loadings",
|
| 309 | 1x |
"composite.weights", |
| 310 | 1x |
"regressions", "residuals", "residual.covariances", "thresholds", |
| 311 | 1x |
"lv.variances", "lv.covariances"), oklen = c(0L, 100L)) |
| 312 | 1x |
elm("group.partial", "", oklen = c(0L, 100L)) # no checks
|
| 313 | 1x |
elm("group.w.free", FALSE, bl = TRUE)
|
| 314 | ||
| 315 |
# clusters |
|
| 316 | 1x |
elm("level.label", NULL, oklen = c(0L, 100L)) # no checks
|
| 317 | ||
| 318 |
# estimation |
|
| 319 | 1x |
elm("estimator", "default", chr = c(
|
| 320 | 1x |
none = "none", default = "default", wlsmv = "wlsmv", ml = "ml", mlr = "mlr", |
| 321 | 1x |
mlf = "mlf", mlm = "mlm", mlmv = "mlmv", mlmvs = "mlmvs", gls = "gls", |
| 322 | 1x |
wls = "wls", wlsm = "wlsm", uls = "uls", ulsm = "ulsm", ulsmv = "ulsmv", |
| 323 | 1x |
pml = "pml", dls = "dls", ntrls = "ntrls", catml = "catml", |
| 324 | 1x |
dwls = "dwls", wlsmvs = "wlsmvs", ulsmvs = "ulsmvs", fml = "fml", |
| 325 | 1x |
umn = "fml", reml = "reml", mml = "mml", fabin = "fabin2", |
| 326 | 1x |
fabin2 = "fabin2", fabin3 = "fabin3", mgm = "mgm", guttman = "mgm", |
| 327 | 1x |
gutman = "mgm", gutmann = "mgm", guttman1952 = "mgm", |
| 328 | 1x |
js = "js", jsa = "jsa", james.stein = "js", |
| 329 | 1x |
james.stein.aggregated = "jsa", bentler = "bentler1982", |
| 330 | 1x |
bentler1982 = "bentler1982", miiv = "iv", iv = "iv", |
| 331 | 1x |
miiv.2sls = "iv" |
| 332 |
)) |
|
| 333 | 1x |
elmdup("estimator.orig", "estimator")
|
| 334 | ||
| 335 | 1x |
elm("estimator.args", list(), oklen = c(0L, 100L))
|
| 336 | 1x |
elm("likelihood", "default", chr = c("default", "normal", "wishart"))
|
| 337 | 1x |
elm("link", "default", chr = c("default", "logit", "probit"))
|
| 338 | 1x |
elm("representation", "default", chr = c(
|
| 339 | 1x |
default = "LISREL", lisrel = "LISREL", ram = "RAM")) |
| 340 | 1x |
elm("do.fit", TRUE, bl = TRUE)
|
| 341 | 1x |
elm("bounds", "none", chr = c(
|
| 342 | 1x |
"none", "default", "standard", "user", "wide", "wide.zerovar", "pos.var", |
| 343 | 1x |
"pos.ov.var", "pos.lv.var")) # new in 0.6-6 |
| 344 | 1x |
elm("rstarts", 0L, nm = "[0, 10000]", num2int = TRUE) # new in 0.6-18
|
| 345 | ||
| 346 |
# inference |
|
| 347 | 1x |
elm("se", "default", chr = c(
|
| 348 | 1x |
default = "default", none = "none", standard = "standard", |
| 349 | 1x |
robust.huber.white = "robust.huber.white", robust = "robust", |
| 350 | 1x |
robust.cluster = "robust.cluster", |
| 351 | 1x |
robust.cluster.sem = "robust.cluster.sem", |
| 352 | 1x |
sandwich = "robust.huber.white", robust.sem = "robust.sem", |
| 353 | 1x |
robust.sem.nt = "robust.sem.nt", |
| 354 | 1x |
two.stage = "two.stage", robust.two.stage = "robust.two.stage", |
| 355 | 1x |
bootstrap = "bootstrap", boot = "bootstrap", first.order = "first.order", |
| 356 | 1x |
robust.mlm.nt = "robust.sem.nt", |
| 357 | 1x |
robust.mlm = "robust.sem", robust.mlr = "robust.huber.white", |
| 358 | 1x |
observed = "observed", expected = "expected"), |
| 359 | 1x |
oklen = c(1L, -1L) |
| 360 |
) |
|
| 361 | 1x |
elm("test", "default", oklen = c(1L, 100L))
|
| 362 |
# checks for 'test' are in lav_test_rename !!! |
|
| 363 | ||
| 364 |
# information (se + test) |
|
| 365 | 1x |
elm("information", c("default", "default"), chr = c(
|
| 366 | 1x |
"default", "expected", "observed", "first.order"), |
| 367 | 1x |
oklen = c(1L, 2L)) |
| 368 | 1x |
elm("h1.information", c("structured", "structured"), chr = c(
|
| 369 | 1x |
"structured", "unstructured"), oklen = c(1L, 2L)) |
| 370 | 1x |
elm("observed.information", c("hessian", "default"), chr = c(
|
| 371 | 1x |
"default", "hessian", "h1"), oklen = c(1L, 2L)) |
| 372 | ||
| 373 |
# information se only |
|
| 374 | 1x |
elm("information.meat", "default",
|
| 375 | 1x |
chr = c(default = "first.order", first.order = "first.order")) |
| 376 | 1x |
elm("h1.information.meat", "default", chr = c(
|
| 377 | 1x |
"default", "structured", "unstructured")) |
| 378 | ||
| 379 |
# information for 'Omega' (yuan-benter test only) |
|
| 380 | 1x |
elm("omega.information", "default", chr = c(
|
| 381 | 1x |
"default", "expected", "observed" |
| 382 |
)) |
|
| 383 | 1x |
elm("omega.h1.information", "default", chr = c(
|
| 384 | 1x |
"default", "structured", "unstructured" |
| 385 |
)) |
|
| 386 | 1x |
elm("omega.information.meat", "default", chr = c(
|
| 387 | 1x |
default = "first.order", first.order = "first.order" |
| 388 |
)) |
|
| 389 | 1x |
elm("omega.h1.information.meat", "default", chr = c(
|
| 390 | 1x |
"default", "structured", "unstructured" |
| 391 |
)) |
|
| 392 | ||
| 393 |
# test statistic for fit measures |
|
| 394 | 1x |
elm("standard.test", "standard", oklen = c(1L, 100L))
|
| 395 | ||
| 396 |
# test statistic for scaling |
|
| 397 | 1x |
elm("scaled.test", "standard", oklen = c(1L, 100L))
|
| 398 | ||
| 399 |
# old approach trace.UGamma2 |
|
| 400 | 1x |
elm("ug2.old.approach", FALSE, bl = TRUE)
|
| 401 | ||
| 402 |
# bootstrap |
|
| 403 | 1x |
elm("bootstrap", list(R = 1000L))
|
| 404 | ||
| 405 |
# gamma |
|
| 406 | 1x |
elm("gamma.n.minus.one", FALSE, bl = TRUE)
|
| 407 | 1x |
elm("gamma.unbiased", FALSE, bl = TRUE)
|
| 408 | ||
| 409 |
# optimization |
|
| 410 | 1x |
elm("control", list(), oklen = c(0L, 100L))
|
| 411 | 1x |
elm("optim.method", "default", chr = c(
|
| 412 | 1x |
"nlminb", "nlminb0", "nlminb1", "nlminb2", |
| 413 | 1x |
"bfgs", "l.bfgs.b", "gn", "default", "noniter", "none", "em" |
| 414 | 1x |
)) # gn for DLS, nlminb rest |
| 415 | 1x |
elm("optim.attempts", 4L, nm = "[1, 4]")
|
| 416 | 1x |
elm("optim.force.converged", FALSE, bl = TRUE)
|
| 417 | 1x |
elm("optim.gradient", "analytic", chr = c(
|
| 418 | 1x |
analytic = "analytic", analytical = "analytic", |
| 419 | 1x |
numeric = "numerical", numerical = "numerical" |
| 420 |
)) |
|
| 421 | 1x |
elm("optim.init_nelder_mead", FALSE, bl = TRUE)
|
| 422 | 1x |
elm("optim.var.transform", "none", chr = c(
|
| 423 | 1x |
"none", "sqrt" |
| 424 |
)) |
|
| 425 | 1x |
elm("optim.parscale", "none", chr = c(
|
| 426 | 1x |
none = "none", st = "standardized", stand = "standardized", |
| 427 | 1x |
standardize = "standardized", standardized = "standardized" |
| 428 |
)) |
|
| 429 | 1x |
elm("optim.partrace", FALSE, bl = TRUE)
|
| 430 | 1x |
elm("optim.dx.tol", 1e-03, nm = "]0, 0.01]") # not too strict
|
| 431 | 1x |
elm("optim.bounds", list(), oklen = c(0L, 100L))
|
| 432 | 1x |
elm("em.iter.max", 10000L, nm = "[100, 1e8]", num2int = TRUE)
|
| 433 | 1x |
elm("em.fx.tol", 1e-08, nm = "]0, 0.01]")
|
| 434 | 1x |
elm("em.dx.tol", 1e-04, nm = "]0, 0.01]")
|
| 435 | 1x |
elm("em.zerovar.offset", 0.0001, nm = "]0, 0.01]")
|
| 436 | 1x |
elm("em.h1.iter.max", 500L, nm = "[10, 1e7]", num2int = TRUE)
|
| 437 | 1x |
elm("em.h1.tol", 1e-05, nm = "]0, 0.01]") # was 1e-06 < 0.6-9
|
| 438 | 1x |
elm("em.h1.warn", TRUE, bl = TRUE)
|
| 439 | 1x |
elm("optim.gn.iter.max", 200L, nm = "[100, 1e8]", num2int = TRUE)
|
| 440 | 1x |
elm("optim.gn.stephalf.max", 10L, nm = "[1, 1e8]", num2int = TRUE)
|
| 441 | 1x |
elm("optim.gn.tol.x", 1e-05, nm = "]0, 0.01]")
|
| 442 | ||
| 443 |
# numerical integration |
|
| 444 | 1x |
elm("integration.ngh", 21L, nm = "[1, 1000]", num2int = TRUE)
|
| 445 | ||
| 446 |
# parallel |
|
| 447 | 1x |
elm("parallel", "no", chr = c(
|
| 448 | 1x |
"no", "multicore", "snow" |
| 449 |
)) |
|
| 450 | 1x |
maxcpu <- max(1L, parallel::detectCores() - 1L) |
| 451 | 1x |
elm("ncpus", maxcpu, nm = paste0("[1,", maxcpu, "]"))
|
| 452 | 1x |
elm("cl", NULL, oklen = c(0L, 1L))
|
| 453 | 1x |
elm("iseed", NULL, oklen = c(0L, 1L))
|
| 454 | ||
| 455 |
# categorical |
|
| 456 | 1x |
elm("zero.add", c(0.5, 0.0), chr = "default",
|
| 457 | 1x |
nm = "[0, 1]", oklen = c(1L, -2L)) |
| 458 | 1x |
elm("zero.keep.margins", "default", chr = "default", bl = TRUE)
|
| 459 | 1x |
elm("zero.cell.warn", FALSE, bl = TRUE) # since 0.6-1
|
| 460 | 1x |
elm("allow.empty.cell", FALSE, bl = TRUE) # since 0.6-19
|
| 461 | 1x |
elm("cat.wls.w", TRUE, bl = TRUE) # since 0.6-18
|
| 462 | ||
| 463 |
# starting values (char values checked in lav_options_set()) |
|
| 464 | 1x |
elm("start", "default", oklen = c(1L, 1000L))
|
| 465 | ||
| 466 |
# sanity checks |
|
| 467 | 1x |
elm("check.start", TRUE, bl = TRUE)
|
| 468 | 1x |
elm("check.sigma.pd", "chol", chr = c("chol", "eigen")) # stored in env
|
| 469 | 1x |
elm("check.post", TRUE, bl = TRUE)
|
| 470 | 1x |
elm("check.gradient", TRUE, bl = TRUE)
|
| 471 | 1x |
elm("check.vcov", TRUE, bl = TRUE)
|
| 472 | 1x |
elm("check.lv.names", TRUE, bl = TRUE)
|
| 473 | 1x |
elm("check.lv.interaction", TRUE, bl = TRUE)
|
| 474 | 1x |
elm("check.delta.cat.mediator", TRUE, bl = TRUE)
|
| 475 | ||
| 476 |
# more models/info |
|
| 477 | 1x |
elm("h1", TRUE, bl = TRUE)
|
| 478 | 1x |
elm("baseline", TRUE, bl = TRUE)
|
| 479 | 1x |
elm("baseline.type", "independence", chr = c(indep = "independence",
|
| 480 | 1x |
independence = "independence", nested = "nested")) |
| 481 | 1x |
elm("baseline.conditional.x.free.slopes", TRUE, bl = TRUE)
|
| 482 | 1x |
elm("baseline.fixed.x.free.cov", TRUE, bl = TRUE)
|
| 483 | 1x |
elm("implied", TRUE, bl = TRUE)
|
| 484 | 1x |
elm("loglik", TRUE, bl = TRUE)
|
| 485 | ||
| 486 |
# storage of information |
|
| 487 | 1x |
elm("store.vcov", "default", chr = "default", bl = TRUE)
|
| 488 | ||
| 489 |
# internal |
|
| 490 | 1x |
elm("parser", "new", chr = c(old = "old", orig = "old", new = "new",
|
| 491 | 1x |
c.r = "c.r", cr = "c.r", classic = "old")) |
| 492 | ||
| 493 |
# categorical |
|
| 494 | 1x |
elm("categorical", "default", chr = "default", bl = TRUE)
|
| 495 | ||
| 496 |
# sort list and sublists |
|
| 497 | 1x |
for (nm in names(opt.default)) {
|
| 498 | 122x |
if (is.list(opt.default[[nm]])) |
| 499 | 5x |
opt.default[[nm]] <- opt.default[[nm]][sort(names(opt.default[[nm]]))] |
| 500 |
} |
|
| 501 | 1x |
opt.default <- opt.default[sort(names(opt.default))] |
| 502 |
# ------------- store info in lavaan environment --------------- |
|
| 503 | 1x |
assign("opt.default", opt.default, lavaan_cache_env)
|
| 504 | 1x |
assign("opt.check", opt.check, lavaan_cache_env)
|
| 505 | 1x |
assign("opt.check.sigma.pd", "chol", lavaan_cache_env)
|
| 506 | ||
| 507 |
# return defaults |
|
| 508 | 1x |
return(opt.default) |
| 509 |
} |
|
| 510 | ||
| 511 |
# public function |
|
| 512 |
lavOptions <- function(x = NULL, default = NULL, mimic = "lavaan") { # nolint
|
|
| 513 | 60x |
lavoptions <- lav_options_default() |
| 514 | ||
| 515 |
# selection only |
|
| 516 | 60x |
if (!is.null(x)) {
|
| 517 | ! |
if (is.character(x)) {
|
| 518 |
# lower case only |
|
| 519 | ! |
x <- tolower(x) |
| 520 | ||
| 521 |
# check if x is in names(lavoptions) |
|
| 522 | ! |
not.ok <- which(!x %in% names(lavoptions)) |
| 523 | ! |
if (length(not.ok) > 0L) {
|
| 524 | ! |
lav_msg_warn(gettextf( |
| 525 | ! |
"option(s) %s not available", lav_msg_view(x[not.ok])) |
| 526 |
) |
|
| 527 | ! |
x <- x[-not.ok] |
| 528 |
} |
|
| 529 | ||
| 530 |
# return requested option(s) |
|
| 531 | ! |
if (length(x) == 0L) {
|
| 532 | ! |
return(default) |
| 533 |
} else {
|
|
| 534 | ! |
lavoptions[x] |
| 535 |
} |
|
| 536 |
} else {
|
|
| 537 | ! |
lav_msg_stop(gettext("`x' must be a character string"))
|
| 538 |
} |
|
| 539 |
} else {
|
|
| 540 | 60x |
lavoptions |
| 541 |
} |
|
| 542 |
} |
| 1 |
# loglikelihood clustered/twolevel data |
|
| 2 | ||
| 3 |
# YR: first version around Feb 2017 |
|
| 4 |
# YR 28 Oct 2024: [EM steps:] if fx.delta is NA, check if we have (near)-perfect |
|
| 5 |
# correlations, and provide an informative warning |
|
| 6 | ||
| 7 | ||
| 8 |
# take model-implied mean+variance matrices, and reorder/augment them |
|
| 9 |
# to facilitate computing of (log)likelihood in the two-level case |
|
| 10 | ||
| 11 |
# when conditional.x = FALSE: |
|
| 12 |
# - sigma.w and sigma.b: same dimensions, level-1 variables only |
|
| 13 |
# - sigma.zz: level-2 variables only |
|
| 14 |
# - sigma.yz: cov(level-1, level-2) |
|
| 15 |
# - mu.y: level-1 variables only (mu.w + mu.b) |
|
| 16 |
# - mu.w: y within part |
|
| 17 |
# - mu.b: y between part |
|
| 18 |
# - mu.z: level-2 variables only |
|
| 19 |
lav_mvnorm_cluster_implied22l <- function(Lp = NULL, |
|
| 20 |
implied = NULL, |
|
| 21 |
Mu.W = NULL, |
|
| 22 |
Mu.B = NULL, |
|
| 23 |
Sigma.W = NULL, |
|
| 24 |
Sigma.B = NULL) {
|
|
| 25 | 1764x |
if (!is.null(implied)) {
|
| 26 |
# FIXME: only for single-group analysis! |
|
| 27 | 16x |
Sigma.W <- implied$cov[[1]] |
| 28 | 16x |
Mu.W <- implied$mean[[1]] |
| 29 | ||
| 30 | 16x |
Sigma.B <- implied$cov[[2]] |
| 31 | 16x |
Mu.B <- implied$mean[[2]] |
| 32 |
} |
|
| 33 | ||
| 34 |
# within/between.idx |
|
| 35 | 1764x |
between.idx <- Lp$between.idx[[2]] |
| 36 | 1764x |
within.idx <- Lp$within.idx[[2]] |
| 37 | 1764x |
both.idx <- Lp$both.idx[[2]] |
| 38 | ||
| 39 |
# ov.idx per level |
|
| 40 | 1764x |
ov.idx <- Lp$ov.idx |
| 41 | ||
| 42 |
# 'tilde' matrices: ALL variables within and between |
|
| 43 | 1764x |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 44 | ||
| 45 |
# Sigma.W.tilde |
|
| 46 | 1764x |
Sigma.W.tilde <- matrix(0, p.tilde, p.tilde) |
| 47 | 1764x |
Sigma.W.tilde[ov.idx[[1]], ov.idx[[1]]] <- Sigma.W |
| 48 | ||
| 49 |
# Sigma.B.tilde |
|
| 50 | 1764x |
Sigma.B.tilde <- matrix(0, p.tilde, p.tilde) |
| 51 | 1764x |
Sigma.B.tilde[ov.idx[[2]], ov.idx[[2]]] <- Sigma.B |
| 52 | ||
| 53 |
# Mu.W.tilde |
|
| 54 | 1764x |
Mu.W.tilde <- numeric(p.tilde) |
| 55 | 1764x |
Mu.W.tilde[ov.idx[[1]]] <- Mu.W |
| 56 | ||
| 57 |
# Mu.B.tilde |
|
| 58 | 1764x |
Mu.B.tilde <- numeric(p.tilde) |
| 59 | 1764x |
Mu.B.tilde[ov.idx[[2]]] <- Mu.B |
| 60 | ||
| 61 |
# add Mu.W[within.idx] to Mu.B |
|
| 62 | 1764x |
Mu.WB.tilde <- numeric(p.tilde) |
| 63 | 1764x |
Mu.WB.tilde[within.idx] <- Mu.W.tilde[within.idx] |
| 64 | 1764x |
Mu.WB.tilde[both.idx] <- (Mu.B.tilde[both.idx] + |
| 65 | 1764x |
Mu.W.tilde[both.idx]) |
| 66 | ||
| 67 |
# set Mu.W[both.idx] to zero (after we added to WB) |
|
| 68 | 1764x |
Mu.W.tilde[both.idx] <- 0 |
| 69 |
# get Mu.B[both.idx[ from WB |
|
| 70 | 1764x |
Mu.B.tilde[both.idx] <- Mu.WB.tilde[both.idx] |
| 71 | ||
| 72 |
# map to matrices needed for loglik |
|
| 73 | 1764x |
if (length(within.idx) > 0L) {
|
| 74 | ! |
Mu.B.tilde[within.idx] <- 0 |
| 75 |
} |
|
| 76 | 1764x |
if (length(between.idx) > 0L) {
|
| 77 | ! |
mu.z <- Mu.B.tilde[between.idx] |
| 78 | ! |
mu.y <- Mu.WB.tilde[-between.idx] |
| 79 | ! |
mu.w <- Mu.W.tilde[-between.idx] |
| 80 | ! |
mu.b <- Mu.B.tilde[-between.idx] |
| 81 | ! |
sigma.zz <- Sigma.B.tilde[between.idx, between.idx, drop = FALSE] |
| 82 | ! |
sigma.yz <- Sigma.B.tilde[-between.idx, between.idx, drop = FALSE] |
| 83 | ! |
sigma.b <- Sigma.B.tilde[-between.idx, -between.idx, drop = FALSE] |
| 84 | ! |
sigma.w <- Sigma.W.tilde[-between.idx, -between.idx, drop = FALSE] |
| 85 |
} else {
|
|
| 86 | 1764x |
mu.z <- numeric(0L) |
| 87 | 1764x |
mu.y <- Mu.WB.tilde |
| 88 | 1764x |
mu.w <- Mu.W.tilde |
| 89 | 1764x |
mu.b <- Mu.B.tilde |
| 90 | 1764x |
sigma.zz <- matrix(0, 0L, 0L) |
| 91 | 1764x |
sigma.yz <- matrix(0, nrow(Sigma.B.tilde), 0L) |
| 92 | 1764x |
sigma.b <- Sigma.B.tilde |
| 93 | 1764x |
sigma.w <- Sigma.W.tilde |
| 94 |
} |
|
| 95 | ||
| 96 | 1764x |
list( |
| 97 | 1764x |
sigma.w = sigma.w, sigma.b = sigma.b, sigma.zz = sigma.zz, |
| 98 | 1764x |
sigma.yz = sigma.yz, mu.z = mu.z, mu.y = mu.y, mu.w = mu.w, |
| 99 | 1764x |
mu.b = mu.b |
| 100 |
) |
|
| 101 |
} |
|
| 102 | ||
| 103 |
lav_mvnorm_cluster_2l2implied <- function(Lp, |
|
| 104 |
sigma.w = NULL, |
|
| 105 |
sigma.b = NULL, |
|
| 106 |
sigma.zz = NULL, |
|
| 107 |
sigma.yz = NULL, |
|
| 108 |
mu.z = NULL, |
|
| 109 |
mu.y = NULL, |
|
| 110 |
mu.w = NULL, |
|
| 111 |
mu.b = NULL) {
|
|
| 112 |
# between.idx |
|
| 113 | 1394x |
between.idx <- Lp$between.idx[[2]] |
| 114 | 1394x |
within.idx <- Lp$within.idx[[2]] |
| 115 | 1394x |
both.idx <- Lp$both.idx[[2]] |
| 116 | ||
| 117 |
# ov.idx per level |
|
| 118 | 1394x |
ov.idx <- Lp$ov.idx |
| 119 | ||
| 120 |
# 'tilde' matrices: ALL variables within and between |
|
| 121 | 1394x |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 122 | ||
| 123 |
# if we have mu.y, convert to mu.w and mu.b |
|
| 124 | 1394x |
if (!is.null(mu.y)) {
|
| 125 | 1310x |
mu.b <- mu.y |
| 126 | 1310x |
mu.w.tilde <- numeric(p.tilde) |
| 127 | 1310x |
mu.w.tilde[ov.idx[[1]]] <- mu.y |
| 128 | ||
| 129 |
# NO NEED TO SET THIS TO ZERO! |
|
| 130 |
# otherwise, we get non-symmetric Hessian!! 0.6-5 |
|
| 131 | ||
| 132 |
# if(length(within.idx) > 0L) {
|
|
| 133 |
# mu.w.tilde[ -within.idx ] <- 0 |
|
| 134 |
# } else {
|
|
| 135 |
# mu.w.tilde[] <- 0 |
|
| 136 |
# } |
|
| 137 | 1310x |
mu.w <- mu.w.tilde[ov.idx[[1]]] |
| 138 |
} |
|
| 139 | ||
| 140 |
# new in 0.6-18: ensure mu.w[both.idx] is zero? |
|
| 141 |
# NO: we get Hessian is not fully symmetric again!! |
|
| 142 |
# only do this at the very end (post-estimation) |
|
| 143 | ||
| 144 |
# Mu.W.tilde <- numeric(p.tilde) |
|
| 145 |
# Mu.B.tilde <- numeric(p.tilde) |
|
| 146 |
# Mu.W.tilde[ov.idx[[1]]] <- mu.w |
|
| 147 |
# Mu.B.tilde[ov.idx[[2]]] <- mu.b |
|
| 148 |
# Mu.B.tilde[between.idx] <- mu.z |
|
| 149 |
# if (length(within.idx) > 0) {
|
|
| 150 |
# Mu.B.tilde[within.idx] <- 0 |
|
| 151 |
# } |
|
| 152 |
# Mu.B.tilde[both.idx] <- Mu.W.tilde[both.idx] + Mu.B.tilde[both.idx] |
|
| 153 |
# Mu.W.tilde[both.idx] <- 0 |
|
| 154 |
# Mu.W <- Mu.W.tilde[ov.idx[[1]]] |
|
| 155 |
# Mu.B <- Mu.B.tilde[ov.idx[[2]]] |
|
| 156 | ||
| 157 | 1394x |
Mu.W.tilde <- numeric( p.tilde ) |
| 158 |
###### DEBUG ############## |
|
| 159 |
#if(length(within.idx) > 0) {
|
|
| 160 | 1394x |
Mu.W.tilde[ ov.idx[[1]] ] <- mu.w |
| 161 |
#} |
|
| 162 |
########################### |
|
| 163 | 1394x |
Mu.W <- Mu.W.tilde[ ov.idx[[1]] ] |
| 164 | ||
| 165 |
# Mu.B |
|
| 166 | 1394x |
Mu.B.tilde <- numeric(p.tilde) |
| 167 | 1394x |
Mu.B.tilde[ ov.idx[[1]] ] <- mu.b |
| 168 | 1394x |
Mu.B.tilde[ between.idx ] <- mu.z |
| 169 | 1394x |
if(length(within.idx) > 0) {
|
| 170 | ! |
Mu.B.tilde[within.idx] <- 0 |
| 171 |
} |
|
| 172 | 1394x |
Mu.B <- Mu.B.tilde[ ov.idx[[2]] ] |
| 173 | ||
| 174 | ||
| 175 |
# Sigma.W |
|
| 176 | 1394x |
Sigma.W <- sigma.w |
| 177 | ||
| 178 |
# Sigma.B |
|
| 179 | 1394x |
Sigma.B.tilde <- matrix(0, p.tilde, p.tilde) |
| 180 | 1394x |
Sigma.B.tilde[ov.idx[[1]], ov.idx[[1]]] <- sigma.b |
| 181 | 1394x |
Sigma.B.tilde[ov.idx[[1]], between.idx] <- sigma.yz |
| 182 | 1394x |
Sigma.B.tilde[between.idx, ov.idx[[1]]] <- t(sigma.yz) |
| 183 | 1394x |
Sigma.B.tilde[between.idx, between.idx] <- sigma.zz |
| 184 | 1394x |
Sigma.B <- Sigma.B.tilde[ov.idx[[2]], ov.idx[[2]], drop = FALSE] |
| 185 | ||
| 186 | 1394x |
list(Mu.W = Mu.W, Mu.B = Mu.B, Sigma.W = Sigma.W, Sigma.B = Sigma.B) |
| 187 |
} |
|
| 188 | ||
| 189 | ||
| 190 |
# Mu.W, Mu.B, Sigma.W, Sigma.B are the model-implied statistics |
|
| 191 |
# (not yet reordered) |
|
| 192 |
lav_mvnorm_cluster_loglik_samplestats_2l <- function(YLp = NULL, |
|
| 193 |
Lp = NULL, |
|
| 194 |
Mu.W = NULL, |
|
| 195 |
Sigma.W = NULL, |
|
| 196 |
Mu.B = NULL, |
|
| 197 |
Sigma.B = NULL, |
|
| 198 |
Sinv.method = "eigen", |
|
| 199 |
log2pi = FALSE, |
|
| 200 |
minus.two = TRUE) {
|
|
| 201 |
# map implied to 2l matrices |
|
| 202 | 432x |
out <- lav_mvnorm_cluster_implied22l( |
| 203 | 432x |
Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, |
| 204 | 432x |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 205 |
) |
|
| 206 | 432x |
mu.y <- out$mu.y |
| 207 | 432x |
mu.z <- out$mu.z |
| 208 | 432x |
sigma.w <- out$sigma.w |
| 209 | 432x |
sigma.b <- out$sigma.b |
| 210 | 432x |
sigma.zz <- out$sigma.zz |
| 211 | 432x |
sigma.yz <- out$sigma.yz |
| 212 | ||
| 213 |
# Lp |
|
| 214 | 432x |
nclusters <- Lp$nclusters[[2]] |
| 215 | 432x |
cluster.size <- Lp$cluster.size[[2]] |
| 216 | 432x |
between.idx <- Lp$between.idx[[2]] |
| 217 | 432x |
cluster.sizes <- Lp$cluster.sizes[[2]] |
| 218 | 432x |
ncluster.sizes <- Lp$ncluster.sizes[[2]] |
| 219 | 432x |
cluster.size.ns <- Lp$cluster.size.ns[[2]] |
| 220 | ||
| 221 |
# Y1 samplestats |
|
| 222 | 432x |
if (length(between.idx) > 0L) {
|
| 223 | ! |
S.PW <- YLp[[2]]$Sigma.W[-between.idx, -between.idx, drop = FALSE] |
| 224 |
} else {
|
|
| 225 | 432x |
S.PW <- YLp[[2]]$Sigma.W |
| 226 |
} |
|
| 227 | ||
| 228 |
# Y2 samplestats |
|
| 229 | 432x |
cov.d <- YLp[[2]]$cov.d |
| 230 | 432x |
mean.d <- YLp[[2]]$mean.d |
| 231 | ||
| 232 |
# common parts: |
|
| 233 | 432x |
sigma.w.inv <- lav_matrix_symmetric_inverse( |
| 234 | 432x |
S = sigma.w, |
| 235 | 432x |
logdet = TRUE, Sinv.method = Sinv.method |
| 236 |
) |
|
| 237 | 432x |
sigma.w.logdet <- attr(sigma.w.inv, "logdet") |
| 238 | 432x |
attr(sigma.w.inv, "logdet") <- NULL |
| 239 | ||
| 240 | 432x |
if (length(between.idx) > 0L) {
|
| 241 | ! |
sigma.zz.inv <- lav_matrix_symmetric_inverse( |
| 242 | ! |
S = sigma.zz, |
| 243 | ! |
logdet = TRUE, Sinv.method = Sinv.method |
| 244 |
) |
|
| 245 | ! |
sigma.zz.logdet <- attr(sigma.zz.inv, "logdet") |
| 246 | ! |
attr(sigma.zz.inv, "logdet") <- NULL |
| 247 | ! |
sigma.yz.zi <- sigma.yz %*% sigma.zz.inv |
| 248 | ! |
sigma.zi.zy <- t(sigma.yz.zi) |
| 249 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 250 |
} else {
|
|
| 251 | 432x |
sigma.zz.logdet <- 0 |
| 252 | 432x |
sigma.b.z <- sigma.b |
| 253 |
} |
|
| 254 | ||
| 255 |
# min 2* logliklihood |
|
| 256 | 432x |
L <- numeric(ncluster.sizes) # logdet |
| 257 | 432x |
B <- numeric(ncluster.sizes) # between qf |
| 258 | 432x |
for (clz in seq_len(ncluster.sizes)) {
|
| 259 |
# cluster size |
|
| 260 | 864x |
nj <- cluster.sizes[clz] |
| 261 | ||
| 262 |
# data between |
|
| 263 | 864x |
Y2Yc <- (cov.d[[clz]] + tcrossprod(mean.d[[clz]] - c(mu.z, mu.y))) |
| 264 | ||
| 265 |
# FIXME: avoid reorder/b.idx, so we can use between.idx |
|
| 266 | 864x |
if (length(between.idx) > 0L) {
|
| 267 | ! |
b.idx <- seq_len(length(Lp$between.idx[[2]])) |
| 268 | ! |
Y2Yc.zz <- Y2Yc[b.idx, b.idx, drop = FALSE] |
| 269 | ! |
Y2Yc.yz <- Y2Yc[-b.idx, b.idx, drop = FALSE] |
| 270 | ! |
Y2Yc.yy <- Y2Yc[-b.idx, -b.idx, drop = FALSE] |
| 271 |
} else {
|
|
| 272 | 864x |
Y2Yc.yy <- Y2Yc |
| 273 |
} |
|
| 274 | ||
| 275 |
# construct sigma.j |
|
| 276 | 864x |
sigma.j <- (nj * sigma.b.z) + sigma.w |
| 277 | 864x |
sigma.j.inv <- lav_matrix_symmetric_inverse( |
| 278 | 864x |
S = sigma.j, |
| 279 | 864x |
logdet = TRUE, Sinv.method = Sinv.method |
| 280 |
) |
|
| 281 | 864x |
sigma.j.logdet <- attr(sigma.j.inv, "logdet") |
| 282 | 864x |
attr(sigma.j.inv, "logdet") <- NULL |
| 283 | ||
| 284 |
# check: what if sigma.j is non-pd? should not happen |
|
| 285 | 864x |
if (is.na(sigma.j.logdet)) {
|
| 286 |
# stop, and return NA right away |
|
| 287 |
# return(as.numeric(NA)) |
|
| 288 |
# FORCE? |
|
| 289 |
# sigma.j <- lav_matrix_symmetric_force_pd(sigma.j) |
|
| 290 |
# sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j, |
|
| 291 |
# logdet = TRUE, Sinv.method = Sinv.method) |
|
| 292 |
# sigma.j.logdet <- attr(sigma.j.inv, "logdet") |
|
| 293 |
# attr(sigma.j.inv, "logdet") <- NULL |
|
| 294 |
} |
|
| 295 | ||
| 296 |
# logdet -- between only |
|
| 297 | 864x |
L[clz] <- (sigma.zz.logdet + sigma.j.logdet) |
| 298 | ||
| 299 | 864x |
if (length(between.idx) > 0L) {
|
| 300 |
# part 1 -- zz |
|
| 301 | ! |
sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi |
| 302 | ! |
Vinv.11 <- sigma.zz.inv + nj * (sigma.zi.zy %*% sigma.ji.yz.zi) |
| 303 | ! |
q.zz <- sum(Vinv.11 * Y2Yc.zz) |
| 304 | ||
| 305 |
# part 2 -- yz |
|
| 306 | ! |
q.yz <- -nj * sum(sigma.ji.yz.zi * Y2Yc.yz) |
| 307 |
} else {
|
|
| 308 | 864x |
q.zz <- q.yz <- 0 |
| 309 |
} |
|
| 310 | ||
| 311 |
# part 5 -- yyc |
|
| 312 | 864x |
q.yyc <- -nj * sum(sigma.j.inv * Y2Yc.yy) |
| 313 | ||
| 314 |
# qf -- between only |
|
| 315 | 864x |
B[clz] <- q.zz + 2 * q.yz - q.yyc |
| 316 |
} |
|
| 317 |
# q.yya + q.yyb |
|
| 318 |
# the reason why we multiply the trace by 'N - nclusters' is |
|
| 319 |
# S.PW has been divided by 'N - nclusters' |
|
| 320 | 432x |
q.W <- sum(cluster.size - 1) * sum(sigma.w.inv * S.PW) |
| 321 |
# logdet within part |
|
| 322 | 432x |
L.W <- sum(cluster.size - 1) * sigma.w.logdet |
| 323 | ||
| 324 |
# -2*times logl (without the constant) |
|
| 325 | 432x |
loglik <- sum(L * cluster.size.ns) + sum(B * cluster.size.ns) + q.W + L.W |
| 326 | ||
| 327 |
# functions below compute -2 * logl |
|
| 328 | 432x |
if (!minus.two) {
|
| 329 | 96x |
loglik <- loglik / (-2) |
| 330 |
} |
|
| 331 | ||
| 332 |
# constant |
|
| 333 |
# Note: total 'N' = (nobs * #within vars) + (nclusters * #between vars) |
|
| 334 | 432x |
if (log2pi) {
|
| 335 | 96x |
LOG.2PI <- log(2 * pi) |
| 336 | 96x |
nWithin <- length(c(Lp$both.idx[[2]], Lp$within.idx[[2]])) |
| 337 | 96x |
nBetween <- length(Lp$between.idx[[2]]) |
| 338 | 96x |
P <- Lp$nclusters[[1]] * nWithin + Lp$nclusters[[2]] * nBetween |
| 339 | 96x |
constant <- -(P * LOG.2PI) / 2 |
| 340 | 96x |
loglik <- loglik + constant |
| 341 |
} |
|
| 342 | ||
| 343 |
# loglik.x (only if loglik is requested) |
|
| 344 | 432x |
if (length(unlist(Lp$ov.x.idx)) > 0L && log2pi && !minus.two) {
|
| 345 | ! |
loglik <- loglik - YLp[[2]]$loglik.x |
| 346 |
} |
|
| 347 | ||
| 348 | 432x |
loglik |
| 349 |
} |
|
| 350 | ||
| 351 | ||
| 352 |
# first derivative -2*logl wrt Mu.W, Mu.B, Sigma.W, Sigma.B |
|
| 353 |
lav_mvnorm_cluster_dlogl_2l_samplestats <- function(YLp = NULL, |
|
| 354 |
Lp = NULL, |
|
| 355 |
Mu.W = NULL, |
|
| 356 |
Sigma.W = NULL, |
|
| 357 |
Mu.B = NULL, |
|
| 358 |
Sigma.B = NULL, |
|
| 359 |
return.list = FALSE, |
|
| 360 |
Sinv.method = "eigen") {
|
|
| 361 |
# map implied to 2l matrices |
|
| 362 | 1310x |
out <- lav_mvnorm_cluster_implied22l( |
| 363 | 1310x |
Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, |
| 364 | 1310x |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 365 |
) |
|
| 366 | 1310x |
mu.y <- out$mu.y |
| 367 | 1310x |
mu.z <- out$mu.z |
| 368 | 1310x |
sigma.w <- out$sigma.w |
| 369 | 1310x |
sigma.b <- out$sigma.b |
| 370 | 1310x |
sigma.zz <- out$sigma.zz |
| 371 | 1310x |
sigma.yz <- out$sigma.yz |
| 372 | ||
| 373 |
# Lp |
|
| 374 | 1310x |
nclusters <- Lp$nclusters[[2]] |
| 375 | 1310x |
cluster.size <- Lp$cluster.size[[2]] |
| 376 | 1310x |
cluster.sizes <- Lp$cluster.sizes[[2]] |
| 377 | 1310x |
cluster.idx <- Lp$cluster.idx[[2]] |
| 378 | 1310x |
between.idx <- Lp$between.idx[[2]] |
| 379 | 1310x |
ncluster.sizes <- Lp$ncluster.sizes[[2]] |
| 380 | 1310x |
cluster.size.ns <- Lp$cluster.size.ns[[2]] |
| 381 | ||
| 382 |
# Y1 |
|
| 383 | 1310x |
if (length(between.idx) > 0L) {
|
| 384 | ! |
S.PW <- YLp[[2]]$Sigma.W[-between.idx, -between.idx, drop = FALSE] |
| 385 |
} else {
|
|
| 386 | 1310x |
S.PW <- YLp[[2]]$Sigma.W |
| 387 |
} |
|
| 388 | ||
| 389 |
# Y2 |
|
| 390 | 1310x |
cov.d <- YLp[[2]]$cov.d |
| 391 | 1310x |
mean.d <- YLp[[2]]$mean.d |
| 392 | ||
| 393 |
# common parts: |
|
| 394 | 1310x |
sigma.w.inv <- lav_matrix_symmetric_inverse( |
| 395 | 1310x |
S = sigma.w, |
| 396 | 1310x |
logdet = FALSE, Sinv.method = Sinv.method |
| 397 |
) |
|
| 398 | ||
| 399 |
# both level-1 and level-2 |
|
| 400 | 1310x |
G.muy <- matrix(0, ncluster.sizes, length(mu.y)) |
| 401 | 1310x |
G.Sigma.w <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.w))) |
| 402 | 1310x |
G.Sigma.b <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.b))) |
| 403 | ||
| 404 | 1310x |
if (length(between.idx) > 0L) {
|
| 405 | ! |
G.muz <- matrix(0, ncluster.sizes, length(mu.z)) |
| 406 | ! |
G.Sigma.zz <- matrix( |
| 407 | ! |
0, ncluster.sizes, |
| 408 | ! |
length(lav_matrix_vech(sigma.zz)) |
| 409 |
) |
|
| 410 | ! |
G.Sigma.yz <- matrix(0, ncluster.sizes, length(lav_matrix_vec(sigma.yz))) |
| 411 | ||
| 412 | ! |
sigma.zz.inv <- lav_matrix_symmetric_inverse( |
| 413 | ! |
S = sigma.zz, |
| 414 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 415 |
) |
|
| 416 | ! |
sigma.yz.zi <- sigma.yz %*% sigma.zz.inv |
| 417 | ! |
sigma.zi.zy <- t(sigma.yz.zi) |
| 418 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 419 | ||
| 420 | ||
| 421 | ! |
for (clz in seq_len(ncluster.sizes)) {
|
| 422 |
# cluster size |
|
| 423 | ! |
nj <- cluster.sizes[clz] |
| 424 | ||
| 425 |
# level-2 vectors |
|
| 426 | ! |
b.idx <- seq_len(length(Lp$between.idx[[2]])) |
| 427 | ! |
zyc <- mean.d[[clz]] - c(mu.z, mu.y) |
| 428 | ! |
yc <- zyc[-b.idx] |
| 429 | ! |
zc <- zyc[b.idx] |
| 430 | ||
| 431 |
# level-2 crossproducts |
|
| 432 | ! |
Y2Yc <- (cov.d[[clz]] + tcrossprod(mean.d[[clz]] - c(mu.z, mu.y))) |
| 433 | ! |
b.idx <- seq_len(length(Lp$between.idx[[2]])) |
| 434 | ! |
Y2Yc.zz <- Y2Yc[b.idx, b.idx, drop = FALSE] |
| 435 | ! |
Y2Yc.yz <- Y2Yc[-b.idx, b.idx, drop = FALSE] |
| 436 | ! |
Y2Yc.yy <- Y2Yc[-b.idx, -b.idx, drop = FALSE] |
| 437 | ||
| 438 |
# construct sigma.j |
|
| 439 | ! |
sigma.j <- (nj * sigma.b.z) + sigma.w |
| 440 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse( |
| 441 | ! |
S = sigma.j, |
| 442 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 443 |
) |
|
| 444 | ! |
sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi |
| 445 | ! |
sigma.zi.zy.ji <- t(sigma.ji.yz.zi) |
| 446 | ||
| 447 |
# common parts |
|
| 448 | ! |
jYZj <- nj * (sigma.j.inv %*% |
| 449 | ! |
(sigma.yz.zi %*% Y2Yc.zz %*% t(sigma.yz.zi) |
| 450 | ! |
- Y2Yc.yz %*% t(sigma.yz.zi) |
| 451 | ! |
- t(Y2Yc.yz %*% t(sigma.yz.zi)) + Y2Yc.yy) |
| 452 | ! |
%*% sigma.j.inv) |
| 453 | ||
| 454 | ! |
Z1 <- Y2Yc.zz %*% t(sigma.ji.yz.zi) %*% sigma.yz |
| 455 | ! |
YZ1 <- t(Y2Yc.yz) %*% sigma.j.inv %*% sigma.yz |
| 456 | ||
| 457 | ||
| 458 |
# Mu.Z |
|
| 459 | ! |
G.muz[clz, ] <- -2 * as.numeric( |
| 460 | ! |
(sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) %*% zc |
| 461 | ! |
- nj * sigma.zi.zy.ji %*% yc |
| 462 |
) |
|
| 463 | ||
| 464 |
# MU.Y |
|
| 465 | ! |
G.muy[clz, ] <- 2 * nj * as.numeric(zc %*% sigma.zi.zy.ji - |
| 466 | ! |
yc %*% sigma.j.inv) |
| 467 | ||
| 468 |
# SIGMA.W (between part) |
|
| 469 | ! |
g.sigma.w <- sigma.j.inv - jYZj |
| 470 | ! |
tmp <- g.sigma.w * 2 |
| 471 | ! |
diag(tmp) <- diag(g.sigma.w) |
| 472 | ! |
G.Sigma.w[clz, ] <- lav_matrix_vech(tmp) |
| 473 | ||
| 474 |
# SIGMA.B |
|
| 475 | ! |
g.sigma.b <- nj * (sigma.j.inv - jYZj) |
| 476 | ! |
tmp <- g.sigma.b * 2 |
| 477 | ! |
diag(tmp) <- diag(g.sigma.b) |
| 478 | ! |
G.Sigma.b[clz, ] <- lav_matrix_vech(tmp) |
| 479 | ||
| 480 |
# SIGMA.ZZ |
|
| 481 | ! |
g.sigma.zz <- (sigma.zz.inv + nj * sigma.zz.inv %*% ( |
| 482 | ! |
t(sigma.yz) %*% (sigma.j.inv - jYZj) %*% sigma.yz |
| 483 | ! |
- (1 / nj * Y2Yc.zz + t(Z1) + Z1 - t(YZ1) - YZ1)) %*% |
| 484 | ! |
sigma.zz.inv) |
| 485 | ||
| 486 | ! |
tmp <- g.sigma.zz * 2 |
| 487 | ! |
diag(tmp) <- diag(g.sigma.zz) |
| 488 | ! |
G.Sigma.zz[clz, ] <- lav_matrix_vech(tmp) |
| 489 | ||
| 490 |
# SIGMA.ZY |
|
| 491 | ! |
g.sigma.yz <- 2 * nj * ( |
| 492 | ! |
(sigma.j.inv %*% |
| 493 | ! |
(sigma.yz.zi %*% Y2Yc.zz - sigma.yz - Y2Yc.yz) |
| 494 | ! |
+ jYZj %*% sigma.yz) %*% sigma.zz.inv) |
| 495 | ||
| 496 | ! |
G.Sigma.yz[clz, ] <- lav_matrix_vec(g.sigma.yz) |
| 497 |
} |
|
| 498 | ||
| 499 |
# level-1 |
|
| 500 | ! |
d.mu.y <- colSums(G.muy * cluster.size.ns) |
| 501 | ! |
d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w * |
| 502 | ! |
cluster.size.ns)) |
| 503 | ! |
d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b * |
| 504 | ! |
cluster.size.ns)) |
| 505 | ||
| 506 |
# level-2 |
|
| 507 | ! |
d.mu.z <- colSums(G.muz * cluster.size.ns) |
| 508 | ! |
d.sigma.zz <- lav_matrix_vech_reverse(colSums(G.Sigma.zz * |
| 509 | ! |
cluster.size.ns)) |
| 510 | ! |
d.sigma.yz <- matrix( |
| 511 | ! |
colSums(G.Sigma.yz * cluster.size.ns), |
| 512 | ! |
nrow(sigma.yz), ncol(sigma.yz) |
| 513 |
) |
|
| 514 |
} # between.idx |
|
| 515 | ||
| 516 |
else { # no level-2 variables
|
|
| 517 | ||
| 518 | 1310x |
for (clz in seq_len(ncluster.sizes)) {
|
| 519 |
# cluster size |
|
| 520 | 2620x |
nj <- cluster.sizes[clz] |
| 521 | ||
| 522 |
# level-2 vectors |
|
| 523 | 2620x |
yc <- mean.d[[clz]] - mu.y |
| 524 | ||
| 525 |
# level-2 crossproducts |
|
| 526 | 2620x |
Y2Yc.yy <- (cov.d[[clz]] + tcrossprod(mean.d[[clz]] - mu.y)) |
| 527 | ||
| 528 |
# construct sigma.j |
|
| 529 | 2620x |
sigma.j <- (nj * sigma.b) + sigma.w |
| 530 | 2620x |
sigma.j.inv <- lav_matrix_symmetric_inverse( |
| 531 | 2620x |
S = sigma.j, |
| 532 | 2620x |
logdet = FALSE, Sinv.method = Sinv.method |
| 533 |
) |
|
| 534 |
# common part |
|
| 535 | 2620x |
jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv |
| 536 | ||
| 537 |
# MU.Y |
|
| 538 | 2620x |
G.muy[clz, ] <- -2 * nj * as.numeric(yc %*% sigma.j.inv) |
| 539 | ||
| 540 |
# SIGMA.W (between part) |
|
| 541 | 2620x |
g.sigma.w <- sigma.j.inv - jYYj |
| 542 | 2620x |
tmp <- g.sigma.w * 2 |
| 543 | 2620x |
diag(tmp) <- diag(g.sigma.w) |
| 544 | 2620x |
G.Sigma.w[clz, ] <- lav_matrix_vech(tmp) |
| 545 | ||
| 546 |
# SIGMA.B |
|
| 547 | 2620x |
g.sigma.b <- nj * (sigma.j.inv - jYYj) |
| 548 | 2620x |
tmp <- g.sigma.b * 2 |
| 549 | 2620x |
diag(tmp) <- diag(g.sigma.b) |
| 550 | 2620x |
G.Sigma.b[clz, ] <- lav_matrix_vech(tmp) |
| 551 |
} |
|
| 552 | ||
| 553 |
# level-1 |
|
| 554 | 1310x |
d.mu.y <- colSums(G.muy * cluster.size.ns) |
| 555 | 1310x |
d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.Sigma.w * |
| 556 | 1310x |
cluster.size.ns)) |
| 557 | 1310x |
d.sigma.b <- lav_matrix_vech_reverse(colSums(G.Sigma.b * |
| 558 | 1310x |
cluster.size.ns)) |
| 559 |
# level-2 |
|
| 560 | 1310x |
d.mu.z <- numeric(0L) |
| 561 | 1310x |
d.sigma.zz <- matrix(0, 0L, 0L) |
| 562 | 1310x |
d.sigma.yz <- matrix(0, 0L, 0L) |
| 563 |
} |
|
| 564 | ||
| 565 |
# Sigma.W (bis) |
|
| 566 | 1310x |
d.sigma.w2 <- (Lp$nclusters[[1]] - nclusters) * (sigma.w.inv |
| 567 | 1310x |
- sigma.w.inv %*% S.PW %*% sigma.w.inv) |
| 568 | 1310x |
tmp <- d.sigma.w2 * 2 |
| 569 | 1310x |
diag(tmp) <- diag(d.sigma.w2) |
| 570 | 1310x |
d.sigma.w2 <- tmp |
| 571 | ||
| 572 | 1310x |
d.sigma.w <- d.sigma.w1 + d.sigma.w2 |
| 573 | ||
| 574 |
# rearrange |
|
| 575 | 1310x |
dout <- lav_mvnorm_cluster_2l2implied( |
| 576 | 1310x |
Lp = Lp, |
| 577 | 1310x |
sigma.w = d.sigma.w, sigma.b = d.sigma.b, |
| 578 | 1310x |
sigma.yz = d.sigma.yz, sigma.zz = d.sigma.zz, |
| 579 | 1310x |
mu.y = d.mu.y, mu.z = d.mu.z |
| 580 |
) |
|
| 581 | ||
| 582 | 1310x |
if (return.list) {
|
| 583 | ! |
out <- dout |
| 584 |
} else {
|
|
| 585 | 1310x |
out <- c( |
| 586 | 1310x |
dout$Mu.W, lav_matrix_vech(dout$Sigma.W), |
| 587 | 1310x |
dout$Mu.B, lav_matrix_vech(dout$Sigma.B) |
| 588 |
) |
|
| 589 |
} |
|
| 590 | ||
| 591 | 1310x |
out |
| 592 |
} |
|
| 593 | ||
| 594 |
# cluster-wise scores -2*logl wrt Mu.W, Mu.B, Sigma.W, Sigma.B |
|
| 595 |
lav_mvnorm_cluster_scores_2l <- function(Y1 = NULL, |
|
| 596 |
YLp = NULL, |
|
| 597 |
Lp = NULL, |
|
| 598 |
Mu.W = NULL, |
|
| 599 |
Sigma.W = NULL, |
|
| 600 |
Mu.B = NULL, |
|
| 601 |
Sigma.B = NULL, |
|
| 602 |
Sinv.method = "eigen") {
|
|
| 603 |
# map implied to 2l matrices |
|
| 604 | ! |
out <- lav_mvnorm_cluster_implied22l( |
| 605 | ! |
Lp = Lp, Mu.W = Mu.W, Mu.B = Mu.B, |
| 606 | ! |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 607 |
) |
|
| 608 | ! |
mu.y <- out$mu.y |
| 609 | ! |
mu.z <- out$mu.z |
| 610 | ! |
sigma.w <- out$sigma.w |
| 611 | ! |
sigma.b <- out$sigma.b |
| 612 | ! |
sigma.zz <- out$sigma.zz |
| 613 | ! |
sigma.yz <- out$sigma.yz |
| 614 | ||
| 615 |
# Lp |
|
| 616 | ! |
nclusters <- Lp$nclusters[[2]] |
| 617 | ! |
cluster.size <- Lp$cluster.size[[2]] |
| 618 | ! |
cluster.idx <- Lp$cluster.idx[[2]] |
| 619 | ! |
between.idx <- Lp$between.idx[[2]] |
| 620 | ||
| 621 |
# Y1 |
|
| 622 | ! |
if (length(between.idx) > 0L) {
|
| 623 | ! |
Y1w <- Y1[, -Lp$between.idx[[2]], drop = FALSE] |
| 624 |
} else {
|
|
| 625 | ! |
Y1w <- Y1 |
| 626 |
} |
|
| 627 | ! |
Y1w.cm <- t(t(Y1w) - mu.y) |
| 628 | ||
| 629 |
# Y2 |
|
| 630 | ! |
Y2 <- YLp[[2]]$Y2 |
| 631 |
# NOTE: ORDER mu.b must match Y2 |
|
| 632 | ! |
mu.b <- numeric(ncol(Y2)) |
| 633 | ! |
if (length(between.idx) > 0L) {
|
| 634 | ! |
mu.b[-Lp$between.idx[[2]]] <- mu.y |
| 635 | ! |
mu.b[Lp$between.idx[[2]]] <- mu.z |
| 636 |
} else {
|
|
| 637 | ! |
mu.b <- mu.y |
| 638 |
} |
|
| 639 | ! |
Y2.cm <- t(t(Y2) - mu.b) |
| 640 | ||
| 641 |
# common parts: |
|
| 642 | ! |
sigma.w.inv <- lav_matrix_symmetric_inverse( |
| 643 | ! |
S = sigma.w, |
| 644 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 645 |
) |
|
| 646 | ||
| 647 |
# both level-1 and level-2 |
|
| 648 | ! |
G.muy <- matrix(0, nclusters, length(mu.y)) |
| 649 | ! |
G.Sigma.w <- matrix(0, nclusters, length(lav_matrix_vech(sigma.w))) |
| 650 | ! |
G.Sigma.b <- matrix(0, nclusters, length(lav_matrix_vech(sigma.b))) |
| 651 | ! |
G.muz <- matrix(0, nclusters, length(mu.z)) |
| 652 | ! |
G.Sigma.zz <- matrix(0, nclusters, length(lav_matrix_vech(sigma.zz))) |
| 653 | ! |
G.Sigma.yz <- matrix(0, nclusters, length(lav_matrix_vec(sigma.yz))) |
| 654 | ||
| 655 | ! |
if (length(between.idx) > 0L) {
|
| 656 | ! |
sigma.zz.inv <- lav_matrix_symmetric_inverse( |
| 657 | ! |
S = sigma.zz, |
| 658 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 659 |
) |
|
| 660 | ! |
sigma.yz.zi <- sigma.yz %*% sigma.zz.inv |
| 661 | ! |
sigma.zi.zy <- t(sigma.yz.zi) |
| 662 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 663 | ||
| 664 | ||
| 665 | ! |
for (cl in seq_len(nclusters)) {
|
| 666 |
# cluster size |
|
| 667 | ! |
nj <- cluster.size[cl] |
| 668 | ||
| 669 |
# data within for the cluster (centered by mu.y) |
|
| 670 | ! |
Y1m <- Y1w.cm[cluster.idx == cl, , drop = FALSE] |
| 671 | ! |
yc <- Y2.cm[cl, -Lp$between.idx[[2]]] |
| 672 | ! |
zc <- Y2.cm[cl, Lp$between.idx[[2]]] |
| 673 | ||
| 674 |
# data between |
|
| 675 | ! |
Y2Yc <- tcrossprod(Y2.cm[cl, ]) |
| 676 | ! |
Y2Yc.zz <- Y2Yc[Lp$between.idx[[2]], |
| 677 | ! |
Lp$between.idx[[2]], |
| 678 | ! |
drop = FALSE |
| 679 |
] |
|
| 680 | ! |
Y2Yc.yz <- Y2Yc[-Lp$between.idx[[2]], |
| 681 | ! |
Lp$between.idx[[2]], |
| 682 | ! |
drop = FALSE |
| 683 |
] |
|
| 684 | ! |
Y2Yc.yy <- Y2Yc[-Lp$between.idx[[2]], |
| 685 | ! |
-Lp$between.idx[[2]], |
| 686 | ! |
drop = FALSE |
| 687 |
] |
|
| 688 | ||
| 689 |
# construct sigma.j |
|
| 690 | ! |
sigma.j <- (nj * sigma.b.z) + sigma.w |
| 691 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse( |
| 692 | ! |
S = sigma.j, |
| 693 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 694 |
) |
|
| 695 | ! |
sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi |
| 696 | ! |
sigma.zi.zy.ji <- t(sigma.ji.yz.zi) |
| 697 | ||
| 698 |
# common parts |
|
| 699 | ! |
jYZj <- nj * (sigma.j.inv %*% |
| 700 | ! |
(sigma.yz.zi %*% Y2Yc.zz %*% t(sigma.yz.zi) |
| 701 | ! |
- Y2Yc.yz %*% t(sigma.yz.zi) |
| 702 | ! |
- t(Y2Yc.yz %*% t(sigma.yz.zi)) + Y2Yc.yy) |
| 703 | ! |
%*% sigma.j.inv) |
| 704 | ||
| 705 | ! |
Z1 <- Y2Yc.zz %*% t(sigma.ji.yz.zi) %*% sigma.yz |
| 706 | ! |
YZ1 <- t(Y2Yc.yz) %*% sigma.j.inv %*% sigma.yz |
| 707 | ||
| 708 | ||
| 709 |
# Mu.Z |
|
| 710 | ! |
G.muz[cl, ] <- -2 * as.numeric( |
| 711 | ! |
(sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) %*% zc |
| 712 | ! |
- nj * sigma.zi.zy.ji %*% yc |
| 713 |
) |
|
| 714 | ||
| 715 |
# MU.Y |
|
| 716 | ! |
G.muy[cl, ] <- 2 * nj * as.numeric(zc %*% sigma.zi.zy.ji - |
| 717 | ! |
yc %*% sigma.j.inv) |
| 718 | ||
| 719 |
# SIGMA.W |
|
| 720 | ! |
g.sigma.w <- ((nj - 1) * sigma.w.inv |
| 721 | ! |
- sigma.w.inv %*% (crossprod(Y1m) - nj * Y2Yc.yy) %*% sigma.w.inv |
| 722 | ! |
+ sigma.j.inv - jYZj) |
| 723 | ||
| 724 | ! |
tmp <- g.sigma.w * 2 |
| 725 | ! |
diag(tmp) <- diag(g.sigma.w) |
| 726 | ! |
G.Sigma.w[cl, ] <- lav_matrix_vech(tmp) |
| 727 | ||
| 728 |
# SIGMA.B |
|
| 729 | ! |
g.sigma.b <- nj * (sigma.j.inv - jYZj) |
| 730 | ||
| 731 | ! |
tmp <- g.sigma.b * 2 |
| 732 | ! |
diag(tmp) <- diag(g.sigma.b) |
| 733 | ! |
G.Sigma.b[cl, ] <- lav_matrix_vech(tmp) |
| 734 | ||
| 735 | ||
| 736 |
# SIGMA.ZZ |
|
| 737 | ! |
g.sigma.zz <- (sigma.zz.inv + nj * sigma.zz.inv %*% ( |
| 738 | ! |
t(sigma.yz) %*% (sigma.j.inv - jYZj) %*% sigma.yz |
| 739 | ! |
- (1 / nj * Y2Yc.zz + t(Z1) + Z1 - t(YZ1) - YZ1)) %*% |
| 740 | ! |
sigma.zz.inv) |
| 741 | ||
| 742 | ! |
tmp <- g.sigma.zz * 2 |
| 743 | ! |
diag(tmp) <- diag(g.sigma.zz) |
| 744 | ! |
G.Sigma.zz[cl, ] <- lav_matrix_vech(tmp) |
| 745 | ||
| 746 |
# SIGMA.ZY |
|
| 747 | ! |
g.sigma.yz <- 2 * nj * ( |
| 748 | ! |
(sigma.j.inv %*% |
| 749 | ! |
(sigma.yz.zi %*% Y2Yc.zz - sigma.yz - Y2Yc.yz) |
| 750 | ! |
+ jYZj %*% sigma.yz) %*% sigma.zz.inv) |
| 751 | ||
| 752 | ! |
G.Sigma.yz[cl, ] <- lav_matrix_vec(g.sigma.yz) |
| 753 |
} |
|
| 754 |
} # between.idx |
|
| 755 | ||
| 756 |
else { # no level-2 variables
|
|
| 757 | ||
| 758 | ! |
for (cl in seq_len(nclusters)) {
|
| 759 |
# cluster size |
|
| 760 | ! |
nj <- cluster.size[cl] |
| 761 | ||
| 762 |
# data within for the cluster (centered by mu.y) |
|
| 763 | ! |
Y1m <- Y1w.cm[cluster.idx == cl, , drop = FALSE] |
| 764 | ! |
yc <- Y2.cm[cl, ] |
| 765 | ||
| 766 |
# data between |
|
| 767 | ! |
Y2Yc.yy <- tcrossprod(Y2.cm[cl, ]) |
| 768 | ||
| 769 |
# construct sigma.j |
|
| 770 | ! |
sigma.j <- (nj * sigma.b) + sigma.w |
| 771 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse( |
| 772 | ! |
S = sigma.j, |
| 773 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 774 |
) |
|
| 775 |
# common part |
|
| 776 | ! |
jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv |
| 777 | ||
| 778 |
# MU.Y |
|
| 779 | ! |
G.muy[cl, ] <- -2 * nj * as.numeric(yc %*% sigma.j.inv) |
| 780 | ||
| 781 |
# SIGMA.W |
|
| 782 | ! |
g.sigma.w <- ((nj - 1) * sigma.w.inv |
| 783 | ! |
- sigma.w.inv %*% (crossprod(Y1m) - nj * Y2Yc.yy) %*% sigma.w.inv |
| 784 | ! |
+ sigma.j.inv - jYYj) |
| 785 | ! |
tmp <- g.sigma.w * 2 |
| 786 | ! |
diag(tmp) <- diag(g.sigma.w) |
| 787 | ! |
G.Sigma.w[cl, ] <- lav_matrix_vech(tmp) |
| 788 | ||
| 789 |
# SIGMA.B |
|
| 790 | ! |
g.sigma.b <- nj * (sigma.j.inv - jYYj) |
| 791 | ! |
tmp <- g.sigma.b * 2 |
| 792 | ! |
diag(tmp) <- diag(g.sigma.b) |
| 793 | ! |
G.Sigma.b[cl, ] <- lav_matrix_vech(tmp) |
| 794 |
} |
|
| 795 |
} |
|
| 796 | ||
| 797 |
# rearrange columns to Mu.W, Mu.B, Sigma.W, Sigma.B |
|
| 798 | ! |
ov.idx <- Lp$ov.idx |
| 799 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 800 | ||
| 801 |
# Mu.W (for within-only) |
|
| 802 | ! |
Mu.W.tilde <- matrix(0, nclusters, p.tilde) |
| 803 | ! |
Mu.W.tilde[, ov.idx[[1]]] <- G.muy |
| 804 | ! |
Mu.W.tilde[, Lp$both.idx[[2]]] <- 0 # ZERO!!! |
| 805 | ! |
Mu.W <- Mu.W.tilde[, ov.idx[[1]], drop = FALSE] |
| 806 | ||
| 807 |
# Mu.B |
|
| 808 | ! |
Mu.B.tilde <- matrix(0, nclusters, p.tilde) |
| 809 | ! |
Mu.B.tilde[, ov.idx[[1]]] <- G.muy |
| 810 | ! |
if (length(between.idx) > 0L) {
|
| 811 | ! |
Mu.B.tilde[, between.idx] <- G.muz |
| 812 |
} |
|
| 813 | ! |
Mu.B <- Mu.B.tilde[, ov.idx[[2]], drop = FALSE] |
| 814 | ||
| 815 |
# Sigma.W |
|
| 816 | ! |
Sigma.W <- G.Sigma.w |
| 817 | ||
| 818 |
# Sigma.B |
|
| 819 | ! |
if (length(between.idx) > 0L) {
|
| 820 | ! |
p.tilde.star <- p.tilde * (p.tilde + 1) / 2 |
| 821 | ! |
B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star)) |
| 822 | ||
| 823 | ! |
Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star) |
| 824 | ||
| 825 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], |
| 826 | ! |
drop = FALSE |
| 827 |
]) |
|
| 828 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.b |
| 829 | ||
| 830 | ! |
col.idx <- lav_matrix_vec(B.tilde[ov.idx[[1]], between.idx, |
| 831 | ! |
drop = FALSE |
| 832 |
]) |
|
| 833 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.yz |
| 834 | ||
| 835 | ! |
col.idx <- lav_matrix_vech(B.tilde[between.idx, between.idx, |
| 836 | ! |
drop = FALSE |
| 837 |
]) |
|
| 838 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.zz |
| 839 | ||
| 840 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], |
| 841 | ! |
drop = FALSE |
| 842 |
]) |
|
| 843 | ! |
Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE] |
| 844 |
} else {
|
|
| 845 | ! |
p.tilde.star <- p.tilde * (p.tilde + 1) / 2 |
| 846 | ! |
B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star)) |
| 847 | ||
| 848 | ! |
Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star) |
| 849 | ||
| 850 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], |
| 851 | ! |
drop = FALSE |
| 852 |
]) |
|
| 853 | ! |
Sigma.B.tilde[, col.idx] <- G.Sigma.b |
| 854 | ||
| 855 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], |
| 856 | ! |
drop = FALSE |
| 857 |
]) |
|
| 858 | ! |
Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE] |
| 859 |
# Sigma.B <- G.Sigma.b |
|
| 860 |
} |
|
| 861 | ||
| 862 | ! |
SCORES <- cbind(Mu.W, Sigma.W, Mu.B, Sigma.B) |
| 863 | ||
| 864 | ! |
SCORES |
| 865 |
} |
|
| 866 | ||
| 867 | ||
| 868 |
# first-order information: outer crossprod of scores per cluster |
|
| 869 |
lav_mvnorm_cluster_information_firstorder <- function(Y1 = NULL, |
|
| 870 |
YLp = NULL, |
|
| 871 |
Lp = NULL, |
|
| 872 |
Mu.W = NULL, |
|
| 873 |
Sigma.W = NULL, |
|
| 874 |
Mu.B = NULL, |
|
| 875 |
Sigma.B = NULL, |
|
| 876 |
x.idx = NULL, |
|
| 877 |
divide.by.two = FALSE, |
|
| 878 |
Sinv.method = "eigen") {
|
|
| 879 | ! |
N <- NROW(Y1) |
| 880 | ||
| 881 | ! |
SCORES <- lav_mvnorm_cluster_scores_2l( |
| 882 | ! |
Y1 = Y1, |
| 883 | ! |
YLp = YLp, |
| 884 | ! |
Lp = Lp, |
| 885 | ! |
Mu.W = Mu.W, |
| 886 | ! |
Sigma.W = Sigma.W, |
| 887 | ! |
Mu.B = Mu.B, |
| 888 | ! |
Sigma.B = Sigma.B, |
| 889 | ! |
Sinv.method = Sinv.method |
| 890 |
) |
|
| 891 | ||
| 892 |
# divide by 2 (if we want scores wrt objective function) |
|
| 893 | ! |
if (divide.by.two) {
|
| 894 | ! |
SCORES <- SCORES / 2 |
| 895 |
} |
|
| 896 | ||
| 897 |
# unit information |
|
| 898 | ! |
information <- crossprod(SCORES) / Lp$nclusters[[2]] |
| 899 | ||
| 900 |
# if x.idx, set rows/cols to zero |
|
| 901 | ! |
if (length(x.idx) > 0L) {
|
| 902 | ! |
nw <- length(as.vector(Mu.W)) |
| 903 | ! |
nw.star <- nw * (nw + 1) / 2 |
| 904 | ! |
nb <- length(as.vector(Mu.B)) |
| 905 | ! |
ov.idx <- Lp$ov.idx |
| 906 | ||
| 907 | ! |
x.idx.w <- which(ov.idx[[1]] %in% x.idx) |
| 908 | ! |
if (length(x.idx.w) > 0L) {
|
| 909 | ! |
xw.idx <- c( |
| 910 | ! |
x.idx.w, |
| 911 | ! |
nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w) |
| 912 |
) |
|
| 913 |
} else {
|
|
| 914 | ! |
xw.idx <- integer(0L) |
| 915 |
} |
|
| 916 | ! |
x.idx.b <- which(ov.idx[[2]] %in% x.idx) |
| 917 | ! |
if (length(x.idx.b) > 0L) {
|
| 918 | ! |
xb.idx <- c( |
| 919 | ! |
x.idx.b, |
| 920 | ! |
nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b) |
| 921 |
) |
|
| 922 |
} else {
|
|
| 923 | ! |
xb.idx <- integer(0L) |
| 924 |
} |
|
| 925 | ||
| 926 | ! |
all.idx <- c(xw.idx, nw + nw.star + xb.idx) |
| 927 | ||
| 928 | ! |
information[all.idx, ] <- 0 |
| 929 | ! |
information[, all.idx] <- 0 |
| 930 |
} |
|
| 931 | ||
| 932 | ! |
information |
| 933 |
} |
|
| 934 | ||
| 935 |
# expected information 'h1' model |
|
| 936 |
# order: mu.w within, vech(sigma.w) within, mu.b between, vech(sigma.b) between |
|
| 937 |
# mu.w rows/cols that are splitted within/between are forced to zero |
|
| 938 |
lav_mvnorm_cluster_information_expected <- function(Lp = NULL, |
|
| 939 |
Mu.W = NULL, |
|
| 940 |
Sigma.W = NULL, |
|
| 941 |
Mu.B = NULL, |
|
| 942 |
Sigma.B = NULL, |
|
| 943 |
x.idx = integer(0L), |
|
| 944 |
Sinv.method = "eigen") {
|
|
| 945 |
# translate to internal matrices |
|
| 946 | 2x |
out <- lav_mvnorm_cluster_implied22l( |
| 947 | 2x |
Lp = Lp, |
| 948 | 2x |
Mu.W = Mu.W, Mu.B = Mu.B, |
| 949 | 2x |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 950 |
) |
|
| 951 | 2x |
mu.y <- out$mu.y |
| 952 | 2x |
mu.z <- out$mu.z |
| 953 | 2x |
sigma.w <- out$sigma.w |
| 954 | 2x |
sigma.b <- out$sigma.b |
| 955 | 2x |
sigma.zz <- out$sigma.zz |
| 956 | 2x |
sigma.yz <- out$sigma.yz |
| 957 | ||
| 958 |
# create Delta.W.tilde, Delta.B.tilde |
|
| 959 | 2x |
ov.idx <- Lp$ov.idx |
| 960 | 2x |
nw <- length(ov.idx[[1]]) |
| 961 | 2x |
nb <- length(ov.idx[[2]]) |
| 962 | 2x |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 963 | 2x |
p.tilde.star <- p.tilde * (p.tilde + 1) / 2 |
| 964 | 2x |
npar <- p.tilde + p.tilde.star |
| 965 | 2x |
B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star)) |
| 966 | 2x |
w.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], drop = FALSE]) |
| 967 | 2x |
b.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], drop = FALSE]) |
| 968 | ||
| 969 | 2x |
Delta.W.tilde <- matrix(0, npar, npar) |
| 970 | 2x |
Delta.B.tilde <- matrix(0, npar, npar) |
| 971 | 2x |
Delta.W.tilde[ |
| 972 | 2x |
c(ov.idx[[1]], w.idx + p.tilde), |
| 973 | 2x |
c(ov.idx[[1]], w.idx + p.tilde) |
| 974 | 2x |
] <- diag(nw + nw * (nw + 1) / 2) |
| 975 | 2x |
Delta.B.tilde[ |
| 976 | 2x |
c(ov.idx[[2]], b.idx + p.tilde), |
| 977 | 2x |
c(ov.idx[[2]], b.idx + p.tilde) |
| 978 | 2x |
] <- diag(nb + nb * (nb + 1) / 2) |
| 979 | 2x |
Delta.W.tilde <- cbind(Delta.W.tilde, matrix(0, npar, npar)) |
| 980 | 2x |
Delta.B.tilde <- cbind(matrix(0, npar, npar), Delta.B.tilde) |
| 981 | ||
| 982 | 2x |
nobs <- Lp$nclusters[[1]] |
| 983 | 2x |
nclusters <- Lp$nclusters[[2]] |
| 984 | 2x |
cluster.size <- Lp$cluster.size[[2]] |
| 985 | 2x |
cluster.sizes <- Lp$cluster.sizes[[2]] |
| 986 | 2x |
ncluster.sizes <- Lp$ncluster.sizes[[2]] |
| 987 | 2x |
n.s <- Lp$cluster.size.ns[[2]] |
| 988 | 2x |
between.idx <- Lp$between.idx[[2]] |
| 989 | ||
| 990 | 2x |
information.j <- matrix(0, npar * 2, npar * 2) |
| 991 | 2x |
for (clz in seq_len(ncluster.sizes)) {
|
| 992 |
# cluster size |
|
| 993 | 4x |
nj <- cluster.sizes[clz] |
| 994 | ||
| 995 |
# Delta.j -- changes per cluster(size) |
|
| 996 |
# this is why we can not write info = t(delta) info.sat delta |
|
| 997 | 4x |
Delta.j <- Delta.B.tilde + 1 / nj * Delta.W.tilde |
| 998 | ||
| 999 |
# compute Sigma.j |
|
| 1000 | 4x |
sigma.j <- sigma.w + nj * sigma.b |
| 1001 | 4x |
if (length(between.idx) > 0L) {
|
| 1002 | ! |
omega.j <- matrix(0, p.tilde, p.tilde) |
| 1003 | ! |
omega.j[-between.idx, -between.idx] <- 1 / nj * sigma.j |
| 1004 | ! |
omega.j[-between.idx, between.idx] <- sigma.yz |
| 1005 | ! |
omega.j[between.idx, -between.idx] <- t(sigma.yz) |
| 1006 | ! |
omega.j[between.idx, between.idx] <- sigma.zz |
| 1007 |
# omega.j <- rbind( cbind(sigma.zz, t(sigma.yz)), |
|
| 1008 |
# cbind(sigma.yz, 1/nj * sigma.j) ) |
|
| 1009 |
} else {
|
|
| 1010 | 4x |
omega.j <- 1 / nj * sigma.j |
| 1011 |
} |
|
| 1012 | 4x |
omega.j.inv <- solve(omega.j) |
| 1013 | ||
| 1014 | 4x |
I11.j <- omega.j.inv |
| 1015 |
# if (lav_use_lavaanC()) {
|
|
| 1016 |
# I22.j <- lavaanC::m_kronecker_dup_pre_post(omega.j.inv, multiplicator = 0.5) |
|
| 1017 |
# } else {
|
|
| 1018 | 4x |
I22.j <- 0.5 * lav_matrix_duplication_pre_post(omega.j.inv %x% omega.j.inv) |
| 1019 |
# } |
|
| 1020 | 4x |
I.j <- lav_matrix_bdiag(I11.j, I22.j) |
| 1021 | 4x |
info.j <- t(Delta.j) %*% I.j %*% Delta.j |
| 1022 | ||
| 1023 | 4x |
information.j <- information.j + n.s[clz] * info.j |
| 1024 |
} |
|
| 1025 | ||
| 1026 | 2x |
Sigma.W.inv <- lav_matrix_symmetric_inverse( |
| 1027 | 2x |
S = Sigma.W, logdet = FALSE, |
| 1028 | 2x |
Sinv.method = Sinv.method |
| 1029 |
) |
|
| 1030 |
# create Sigma.W.inv.tilde |
|
| 1031 | 2x |
Sigma.W.inv.tilde <- matrix(0, p.tilde, p.tilde) |
| 1032 | 2x |
Sigma.W.inv.tilde[ov.idx[[1]], ov.idx[[1]]] <- Sigma.W.inv |
| 1033 | ||
| 1034 | 2x |
I11.w <- Sigma.W.inv.tilde |
| 1035 |
# if (lav_use_lavaanC()) {
|
|
| 1036 |
# I22.W <- lavaanC::m_kronecker_dup_pre_post(Sigma.W.inv.tilde, multiplicator = 0.5) |
|
| 1037 |
# } else {
|
|
| 1038 | 2x |
I22.w <- 0.5 * lav_matrix_duplication_pre_post(Sigma.W.inv.tilde %x% Sigma.W.inv.tilde) |
| 1039 |
# } |
|
| 1040 | 2x |
I.w <- lav_matrix_bdiag(I11.w, I22.w) |
| 1041 | 2x |
information.w <- (nobs - nclusters) * |
| 1042 | 2x |
(t(Delta.W.tilde) %*% I.w %*% Delta.W.tilde) |
| 1043 | ||
| 1044 |
# unit information |
|
| 1045 | 2x |
information.tilde <- 1 / Lp$nclusters[[2]] * (information.w + information.j) |
| 1046 | ||
| 1047 |
# force zero for means both.idx in within part |
|
| 1048 | 2x |
information.tilde[Lp$both.idx[[2]], ] <- 0 |
| 1049 | 2x |
information.tilde[, Lp$both.idx[[2]]] <- 0 |
| 1050 | ||
| 1051 |
# if x.idx, set rows/cols to zero |
|
| 1052 | 2x |
if (length(x.idx) > 0L) {
|
| 1053 | ! |
xw.idx <- c( |
| 1054 | ! |
x.idx, |
| 1055 | ! |
p.tilde + lav_matrix_vech_which_idx(n = p.tilde, idx = x.idx) |
| 1056 |
) |
|
| 1057 | ! |
xb.idx <- npar + xw.idx |
| 1058 | ! |
all.idx <- c(xw.idx, xb.idx) |
| 1059 | ! |
information.tilde[all.idx, ] <- 0 |
| 1060 | ! |
information.tilde[, all.idx] <- 0 |
| 1061 |
} |
|
| 1062 | ||
| 1063 |
# remove redundant rows/cols |
|
| 1064 | 2x |
ok.idx <- c( |
| 1065 | 2x |
ov.idx[[1]], |
| 1066 | 2x |
w.idx + p.tilde, |
| 1067 | 2x |
npar + ov.idx[[2]], |
| 1068 | 2x |
npar + b.idx + p.tilde |
| 1069 |
) |
|
| 1070 | ||
| 1071 | 2x |
information <- information.tilde[ok.idx, ok.idx] |
| 1072 | ||
| 1073 | 2x |
information |
| 1074 |
} |
|
| 1075 | ||
| 1076 | ||
| 1077 |
# expected information -- delta |
|
| 1078 |
# for non-saturated models only |
|
| 1079 |
lav_mvnorm_cluster_information_expected_delta <- function(Lp = NULL, |
|
| 1080 |
Delta = NULL, |
|
| 1081 |
Mu.W = NULL, |
|
| 1082 |
Sigma.W = NULL, |
|
| 1083 |
Mu.B = NULL, |
|
| 1084 |
Sigma.B = NULL, |
|
| 1085 |
Sinv.method = "eigen") {
|
|
| 1086 |
# translate to internal matrices |
|
| 1087 | ! |
out <- lav_mvnorm_cluster_implied22l( |
| 1088 | ! |
Lp = Lp, |
| 1089 | ! |
Mu.W = Mu.W, Mu.B = Mu.B, |
| 1090 | ! |
Sigma.W = Sigma.W, Sigma.B = Sigma.B |
| 1091 |
) |
|
| 1092 | ! |
mu.y <- out$mu.y |
| 1093 | ! |
mu.z <- out$mu.z |
| 1094 | ! |
sigma.w <- out$sigma.w |
| 1095 | ! |
sigma.b <- out$sigma.b |
| 1096 | ! |
sigma.zz <- out$sigma.zz |
| 1097 | ! |
sigma.yz <- out$sigma.yz |
| 1098 | ||
| 1099 |
# Delta -- this group |
|
| 1100 | ! |
npar <- NCOL(Delta) |
| 1101 | ||
| 1102 |
# create Delta.W.tilde, Delta.B.tilde |
|
| 1103 | ! |
ov.idx <- Lp$ov.idx |
| 1104 | ! |
nw <- length(ov.idx[[1]]) |
| 1105 | ! |
nw.star <- nw * (nw + 1) / 2 |
| 1106 | ! |
nb <- length(ov.idx[[2]]) |
| 1107 | ||
| 1108 | ! |
Delta.W <- Delta[1:(nw + nw.star), , drop = FALSE] |
| 1109 | ! |
Delta.B <- Delta[-(1:(nw + nw.star)), , drop = FALSE] |
| 1110 | ||
| 1111 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 1112 | ! |
p.tilde.star <- p.tilde * (p.tilde + 1) / 2 |
| 1113 | ! |
Delta.W.tilde.Mu <- matrix(0, p.tilde, npar) |
| 1114 | ! |
Delta.W.tilde.Sigma <- matrix(0, p.tilde.star, npar) |
| 1115 | ! |
Delta.B.tilde.Mu <- matrix(0, p.tilde, npar) |
| 1116 | ! |
Delta.B.tilde.Sigma <- matrix(0, p.tilde.star, npar) |
| 1117 | ||
| 1118 | ! |
Delta.W.tilde.Mu[ov.idx[[1]], ] <- Delta.W[1:nw, ] |
| 1119 | ! |
Delta.B.tilde.Mu[ov.idx[[2]], ] <- Delta.B[1:nb, ] |
| 1120 | ||
| 1121 |
# correct Delta to reflect Mu.W[ both.idx ] is added to Mu.B[ both.idx ] |
|
| 1122 |
# changed in 0.6-5 |
|
| 1123 | ! |
Delta.B.tilde.Mu[Lp$both.idx[[2]], ] <- |
| 1124 | ! |
(Delta.B.tilde.Mu[Lp$both.idx[[2]], ] + |
| 1125 | ! |
Delta.W.tilde.Mu[Lp$both.idx[[2]], ]) |
| 1126 | ! |
Delta.W.tilde.Mu[Lp$both.idx[[2]], ] <- 0 |
| 1127 | ||
| 1128 | ||
| 1129 | ! |
B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star)) |
| 1130 | ! |
w.idx <- lav_matrix_vech(B.tilde[ov.idx[[1]], ov.idx[[1]], drop = FALSE]) |
| 1131 | ! |
b.idx <- lav_matrix_vech(B.tilde[ov.idx[[2]], ov.idx[[2]], drop = FALSE]) |
| 1132 | ! |
Delta.W.tilde.Sigma[w.idx, ] <- Delta.W[-(1:nw), ] |
| 1133 | ! |
Delta.B.tilde.Sigma[b.idx, ] <- Delta.B[-(1:nb), ] |
| 1134 | ||
| 1135 | ! |
Delta.W.tilde <- rbind(Delta.W.tilde.Mu, Delta.W.tilde.Sigma) |
| 1136 | ! |
Delta.B.tilde <- rbind(Delta.B.tilde.Mu, Delta.B.tilde.Sigma) |
| 1137 | ||
| 1138 | ! |
nobs <- Lp$nclusters[[1]] |
| 1139 | ! |
nclusters <- Lp$nclusters[[2]] |
| 1140 | ! |
cluster.size <- Lp$cluster.size[[2]] |
| 1141 | ! |
cluster.sizes <- Lp$cluster.sizes[[2]] |
| 1142 | ! |
ncluster.sizes <- Lp$ncluster.sizes[[2]] |
| 1143 | ! |
n.s <- Lp$cluster.size.ns[[2]] |
| 1144 | ! |
between.idx <- Lp$between.idx[[2]] |
| 1145 | ||
| 1146 | ! |
information.j <- matrix(0, npar, npar) |
| 1147 | ! |
for (clz in seq_len(ncluster.sizes)) {
|
| 1148 |
# cluster size |
|
| 1149 | ! |
nj <- cluster.sizes[clz] |
| 1150 | ||
| 1151 |
# Delta.j -- changes per cluster(size) |
|
| 1152 |
# this is why we can not write info = t(delta) info.sat delta |
|
| 1153 | ! |
Delta.j <- Delta.B.tilde + 1 / nj * Delta.W.tilde |
| 1154 | ||
| 1155 |
# compute Sigma.j |
|
| 1156 | ! |
sigma.j <- sigma.w + nj * sigma.b |
| 1157 | ! |
if (length(between.idx) > 0L) {
|
| 1158 | ! |
omega.j <- matrix(0, p.tilde, p.tilde) |
| 1159 | ! |
omega.j[-between.idx, -between.idx] <- 1 / nj * sigma.j |
| 1160 | ! |
omega.j[-between.idx, between.idx] <- sigma.yz |
| 1161 | ! |
omega.j[between.idx, -between.idx] <- t(sigma.yz) |
| 1162 | ! |
omega.j[between.idx, between.idx] <- sigma.zz |
| 1163 |
# omega.j <- rbind( cbind(sigma.zz, t(sigma.yz)), |
|
| 1164 |
# cbind(sigma.yz, 1/nj * sigma.j) ) |
|
| 1165 |
} else {
|
|
| 1166 | ! |
omega.j <- 1 / nj * sigma.j |
| 1167 |
} |
|
| 1168 | ! |
omega.j.inv <- solve(omega.j) |
| 1169 | ||
| 1170 | ! |
I11.j <- omega.j.inv |
| 1171 |
# if (lav_use_lavaanC()) {
|
|
| 1172 |
# I22.j <- lavaanC::m_kronecker_dup_pre_post(omega.j.inv, multiplicator = 0.5) |
|
| 1173 |
# } else {
|
|
| 1174 | ! |
I22.j <- 0.5 * lav_matrix_duplication_pre_post(omega.j.inv %x% omega.j.inv) |
| 1175 |
# } |
|
| 1176 | ! |
I.j <- lav_matrix_bdiag(I11.j, I22.j) |
| 1177 | ! |
info.j <- t(Delta.j) %*% I.j %*% Delta.j |
| 1178 | ||
| 1179 | ! |
information.j <- information.j + n.s[clz] * info.j |
| 1180 |
} |
|
| 1181 | ||
| 1182 | ||
| 1183 | ! |
Sigma.W.inv <- lav_matrix_symmetric_inverse( |
| 1184 | ! |
S = sigma.w, logdet = FALSE, |
| 1185 | ! |
Sinv.method = Sinv.method |
| 1186 |
) |
|
| 1187 | ! |
I11.w <- Sigma.W.inv |
| 1188 |
# if (lav_use_lavaanC()) {
|
|
| 1189 |
# I22.w <- lavaanC::m_kronecker_dup_pre_post(Sigma.W.inv, multiplicator = 0.5) |
|
| 1190 |
# } else {
|
|
| 1191 | ! |
I22.w <- 0.5 * lav_matrix_duplication_pre_post(Sigma.W.inv %x% Sigma.W.inv) |
| 1192 |
# } |
|
| 1193 | ! |
I.w <- lav_matrix_bdiag(I11.w, I22.w) |
| 1194 | ||
| 1195 |
# force zero for means both.idx in within part |
|
| 1196 |
# changed in 0.6-5 |
|
| 1197 | ! |
I.w[Lp$both.idx[[2]], ] <- 0 |
| 1198 | ! |
I.w[, Lp$both.idx[[2]]] <- 0 |
| 1199 | ||
| 1200 | ! |
information.w <- (nobs - nclusters) * (t(Delta.W) %*% I.w %*% Delta.W) |
| 1201 | ||
| 1202 |
# unit information |
|
| 1203 | ! |
information <- 1 / Lp$nclusters[[2]] * (information.w + information.j) |
| 1204 | ||
| 1205 | ||
| 1206 | ! |
information |
| 1207 |
} |
|
| 1208 | ||
| 1209 | ||
| 1210 |
# observed information |
|
| 1211 |
# order: mu.w within, vech(sigma.w) within, mu.b between, vech(sigma.b) between |
|
| 1212 |
# mu.w rows/cols that are splitted within/between are forced to zero |
|
| 1213 |
# |
|
| 1214 |
# numerical approximation (for now) |
|
| 1215 |
lav_mvnorm_cluster_information_observed <- function(Lp = NULL, |
|
| 1216 |
YLp = NULL, |
|
| 1217 |
Mu.W = NULL, |
|
| 1218 |
Sigma.W = NULL, |
|
| 1219 |
Mu.B = NULL, |
|
| 1220 |
Sigma.B = NULL, |
|
| 1221 |
x.idx = integer(0L), |
|
| 1222 |
Sinv.method = "eigen") {
|
|
| 1223 | ! |
nobs <- Lp$nclusters[[1]] |
| 1224 | ||
| 1225 | ! |
nw <- length(as.vector(Mu.W)) |
| 1226 | ! |
nw.star <- nw * (nw + 1) / 2 |
| 1227 | ! |
nb <- length(as.vector(Mu.B)) |
| 1228 | ! |
nb.star <- nb * (nb + 1) / 2 |
| 1229 | ||
| 1230 | ! |
ov.idx <- Lp$ov.idx |
| 1231 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 1232 | ||
| 1233 |
# Mu.W (for within-only) |
|
| 1234 | ! |
Mu.W.tilde <- numeric(p.tilde) |
| 1235 | ! |
Mu.W.tilde[ov.idx[[1]]] <- Mu.W |
| 1236 | ||
| 1237 |
# local function -- gradient |
|
| 1238 | ! |
GRAD <- function(x) {
|
| 1239 |
# Mu.W (for within-only) |
|
| 1240 | ! |
Mu.W.tilde2 <- numeric(p.tilde) |
| 1241 | ! |
Mu.W.tilde2[ov.idx[[1]]] <- x[1:nw] |
| 1242 | ! |
Mu.W.tilde2[Lp$both.idx[[2]]] <- Mu.W.tilde[Lp$both.idx[[2]]] |
| 1243 | ! |
Mu.W2 <- Mu.W.tilde2[ov.idx[[1]]] |
| 1244 | ||
| 1245 | ! |
Sigma.W2 <- lav_matrix_vech_reverse(x[nw + 1:nw.star]) |
| 1246 | ! |
Mu.B2 <- x[nw + nw.star + 1:nb] |
| 1247 | ! |
Sigma.B2 <- lav_matrix_vech_reverse(x[nw + nw.star + nb + 1:nb.star]) |
| 1248 | ||
| 1249 | ! |
dx <- lav_mvnorm_cluster_dlogl_2l_samplestats( |
| 1250 | ! |
YLp = YLp, |
| 1251 | ! |
Lp = Lp, Mu.W = Mu.W2, Sigma.W = Sigma.W2, |
| 1252 | ! |
Mu.B = Mu.B2, Sigma.B = Sigma.B2, |
| 1253 | ! |
return.list = FALSE, |
| 1254 | ! |
Sinv.method = Sinv.method |
| 1255 |
) |
|
| 1256 | ||
| 1257 |
# dx is for -2*logl |
|
| 1258 | ! |
-1 / 2 * dx |
| 1259 |
} |
|
| 1260 | ||
| 1261 |
# start.x |
|
| 1262 | ! |
start.x <- c( |
| 1263 | ! |
as.vector(Mu.W), lav_matrix_vech(Sigma.W), |
| 1264 | ! |
as.vector(Mu.B), lav_matrix_vech(Sigma.B) |
| 1265 |
) |
|
| 1266 | ||
| 1267 |
# total information |
|
| 1268 | ! |
information <- -1 * numDeriv::jacobian(func = GRAD, x = start.x) |
| 1269 | ||
| 1270 |
# unit information |
|
| 1271 | ! |
information <- information / Lp$nclusters[[2]] |
| 1272 | ||
| 1273 |
# if x.idx, set rows/cols to zero |
|
| 1274 | ! |
if (length(x.idx) > 0L) {
|
| 1275 | ! |
x.idx.w <- which(ov.idx[[1]] %in% x.idx) |
| 1276 | ! |
if (length(x.idx.w) > 0L) {
|
| 1277 | ! |
xw.idx <- c( |
| 1278 | ! |
x.idx.w, |
| 1279 | ! |
nw + lav_matrix_vech_which_idx(n = nw, idx = x.idx.w) |
| 1280 |
) |
|
| 1281 |
} else {
|
|
| 1282 | ! |
xw.idx <- integer(0L) |
| 1283 |
} |
|
| 1284 | ! |
x.idx.b <- which(ov.idx[[2]] %in% x.idx) |
| 1285 | ! |
if (length(x.idx.b) > 0L) {
|
| 1286 | ! |
xb.idx <- c( |
| 1287 | ! |
x.idx.b, |
| 1288 | ! |
nb + lav_matrix_vech_which_idx(n = nb, idx = x.idx.b) |
| 1289 |
) |
|
| 1290 |
} else {
|
|
| 1291 | ! |
xb.idx <- integer(0L) |
| 1292 |
} |
|
| 1293 | ||
| 1294 | ! |
all.idx <- c(xw.idx, nw + nw.star + xb.idx) |
| 1295 | ||
| 1296 | ! |
information[all.idx, ] <- 0 |
| 1297 | ! |
information[, all.idx] <- 0 |
| 1298 |
} |
|
| 1299 | ||
| 1300 | ! |
information |
| 1301 |
} |
|
| 1302 | ||
| 1303 |
# estimate ML estimates of Mu.W, Mu.B, Sigma.W, Sigma.B |
|
| 1304 |
# using the EM algorithm |
|
| 1305 |
# |
|
| 1306 |
# per cluster-SIZE |
|
| 1307 |
# |
|
| 1308 |
lav_mvnorm_cluster_em_sat <- function(YLp = NULL, |
|
| 1309 |
Lp = NULL, |
|
| 1310 |
tol = 1e-04, |
|
| 1311 |
max.iter = 5000, |
|
| 1312 |
min.variance = 1e-05) {
|
|
| 1313 |
# lavdata |
|
| 1314 | 4x |
between.idx <- Lp$between.idx[[2]] |
| 1315 | 4x |
within.idx <- Lp$within.idx[[2]] |
| 1316 | 4x |
Y2 <- YLp[[2]]$Y2 |
| 1317 | ||
| 1318 |
# starting values for Sigma |
|
| 1319 | 4x |
ov.idx <- Lp$ov.idx |
| 1320 |
# COVT <- lavsamplestats@cov[[1]] |
|
| 1321 |
# Sigma.W <- diag( diag(COVT)[ov.idx[[1]]] ) |
|
| 1322 |
# Sigma.B <- diag( diag(COVT)[ov.idx[[2]]] ) |
|
| 1323 | 4x |
Sigma.W <- diag(length(ov.idx[[1]])) |
| 1324 | 4x |
Sigma.B <- diag(length(ov.idx[[2]])) |
| 1325 | 4x |
Mu.W <- numeric(length(ov.idx[[1]])) |
| 1326 | 4x |
Mu.B <- numeric(length(ov.idx[[2]])) |
| 1327 |
# Mu.W.tilde <- YLp[[2]]$Mu.W |
|
| 1328 |
# Mu.B.tilde <- YLp[[2]]$Mu.B |
|
| 1329 |
# if(length(between.idx) > 0) {
|
|
| 1330 |
# Mu.W <- Mu.W.tilde[-between.idx] |
|
| 1331 |
# } else {
|
|
| 1332 |
# Mu.W <- Mu.W.tilde |
|
| 1333 |
# } |
|
| 1334 |
# if(length(within.idx) > 0) {
|
|
| 1335 |
# Mu.B <- Mu.B.tilde[-within.idx] |
|
| 1336 |
# } else {
|
|
| 1337 |
# Mu.B <- Mu.B.tilde |
|
| 1338 |
# } |
|
| 1339 | ||
| 1340 |
# report initial fx |
|
| 1341 | 4x |
fx <- lav_mvnorm_cluster_loglik_samplestats_2l( |
| 1342 | 4x |
YLp = YLp, Lp = Lp, |
| 1343 | 4x |
Mu.W = Mu.W, Sigma.W = Sigma.W, |
| 1344 | 4x |
Mu.B = Mu.B, Sigma.B = Sigma.B, |
| 1345 | 4x |
Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE |
| 1346 |
) |
|
| 1347 | ||
| 1348 |
# if verbose, report |
|
| 1349 | 4x |
if (lav_verbose()) {
|
| 1350 | ! |
cat( |
| 1351 | ! |
"EM iter:", sprintf("%3d", 0),
|
| 1352 | ! |
" fx =", sprintf("%17.10f", fx),
|
| 1353 | ! |
"\n" |
| 1354 |
) |
|
| 1355 |
} |
|
| 1356 | ||
| 1357 |
# translate to internal matrices |
|
| 1358 | 4x |
out <- lav_mvnorm_cluster_implied22l( |
| 1359 | 4x |
Lp = Lp, |
| 1360 | 4x |
Mu.W = Mu.W, Sigma.W = Sigma.W, Mu.B = Mu.B, Sigma.B = Sigma.B |
| 1361 |
) |
|
| 1362 | 4x |
mu.y <- out$mu.y |
| 1363 | 4x |
mu.z <- out$mu.z |
| 1364 | 4x |
mu.w <- out$mu.w |
| 1365 | 4x |
mu.b <- out$mu.b |
| 1366 | 4x |
sigma.w <- out$sigma.w |
| 1367 | 4x |
sigma.b <- out$sigma.b |
| 1368 | 4x |
sigma.zz <- out$sigma.zz |
| 1369 | 4x |
sigma.yz <- out$sigma.yz |
| 1370 | ||
| 1371 |
# mu.z and sigma.zz can be computed beforehand |
|
| 1372 | 4x |
if (length(between.idx) > 0L) {
|
| 1373 | ! |
Z <- Y2[, between.idx, drop = FALSE] |
| 1374 | ! |
mu.z <- colMeans(Z, na.rm = TRUE) |
| 1375 | ! |
sigma.zz <- cov(Z, use = "pairwise.complete.obs") * (Lp$nclusters[[2]] - 1L) / Lp$nclusters[[2]] |
| 1376 |
# sigma.zz <- 1/Lp$nclusters[[2]] * crossprod(Z) - tcrossprod(mu.z) |
|
| 1377 |
# Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop=FALSE] |
|
| 1378 |
} |
|
| 1379 | ||
| 1380 |
# EM iterations |
|
| 1381 | 4x |
fx.old <- fx |
| 1382 | 4x |
for (i in 1:max.iter) {
|
| 1383 |
# E-step |
|
| 1384 | 84x |
estep <- lav_mvnorm_cluster_em_estepb( # Y1 = Y1, |
| 1385 | 84x |
YLp = YLp, |
| 1386 | 84x |
Lp = Lp, |
| 1387 | 84x |
sigma.w = sigma.w, |
| 1388 | 84x |
sigma.b = sigma.b, |
| 1389 | 84x |
mu.w = mu.w, |
| 1390 | 84x |
mu.b = mu.b, |
| 1391 | 84x |
sigma.yz = sigma.yz, |
| 1392 | 84x |
sigma.zz = sigma.zz, |
| 1393 | 84x |
mu.z = mu.z |
| 1394 |
) |
|
| 1395 | ||
| 1396 |
# mstep |
|
| 1397 | 84x |
sigma.w <- estep$sigma.w |
| 1398 | 84x |
sigma.b <- estep$sigma.b |
| 1399 | 84x |
sigma.yz <- estep$sigma.yz |
| 1400 | 84x |
mu.w <- estep$mu.w |
| 1401 | 84x |
mu.b <- estep$mu.b |
| 1402 | ||
| 1403 | 84x |
implied2 <- lav_mvnorm_cluster_2l2implied( |
| 1404 | 84x |
Lp = Lp, |
| 1405 | 84x |
sigma.w = estep$sigma.w, sigma.b = estep$sigma.b, |
| 1406 | 84x |
sigma.zz = sigma.zz, sigma.yz = estep$sigma.yz, |
| 1407 | 84x |
mu.z = mu.z, |
| 1408 | 84x |
mu.y = NULL, mu.w = estep$mu.w, mu.b = estep$mu.b |
| 1409 |
) |
|
| 1410 | ||
| 1411 |
# check for (near-zero) variances at the within level, and set |
|
| 1412 |
# them to min.variance |
|
| 1413 | 84x |
Sigma.W <- implied2$Sigma.W |
| 1414 | 84x |
zero.var <- which(diag(Sigma.W) < min.variance) |
| 1415 | 84x |
if (length(zero.var) > 0L) {
|
| 1416 | ! |
Sigma.W[, zero.var] <- sigma.w[, zero.var] <- 0 |
| 1417 | ! |
Sigma.W[zero.var, ] <- sigma.w[zero.var, ] <- 0 |
| 1418 | ! |
diag(Sigma.W)[zero.var] <- diag(sigma.w)[zero.var] <- min.variance |
| 1419 |
} |
|
| 1420 | ||
| 1421 | 84x |
fx <- lav_mvnorm_cluster_loglik_samplestats_2l( |
| 1422 | 84x |
YLp = YLp, |
| 1423 | 84x |
Lp = Lp, Mu.W = implied2$Mu.W, Sigma.W = Sigma.W, |
| 1424 | 84x |
Mu.B = implied2$Mu.B, Sigma.B = implied2$Sigma.B, |
| 1425 | 84x |
Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE |
| 1426 |
) |
|
| 1427 | ||
| 1428 |
# fx.delta |
|
| 1429 | 84x |
fx.delta <- fx - fx.old |
| 1430 | ||
| 1431 |
# check if fx.delta is finite |
|
| 1432 | 84x |
if (!is.finite(fx.delta)) {
|
| 1433 |
# not good ... something is very wrong; perhaps near-singular |
|
| 1434 |
# matrices? |
|
| 1435 | ! |
cat("\n")
|
| 1436 | ! |
cat("FATAL problem: dumping Sigma.W and Sigma.B matrices:\n\n")
|
| 1437 | ! |
cat("Sigma.W:\n")
|
| 1438 | ! |
print(Sigma.W) |
| 1439 | ! |
cat("\n")
|
| 1440 | ! |
cat("Sigma.B:\n")
|
| 1441 | ! |
print(implied2$Sigma.B) |
| 1442 | ! |
cat("\n")
|
| 1443 | ! |
lav_msg_stop(gettext( |
| 1444 | ! |
"EM steps of the saturated (H1) model failed; some matrices may |
| 1445 | ! |
be singular; please check your data for (near-)perfect correlations.")) |
| 1446 |
} |
|
| 1447 | ||
| 1448 |
# what if fx.delta is negative? |
|
| 1449 | 84x |
if (fx.delta < 0) {
|
| 1450 | ! |
lav_msg_warn(gettext( |
| 1451 | ! |
"logl decreased during EM steps of the saturated (H1) model")) |
| 1452 |
} |
|
| 1453 | ||
| 1454 | 84x |
if (lav_verbose()) {
|
| 1455 | ! |
cat( |
| 1456 | ! |
"EM iter:", sprintf("%3d", i),
|
| 1457 | ! |
" fx =", sprintf("%17.10f", fx),
|
| 1458 | ! |
" fx.delta =", sprintf("%9.8f", fx.delta),
|
| 1459 | ! |
"\n" |
| 1460 |
) |
|
| 1461 |
} |
|
| 1462 | ||
| 1463 |
# convergence check |
|
| 1464 | 84x |
if (fx.delta < tol) {
|
| 1465 | 4x |
break |
| 1466 |
} else {
|
|
| 1467 | 80x |
fx.old <- fx |
| 1468 |
} |
|
| 1469 |
} # EM iterations |
|
| 1470 | ||
| 1471 | 4x |
list( |
| 1472 | 4x |
Sigma.W = implied2$Sigma.W, Sigma.B = implied2$Sigma.B, |
| 1473 | 4x |
Mu.W = implied2$Mu.W, Mu.B = implied2$Mu.B, logl = fx |
| 1474 |
) |
|
| 1475 |
} |
|
| 1476 | ||
| 1477 | ||
| 1478 |
# based on lav_mvnorm_cluster_em_estep |
|
| 1479 |
lav_mvnorm_cluster_em_h0 <- function(lavsamplestats = NULL, |
|
| 1480 |
lavdata = NULL, |
|
| 1481 |
lavimplied = NULL, |
|
| 1482 |
lavpartable = NULL, |
|
| 1483 |
lavmodel = NULL, |
|
| 1484 |
lavoptions = NULL, |
|
| 1485 |
verbose.x = FALSE, |
|
| 1486 |
fx.tol = 1e-08, |
|
| 1487 |
dx.tol = 1e-05, |
|
| 1488 |
max.iter = 5000, |
|
| 1489 |
mstep.iter.max = 10000L, |
|
| 1490 |
mstep.rel.tol = 1e-10) {
|
|
| 1491 |
# single group only for now |
|
| 1492 | ! |
stopifnot(lavdata@ngroups == 1L) |
| 1493 | ||
| 1494 |
# lavdata |
|
| 1495 | ! |
Lp <- lavdata@Lp[[1]] # first group only (for now) |
| 1496 | ! |
ov.names.l <- lavdata@ov.names.l[[1]] # first group only (for now) |
| 1497 | ! |
Y1 <- lavdata@X[[1]] # first group only |
| 1498 | ! |
YLp <- lavsamplestats@YLp[[1]] # first group only |
| 1499 | ||
| 1500 | ! |
between.idx <- Lp$between.idx[[2]] |
| 1501 | ! |
Y2 <- YLp[[2]]$Y2 |
| 1502 | ||
| 1503 |
# initial values |
|
| 1504 | ! |
x.current <- lav_model_get_parameters(lavmodel) |
| 1505 | ||
| 1506 |
# implied |
|
| 1507 | ! |
if (is.null(lavimplied)) {
|
| 1508 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 1509 |
} |
|
| 1510 | ||
| 1511 |
# TODO: what if current 'starting' parameters imply a non-pd sigma.b? |
|
| 1512 | ||
| 1513 |
# report initial fx |
|
| 1514 | ! |
fx <- lav_mvnorm_cluster_loglik_samplestats_2l( |
| 1515 | ! |
YLp = YLp, Lp = Lp, |
| 1516 | ! |
Mu.W = lavimplied$mean[[1]], Sigma.W = lavimplied$cov[[1]], |
| 1517 | ! |
Mu.B = lavimplied$mean[[2]], Sigma.B = lavimplied$cov[[2]], |
| 1518 | ! |
Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE |
| 1519 |
) |
|
| 1520 | ||
| 1521 |
# if verbose, report |
|
| 1522 | ! |
if (lav_verbose()) {
|
| 1523 | ! |
cat( |
| 1524 | ! |
"EM iter:", sprintf("%3d", 0),
|
| 1525 | ! |
" fx =", sprintf("%17.10f", fx),
|
| 1526 | ! |
"\n" |
| 1527 |
) |
|
| 1528 |
} |
|
| 1529 | ||
| 1530 |
# translate to internal matrices |
|
| 1531 | ! |
out <- lav_mvnorm_cluster_implied22l( |
| 1532 | ! |
Lp = Lp, |
| 1533 | ! |
Mu.W = lavimplied$mean[[1]], Sigma.W = lavimplied$cov[[1]], |
| 1534 | ! |
Mu.B = lavimplied$mean[[2]], Sigma.B = lavimplied$cov[[2]] |
| 1535 |
) |
|
| 1536 | ! |
mu.y <- out$mu.y |
| 1537 | ! |
mu.z <- out$mu.z |
| 1538 | ! |
mu.w <- out$mu.w |
| 1539 | ! |
mu.b <- out$mu.b |
| 1540 | ! |
sigma.w <- out$sigma.w |
| 1541 | ! |
sigma.b <- out$sigma.b |
| 1542 | ! |
sigma.zz <- out$sigma.zz |
| 1543 | ! |
sigma.yz <- out$sigma.yz |
| 1544 | ||
| 1545 |
# mu.z and sigma.zz can be computed beforehand |
|
| 1546 | ! |
if (length(between.idx) > 0L) {
|
| 1547 | ! |
Z <- Y2[, between.idx, drop = FALSE] |
| 1548 | ! |
mu.z <- colMeans(Y2)[between.idx] |
| 1549 | ! |
sigma.zz <- cov(Z) * (Lp$nclusters[[2]] - 1L) / Lp$nclusters[[2]] |
| 1550 |
# sigma.zz <- 1/Lp$nclusters[[2]] * crossprod(Z) - tcrossprod(mu.z) |
|
| 1551 |
# Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop=FALSE] |
|
| 1552 |
} |
|
| 1553 | ||
| 1554 |
# EM iterations |
|
| 1555 | ! |
fx.old <- fx |
| 1556 | ! |
fx2.old <- 0 |
| 1557 | ! |
REL <- numeric(max.iter) |
| 1558 | ! |
for (i in 1:max.iter) {
|
| 1559 |
# E-step |
|
| 1560 | ! |
estep <- lav_mvnorm_cluster_em_estepb( |
| 1561 | ! |
YLp = YLp, |
| 1562 | ! |
Lp = Lp, |
| 1563 | ! |
sigma.w = sigma.w, |
| 1564 | ! |
sigma.b = sigma.b, |
| 1565 | ! |
mu.w = mu.w, |
| 1566 | ! |
mu.b = mu.b, |
| 1567 | ! |
sigma.yz = sigma.yz, |
| 1568 | ! |
sigma.zz = sigma.zz, |
| 1569 | ! |
mu.z = mu.z |
| 1570 |
) |
|
| 1571 | ||
| 1572 |
# back to model-implied dimensions |
|
| 1573 | ! |
implied <- lav_mvnorm_cluster_2l2implied( |
| 1574 | ! |
Lp = Lp, |
| 1575 | ! |
sigma.w = estep$sigma.w, sigma.b = estep$sigma.b, |
| 1576 | ! |
sigma.zz = sigma.zz, sigma.yz = estep$sigma.yz, |
| 1577 | ! |
mu.z = mu.z, |
| 1578 | ! |
mu.y = NULL, mu.w = estep$mu.w, mu.b = estep$mu.b |
| 1579 |
) |
|
| 1580 | ! |
rownames(implied$Sigma.W) <- ov.names.l[[1]] |
| 1581 | ! |
rownames(implied$Sigma.B) <- ov.names.l[[2]] |
| 1582 | ||
| 1583 |
# M-step |
|
| 1584 | ||
| 1585 |
# fit two-group model |
|
| 1586 | ! |
local.partable <- lavpartable |
| 1587 |
# if a group column exists, delete it (it will be overriden anyway) |
|
| 1588 | ! |
local.partable$group <- NULL |
| 1589 | ! |
level.idx <- which(names(local.partable) == "level") |
| 1590 | ! |
names(local.partable)[level.idx] <- "group" |
| 1591 | ! |
local.partable$est <- NULL |
| 1592 | ! |
local.partable$se <- NULL |
| 1593 | ||
| 1594 |
# give current values as starting values |
|
| 1595 | ! |
free.idx <- which(lavpartable$free > 0L) |
| 1596 | ! |
local.partable$ustart[free.idx] <- x.current |
| 1597 | ||
| 1598 | ! |
local.fit <- lavaan(local.partable, |
| 1599 | ! |
sample.cov = list( |
| 1600 | ! |
within = implied$Sigma.W, |
| 1601 | ! |
between = implied$Sigma.B |
| 1602 |
), |
|
| 1603 | ! |
sample.mean = list( |
| 1604 | ! |
within = implied$Mu.W, |
| 1605 | ! |
between = implied$Mu.B |
| 1606 |
), |
|
| 1607 | ! |
sample.nobs = Lp$nclusters, |
| 1608 | ! |
sample.cov.rescale = FALSE, |
| 1609 | ! |
control = list( |
| 1610 | ! |
iter.max = mstep.iter.max, |
| 1611 | ! |
rel.tol = mstep.rel.tol |
| 1612 |
), |
|
| 1613 | ! |
fixed.x = any(lavpartable$exo == 1L), |
| 1614 | ! |
estimator = "ML", |
| 1615 | ! |
warn = FALSE, # no warnings |
| 1616 | ! |
check.start = FALSE, |
| 1617 | ! |
check.post = FALSE, |
| 1618 | ! |
check.gradient = FALSE, |
| 1619 | ! |
check.vcov = FALSE, |
| 1620 | ! |
baseline = FALSE, |
| 1621 | ! |
h1 = FALSE, |
| 1622 | ! |
se = "none", |
| 1623 | ! |
test = "none" |
| 1624 |
) |
|
| 1625 | ||
| 1626 |
# end of M-step |
|
| 1627 | ||
| 1628 | ! |
implied2 <- local.fit@implied |
| 1629 | ! |
fx <- lav_mvnorm_cluster_loglik_samplestats_2l( |
| 1630 | ! |
YLp = YLp, |
| 1631 | ! |
Lp = Lp, Mu.W = implied2$mean[[1]], Sigma.W = implied2$cov[[1]], |
| 1632 | ! |
Mu.B = implied2$mean[[2]], Sigma.B = implied2$cov[[2]], |
| 1633 | ! |
Sinv.method = "eigen", log2pi = TRUE, minus.two = FALSE |
| 1634 |
) |
|
| 1635 | ||
| 1636 |
# fx.delta |
|
| 1637 | ! |
fx.delta <- fx - fx.old |
| 1638 | ||
| 1639 |
# derivatives |
|
| 1640 | ! |
lavmodel <- lav_model_set_parameters(lavmodel, x = local.fit@optim$x) |
| 1641 | ! |
dx <- lav_model_gradient(lavmodel, |
| 1642 | ! |
lavdata = lavdata, |
| 1643 | ! |
lavsamplestats = lavsamplestats |
| 1644 |
) |
|
| 1645 | ! |
max.dx <- max(abs(dx)) |
| 1646 | ||
| 1647 | ! |
if (lav_verbose()) {
|
| 1648 | ! |
cat( |
| 1649 | ! |
"EM iter:", sprintf("%3d", i),
|
| 1650 | ! |
" fx =", sprintf("%17.10f", fx),
|
| 1651 | ! |
" fx.delta =", sprintf("%9.8f", fx.delta),
|
| 1652 | ! |
" mstep.iter =", sprintf( |
| 1653 | ! |
"%3d", |
| 1654 | ! |
lavInspect(local.fit, "iterations") |
| 1655 |
), |
|
| 1656 | ! |
" max.dx = ", sprintf("%9.8f", max.dx),
|
| 1657 | ! |
"\n" |
| 1658 |
) |
|
| 1659 |
} |
|
| 1660 | ||
| 1661 |
# stopping rule check |
|
| 1662 | ! |
if (fx.delta < fx.tol) {
|
| 1663 | ! |
if (lav_verbose()) {
|
| 1664 | ! |
cat("EM stopping rule reached: fx.delta < ", fx.tol, "\n")
|
| 1665 |
} |
|
| 1666 | ! |
break |
| 1667 |
} else {
|
|
| 1668 | ! |
fx.old <- fx |
| 1669 | ! |
x.current <- local.fit@optim$x |
| 1670 | ! |
if (verbose.x) {
|
| 1671 | ! |
print(round(x.current, 3)) |
| 1672 |
} |
|
| 1673 |
} |
|
| 1674 | ||
| 1675 |
# second stopping rule check -- derivatives |
|
| 1676 | ! |
if (max.dx < dx.tol) {
|
| 1677 | ! |
if (lav_verbose()) {
|
| 1678 | ! |
cat("EM stopping rule reached: max.dx < ", dx.tol, "\n")
|
| 1679 |
} |
|
| 1680 | ! |
break |
| 1681 |
} |
|
| 1682 | ||
| 1683 |
# translate to internal matrices |
|
| 1684 | ! |
out <- lav_mvnorm_cluster_implied22l( |
| 1685 | ! |
Lp = Lp, |
| 1686 | ! |
Mu.W = implied2$mean[[1]], Sigma.W = implied2$cov[[1]], |
| 1687 | ! |
Mu.B = implied2$mean[[2]], Sigma.B = implied2$cov[[2]] |
| 1688 |
) |
|
| 1689 | ! |
mu.y <- out$mu.y |
| 1690 | ! |
mu.z <- out$mu.z |
| 1691 | ! |
mu.w <- out$mu.w |
| 1692 | ! |
mu.b <- out$mu.b |
| 1693 | ! |
sigma.w <- out$sigma.w |
| 1694 | ! |
sigma.b <- out$sigma.b |
| 1695 | ! |
sigma.zz <- out$sigma.zz |
| 1696 | ! |
sigma.yz <- out$sigma.yz |
| 1697 |
} # EM iterations |
|
| 1698 | ||
| 1699 | ! |
x <- local.fit@optim$x |
| 1700 | ||
| 1701 |
# add attributes |
|
| 1702 | ! |
if (i < max.iter) {
|
| 1703 | ! |
attr(x, "converged") <- TRUE |
| 1704 | ! |
attr(x, "warn.txt") <- "" |
| 1705 |
} else {
|
|
| 1706 | ! |
attr(x, "converged") <- FALSE |
| 1707 | ! |
attr(x, "warn.txt") <- paste("maxmimum number of iterations (",
|
| 1708 | ! |
max.iter, ") ", |
| 1709 | ! |
"was reached without convergence.\n", |
| 1710 | ! |
sep = "" |
| 1711 |
) |
|
| 1712 |
} |
|
| 1713 | ! |
attr(x, "iterations") <- i |
| 1714 | ! |
attr(x, "control") <- list( |
| 1715 | ! |
em.iter.max = max.iter, |
| 1716 | ! |
em.fx.tol = fx.tol, |
| 1717 | ! |
em.dx.tol = dx.tol |
| 1718 |
) |
|
| 1719 | ! |
attr(fx, "fx.group") <- fx # single group for now |
| 1720 | ! |
attr(x, "fx") <- fx |
| 1721 | ||
| 1722 | ! |
x |
| 1723 |
} |
|
| 1724 | ||
| 1725 |
# get the random effects (here: expected values for cluster means) |
|
| 1726 |
# and optionally a standard error |
|
| 1727 |
lav_mvnorm_cluster_em_estep_ranef <- function(YLp = NULL, |
|
| 1728 |
Lp = NULL, |
|
| 1729 |
sigma.w = NULL, |
|
| 1730 |
sigma.b = NULL, |
|
| 1731 |
sigma.yz = NULL, |
|
| 1732 |
sigma.zz = NULL, |
|
| 1733 |
mu.z = NULL, |
|
| 1734 |
mu.w = NULL, |
|
| 1735 |
mu.b = NULL, |
|
| 1736 |
se = FALSE) {
|
|
| 1737 |
# sample stats |
|
| 1738 | 16x |
nobs <- Lp$nclusters[[1]] |
| 1739 | 16x |
nclusters <- Lp$nclusters[[2]] |
| 1740 | 16x |
cluster.size <- Lp$cluster.size[[2]] |
| 1741 | 16x |
between.idx <- Lp$between.idx[[2]] |
| 1742 | ||
| 1743 | 16x |
Y2 <- YLp[[2]]$Y2 |
| 1744 | ||
| 1745 | 16x |
nvar.y <- ncol(sigma.w) |
| 1746 | 16x |
nvar.z <- ncol(sigma.zz) |
| 1747 | ||
| 1748 | 16x |
MB.j <- matrix(0, nrow = nclusters, ncol = nvar.y) |
| 1749 | 16x |
SE.j <- matrix(0, nrow = nclusters, ncol = nvar.y) |
| 1750 | ||
| 1751 | 16x |
mu.y <- mu.w + mu.b |
| 1752 | ||
| 1753 | 16x |
if (length(between.idx) > 0L) {
|
| 1754 | ! |
sigma.1 <- cbind(sigma.yz, sigma.b) |
| 1755 | ! |
mu <- c(mu.z, mu.y) |
| 1756 |
} else {
|
|
| 1757 | 16x |
sigma.1 <- sigma.b |
| 1758 | 16x |
mu <- mu.y |
| 1759 |
} |
|
| 1760 | ||
| 1761 |
# E-step |
|
| 1762 | 16x |
for (cl in seq_len(nclusters)) {
|
| 1763 | 1600x |
nj <- cluster.size[cl] |
| 1764 | ||
| 1765 |
# data |
|
| 1766 | 1600x |
if (length(between.idx) > 0L) {
|
| 1767 |
# z comes first! |
|
| 1768 | ! |
b.j <- c( |
| 1769 | ! |
Y2[cl, between.idx], |
| 1770 | ! |
Y2[cl, -between.idx] |
| 1771 |
) |
|
| 1772 | ! |
ybar.j <- Y2[cl, -between.idx] |
| 1773 |
} else {
|
|
| 1774 | 1600x |
ybar.j <- b.j <- Y2[cl, ] |
| 1775 |
} |
|
| 1776 | ||
| 1777 | 1600x |
sigma.j <- sigma.w + nj * sigma.b |
| 1778 | 1600x |
if (length(between.idx) > 0L) {
|
| 1779 | ! |
omega.j <- rbind( |
| 1780 | ! |
cbind(sigma.zz, t(sigma.yz)), |
| 1781 | ! |
cbind(sigma.yz, 1 / nj * sigma.j) |
| 1782 |
) |
|
| 1783 |
} else {
|
|
| 1784 | 1600x |
omega.j <- 1 / nj * sigma.j |
| 1785 |
} |
|
| 1786 | 1600x |
omega.j.inv <- solve(omega.j) |
| 1787 | ||
| 1788 |
# E(v|y) |
|
| 1789 | 1600x |
Ev <- as.numeric(mu.b + (sigma.1 %*% omega.j.inv %*% (b.j - mu))) |
| 1790 | 1600x |
MB.j[cl, ] <- Ev |
| 1791 | ||
| 1792 | 1600x |
if (se) {
|
| 1793 |
# Cov(v|y) |
|
| 1794 | ! |
Covv <- sigma.b - (sigma.1 %*% omega.j.inv %*% t(sigma.1)) |
| 1795 | ||
| 1796 |
# force symmetry |
|
| 1797 | ! |
Covv <- (Covv + t(Covv)) / 2 |
| 1798 | ||
| 1799 | ! |
Covv.diag <- diag(Covv) |
| 1800 | ! |
nonzero.idx <- which(Covv.diag > 0) |
| 1801 | ||
| 1802 | ! |
SE.j[cl, ] <- numeric(length(Covv.diag)) |
| 1803 | ! |
SE.j[cl, nonzero.idx] <- sqrt(Covv.diag[nonzero.idx]) |
| 1804 |
} |
|
| 1805 |
} |
|
| 1806 | ||
| 1807 | 16x |
if (se) {
|
| 1808 | ! |
attr(MB.j, "se") <- SE.j |
| 1809 |
} |
|
| 1810 | ||
| 1811 | 16x |
MB.j |
| 1812 |
} |
|
| 1813 | ||
| 1814 |
# per cluster |
|
| 1815 |
lav_mvnorm_cluster_em_estep <- function( # Y1 = NULL, |
|
| 1816 |
YLp = NULL, |
|
| 1817 |
Lp = NULL, |
|
| 1818 |
sigma.w = NULL, |
|
| 1819 |
sigma.b = NULL, |
|
| 1820 |
sigma.yz = NULL, |
|
| 1821 |
sigma.zz = NULL, |
|
| 1822 |
mu.z = NULL, |
|
| 1823 |
mu.w = NULL, |
|
| 1824 |
mu.b = NULL) {
|
|
| 1825 |
# sample stats |
|
| 1826 | ! |
nobs <- Lp$nclusters[[1]] |
| 1827 | ! |
nclusters <- Lp$nclusters[[2]] |
| 1828 | ! |
cluster.size <- Lp$cluster.size[[2]] |
| 1829 | ! |
cluster.idx <- Lp$cluster.idx[[2]] |
| 1830 | ! |
within.idx <- Lp$within.idx[[2]] |
| 1831 | ! |
between.idx <- Lp$between.idx[[2]] |
| 1832 | ! |
both.idx <- Lp$both.idx[[2]] |
| 1833 | ||
| 1834 | ! |
Y2 <- YLp[[2]]$Y2 |
| 1835 | ! |
Y1Y1 <- YLp[[2]]$Y1Y1 |
| 1836 | ||
| 1837 | ! |
nvar.y <- ncol(sigma.w) |
| 1838 | ! |
nvar.z <- ncol(sigma.zz) |
| 1839 | ||
| 1840 | ! |
CW2.j <- matrix(0, nrow = nvar.y, ncol = nvar.y) |
| 1841 | ! |
CB.j <- matrix(0, nrow = nvar.y, ncol = nvar.y) |
| 1842 | ! |
MW.j <- matrix(0, nrow = nclusters, ncol = nvar.y) |
| 1843 | ! |
MB.j <- matrix(0, nrow = nclusters, ncol = nvar.y) |
| 1844 | ! |
ZY.j <- matrix(0, nrow = nvar.z, ncol = nvar.y) |
| 1845 | ||
| 1846 | ! |
mu.y <- mu.w + mu.b |
| 1847 | ||
| 1848 | ! |
if (length(between.idx) > 0L) {
|
| 1849 | ! |
sigma.1 <- cbind(sigma.yz, sigma.b) |
| 1850 | ! |
mu <- c(mu.z, mu.y) |
| 1851 | ! |
Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop = FALSE] |
| 1852 |
} else {
|
|
| 1853 | ! |
sigma.1 <- sigma.b |
| 1854 | ! |
mu <- mu.y |
| 1855 |
} |
|
| 1856 | ||
| 1857 |
# E-step |
|
| 1858 | ! |
for (cl in seq_len(nclusters)) {
|
| 1859 | ! |
nj <- cluster.size[cl] |
| 1860 | ||
| 1861 |
# data |
|
| 1862 | ! |
if (length(between.idx) > 0L) {
|
| 1863 |
# z comes first! |
|
| 1864 | ! |
b.j <- c( |
| 1865 | ! |
Y2[cl, between.idx], |
| 1866 | ! |
Y2[cl, -between.idx] |
| 1867 |
) |
|
| 1868 | ! |
ybar.j <- Y2[cl, -between.idx] |
| 1869 |
} else {
|
|
| 1870 | ! |
ybar.j <- b.j <- Y2[cl, ] |
| 1871 |
} |
|
| 1872 | ||
| 1873 | ! |
sigma.j <- sigma.w + nj * sigma.b |
| 1874 | ! |
if (length(between.idx) > 0L) {
|
| 1875 | ! |
omega.j <- rbind( |
| 1876 | ! |
cbind(sigma.zz, t(sigma.yz)), |
| 1877 | ! |
cbind(sigma.yz, 1 / nj * sigma.j) |
| 1878 |
) |
|
| 1879 |
} else {
|
|
| 1880 | ! |
omega.j <- 1 / nj * sigma.j |
| 1881 |
} |
|
| 1882 | ! |
omega.j.inv <- solve(omega.j) |
| 1883 | ||
| 1884 |
# E(v|y) |
|
| 1885 | ! |
Ev <- as.numeric(mu.b + (sigma.1 %*% omega.j.inv %*% (b.j - mu))) |
| 1886 | ||
| 1887 |
# Cov(v|y) |
|
| 1888 | ! |
Covv <- sigma.b - (sigma.1 %*% omega.j.inv %*% t(sigma.1)) |
| 1889 | ||
| 1890 |
# force symmetry |
|
| 1891 | ! |
Covv <- (Covv + t(Covv)) / 2 |
| 1892 | ||
| 1893 |
# E(vv|y) = Cov(v|y) + E(v|y)E(v|y)^T |
|
| 1894 | ! |
Evv <- Covv + tcrossprod(Ev) |
| 1895 | ||
| 1896 |
# store for this cluster |
|
| 1897 | ! |
MW.j[cl, ] <- ybar.j - Ev |
| 1898 | ! |
MB.j[cl, ] <- Ev |
| 1899 | ! |
CW2.j <- CW2.j + nj * (Evv - tcrossprod(ybar.j, Ev) |
| 1900 | ! |
- tcrossprod(Ev, ybar.j)) |
| 1901 | ! |
CB.j <- CB.j + Evv |
| 1902 | ||
| 1903 |
# between only |
|
| 1904 | ! |
if (length(between.idx) > 0L) {
|
| 1905 | ! |
ZY.j <- ZY.j + tcrossprod(Y2[cl, between.idx], Ev) |
| 1906 |
} |
|
| 1907 |
} |
|
| 1908 | ||
| 1909 | ! |
M.w <- 1 / nobs * colSums(MW.j * cluster.size) |
| 1910 | ! |
M.b <- 1 / nclusters * colSums(MB.j) |
| 1911 | ! |
C.b <- 1 / nclusters * CB.j |
| 1912 | ! |
C.w <- 1 / nobs * (Y1Y1 + CW2.j) |
| 1913 |
# end of E-step |
|
| 1914 | ||
| 1915 |
# make symmetric (not needed here?) |
|
| 1916 |
# C.b <- (C.b + t(C.b))/2 |
|
| 1917 |
# C.w <- (C.w + t(C.w))/2 |
|
| 1918 | ||
| 1919 |
# between only |
|
| 1920 | ! |
if (length(between.idx) > 0L) {
|
| 1921 | ! |
A <- 1 / nclusters * ZY.j - tcrossprod(mu.z, M.b) |
| 1922 |
} |
|
| 1923 | ||
| 1924 | ! |
sigma.w <- C.w - tcrossprod(M.w) |
| 1925 | ! |
sigma.b <- C.b - tcrossprod(M.b) |
| 1926 | ! |
mu.w <- M.w |
| 1927 | ! |
mu.b <- M.b |
| 1928 | ||
| 1929 | ! |
if (length(between.idx) > 0L) {
|
| 1930 | ! |
sigma.yz <- t(A) |
| 1931 |
} |
|
| 1932 | ||
| 1933 | ! |
list( |
| 1934 | ! |
sigma.w = sigma.w, sigma.b = sigma.b, mu.w = mu.w, mu.b = mu.b, |
| 1935 | ! |
sigma.yz = sigma.yz, sigma.zz = sigma.zz, mu.z = mu.z |
| 1936 |
) |
|
| 1937 |
} |
|
| 1938 | ||
| 1939 |
# per cluster SIZE |
|
| 1940 |
lav_mvnorm_cluster_em_estepb <- function( # Y1 = NULL, # not used! |
|
| 1941 |
YLp = NULL, |
|
| 1942 |
Lp = NULL, |
|
| 1943 |
sigma.w = NULL, |
|
| 1944 |
sigma.b = NULL, |
|
| 1945 |
sigma.yz = NULL, |
|
| 1946 |
sigma.zz = NULL, |
|
| 1947 |
mu.z = NULL, |
|
| 1948 |
mu.w = NULL, |
|
| 1949 |
mu.b = NULL) {
|
|
| 1950 |
# sample stats |
|
| 1951 | 84x |
nobs <- Lp$nclusters[[1]] |
| 1952 | 84x |
nclusters <- Lp$nclusters[[2]] |
| 1953 | 84x |
cluster.size <- Lp$cluster.size[[2]] |
| 1954 | 84x |
cluster.idx <- Lp$cluster.idx[[2]] |
| 1955 | 84x |
between.idx <- Lp$between.idx[[2]] |
| 1956 | 84x |
cluster.sizes <- Lp$cluster.sizes[[2]] |
| 1957 | 84x |
ncluster.sizes <- Lp$ncluster.sizes[[2]] |
| 1958 | 84x |
n.s <- Lp$cluster.size.ns[[2]] |
| 1959 | ||
| 1960 | 84x |
Y2 <- YLp[[2]]$Y2 |
| 1961 | 84x |
Y1Y1 <- YLp[[2]]$Y1Y1 |
| 1962 | ||
| 1963 | 84x |
nvar.y <- ncol(sigma.w) |
| 1964 | 84x |
nvar.z <- ncol(sigma.zz) |
| 1965 | ||
| 1966 | 84x |
mu.y <- mu.w + mu.b |
| 1967 | ||
| 1968 | 84x |
if (length(between.idx) > 0L) {
|
| 1969 | ! |
sigma.1 <- cbind(sigma.yz, sigma.b) |
| 1970 | ! |
mu <- c(mu.z, mu.y) |
| 1971 | ! |
Y1Y1 <- Y1Y1[-between.idx, -between.idx, drop = FALSE] |
| 1972 |
} else {
|
|
| 1973 | 84x |
sigma.1 <- sigma.b |
| 1974 | 84x |
mu <- mu.y |
| 1975 |
} |
|
| 1976 | ||
| 1977 |
# per cluster SIZE |
|
| 1978 | 84x |
CW2.s <- matrix(0, nrow = nvar.y, ncol = nvar.y) |
| 1979 | 84x |
CB.s <- matrix(0, nrow = nvar.y, ncol = nvar.y) |
| 1980 | 84x |
MW.s <- matrix(0, nrow = ncluster.sizes, ncol = nvar.y) |
| 1981 | 84x |
MB.s <- matrix(0, nrow = ncluster.sizes, ncol = nvar.y) |
| 1982 | 84x |
ZY.s <- matrix(0, nvar.z, nvar.y) |
| 1983 | ||
| 1984 |
# E-step |
|
| 1985 | 84x |
for (clz in seq_len(ncluster.sizes)) {
|
| 1986 |
# cluster size |
|
| 1987 | 168x |
nj <- cluster.sizes[clz] |
| 1988 | ||
| 1989 |
# data |
|
| 1990 | 168x |
if (length(between.idx) > 0L) {
|
| 1991 |
# z comes first! |
|
| 1992 | ! |
b.j <- cbind( |
| 1993 | ! |
Y2[cluster.size == nj, between.idx, drop = FALSE], |
| 1994 | ! |
Y2[cluster.size == nj, -between.idx, drop = FALSE] |
| 1995 |
) |
|
| 1996 | ! |
ybar.j <- Y2[cluster.size == nj, -between.idx, drop = FALSE] |
| 1997 |
} else {
|
|
| 1998 | 168x |
ybar.j <- b.j <- Y2[cluster.size == nj, , drop = FALSE] |
| 1999 |
} |
|
| 2000 | ||
| 2001 | 168x |
sigma.j <- sigma.w + nj * sigma.b |
| 2002 | 168x |
if (length(between.idx) > 0L) {
|
| 2003 | ! |
omega.j <- rbind( |
| 2004 | ! |
cbind(sigma.zz, t(sigma.yz)), |
| 2005 | ! |
cbind(sigma.yz, 1 / nj * sigma.j) |
| 2006 |
) |
|
| 2007 |
} else {
|
|
| 2008 | 168x |
omega.j <- 1 / nj * sigma.j |
| 2009 |
} |
|
| 2010 | 168x |
omega.j.inv <- solve(omega.j) |
| 2011 | 168x |
sigma.1.j.inv <- sigma.1 %*% omega.j.inv |
| 2012 | ||
| 2013 |
# E(v|y) |
|
| 2014 | 168x |
b.jc <- t(t(b.j) - mu) |
| 2015 | 168x |
tmp <- b.jc %*% t(sigma.1.j.inv) |
| 2016 | 168x |
Ev <- t(t(tmp) + mu.b) |
| 2017 | ||
| 2018 |
# Cov(v|y) |
|
| 2019 | 168x |
Covv <- n.s[clz] * (sigma.b - (sigma.1.j.inv %*% t(sigma.1))) |
| 2020 | ||
| 2021 |
# force symmetry |
|
| 2022 | 168x |
Covv <- (Covv + t(Covv)) / 2 |
| 2023 | ||
| 2024 |
# E(vv|y) = Cov(v|y) + E(v|y)E(v|y)^T |
|
| 2025 | 168x |
Evv <- Covv + crossprod(Ev) |
| 2026 | ||
| 2027 |
# store for this cluster SIZE |
|
| 2028 | 168x |
MW.s[clz, ] <- nj * colSums(ybar.j - Ev) |
| 2029 | 168x |
MB.s[clz, ] <- colSums(Ev) |
| 2030 | 168x |
CW2.s <- CW2.s + nj * (Evv - crossprod(ybar.j, Ev) |
| 2031 | 168x |
- crossprod(Ev, ybar.j)) |
| 2032 | 168x |
CB.s <- CB.s + Evv |
| 2033 | ||
| 2034 |
# between only |
|
| 2035 | 168x |
if (length(between.idx) > 0L) {
|
| 2036 | ! |
ZY.s <- ZY.s + crossprod(Y2[cluster.size == nj, between.idx, |
| 2037 | ! |
drop = FALSE |
| 2038 | ! |
], Ev) |
| 2039 |
} |
|
| 2040 |
} # cluster-sizes |
|
| 2041 | ||
| 2042 | 84x |
M.ws <- 1 / nobs * colSums(MW.s) |
| 2043 | 84x |
M.bs <- 1 / nclusters * colSums(MB.s) |
| 2044 | 84x |
C.bs <- 1 / nclusters * CB.s |
| 2045 | 84x |
C.ws <- 1 / nobs * (Y1Y1 + CW2.s) |
| 2046 | ||
| 2047 |
# between only |
|
| 2048 | 84x |
if (length(between.idx) > 0L) {
|
| 2049 | ! |
As <- 1 / nclusters * ZY.s - tcrossprod(mu.z, M.bs) |
| 2050 |
} |
|
| 2051 | ||
| 2052 | 84x |
sigma.w <- C.ws - tcrossprod(M.ws) |
| 2053 | 84x |
sigma.b <- C.bs - tcrossprod(M.bs) |
| 2054 | 84x |
mu.w <- M.ws |
| 2055 | 84x |
mu.b <- M.bs |
| 2056 | 84x |
if (length(between.idx) > 0L) {
|
| 2057 | ! |
sigma.yz <- t(As) |
| 2058 |
} |
|
| 2059 | ||
| 2060 | 84x |
list( |
| 2061 | 84x |
sigma.w = sigma.w, sigma.b = sigma.b, mu.w = mu.w, mu.b = mu.b, |
| 2062 | 84x |
sigma.yz = sigma.yz, sigma.zz = sigma.zz, mu.z = mu.z |
| 2063 |
) |
|
| 2064 |
} |
| 1 |
# print 'blocks' of test statistics |
|
| 2 |
# - blocks with 'scaling.factors' come first (in 'two columns') |
|
| 3 |
# - then come the 'single-column' test statistics (eg browne.residual.adf) |
|
| 4 |
# - print additional informatiation (eg information matrix, h1.information, ...) |
|
| 5 |
# if they deviate from what is used for the standard errors |
|
| 6 | ||
| 7 |
# this is used by the summary() function and lavTest(, output = "text") |
|
| 8 | ||
| 9 |
# YR 13 Feb 2026: if test[[1]] has stat = NA, skip if there are other tests |
|
| 10 | ||
| 11 |
lav_test_print <- function(object, nd = 3L) {
|
|
| 12 |
# object is list of tests |
|
| 13 | 20x |
TEST <- object |
| 14 | ||
| 15 |
# empty list? |
|
| 16 | 20x |
if (is.null(TEST) || length(TEST) == 0L || !is.list(TEST)) {
|
| 17 | ! |
return(character(0L)) |
| 18 |
} |
|
| 19 | ||
| 20 |
# test = "none"? |
|
| 21 | 20x |
if (TEST[[1]]$test == "none") {
|
| 22 | ! |
return(character(0L)) |
| 23 |
} |
|
| 24 | ||
| 25 |
# remove empty first test (stat = NA) if multiple tests are available) |
|
| 26 | 20x |
if (length(TEST) > 1L && is.na(TEST[[1]]$stat)) {
|
| 27 | ! |
TEST <- TEST[-1] |
| 28 |
} |
|
| 29 | ||
| 30 |
# meta data |
|
| 31 | 20x |
info <- attr(object, "info") |
| 32 | 20x |
ngroups <- info$ngroups |
| 33 | 20x |
group.label <- info$group.label |
| 34 | 20x |
information <- info$information |
| 35 | 20x |
h1.information <- info$h1.information |
| 36 | 20x |
observed.information <- info$observed.information |
| 37 | ||
| 38 |
# num format |
|
| 39 | 20x |
num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")
|
| 40 | ||
| 41 |
# header |
|
| 42 | 20x |
cat("Model Test User Model:\n")
|
| 43 | ||
| 44 |
# locate 'robust' tests (here: having a scaling factor) |
|
| 45 | 20x |
has.no.scaling <- unname(sapply( |
| 46 | 20x |
(lapply(TEST, "[[", "scaling.factor")), |
| 47 | 20x |
is.null |
| 48 |
)) |
|
| 49 | 20x |
robust.idx <- which(!has.no.scaling) |
| 50 | 20x |
non.robust.idx <- which(has.no.scaling) |
| 51 | 20x |
scaled.idx <- 1L |
| 52 | 20x |
if (length(robust.idx) > 0L) {
|
| 53 | 2x |
scaled.idx <- which(names(TEST) == TEST[[robust.idx[1]]]$scaled.test) |
| 54 | 2x |
if (length(scaled.idx) == 0L) {
|
| 55 | 1x |
scaled.idx <- 1L |
| 56 |
} |
|
| 57 |
# remove 'scaled.test', because it is shown together with robust |
|
| 58 | 2x |
non.robust.idx <- non.robust.idx[-scaled.idx] |
| 59 |
} |
|
| 60 | 20x |
BLOCKS <- c(robust.idx, non.robust.idx) |
| 61 | 20x |
nBlocks <- length(BLOCKS) |
| 62 | ||
| 63 |
# print out blocks |
|
| 64 | 20x |
for (block in BLOCKS) {
|
| 65 |
# one or two-columns for this block? |
|
| 66 | 20x |
if (length(robust.idx) > 0L && block %in% robust.idx) {
|
| 67 | 2x |
twocolumn <- TRUE |
| 68 |
} else {
|
|
| 69 | 18x |
twocolumn <- FALSE |
| 70 |
} |
|
| 71 | ||
| 72 | 20x |
if (!twocolumn) {
|
| 73 |
# print label |
|
| 74 | 18x |
c1 <- c2 <- c3 <- character(0L) |
| 75 | 18x |
if (!is.null(TEST[[block]]$label)) {
|
| 76 | ! |
c1 <- c(c1, TEST[[block]]$label) |
| 77 | ! |
c2 <- c(c2, "") |
| 78 | ! |
c3 <- c(c3, "") |
| 79 |
} |
|
| 80 | 18x |
if (is.na(TEST[[block]]$df) || TEST[[block]]$df == 0L) {
|
| 81 | 6x |
c1 <- c(c1, c("Test statistic", "Degrees of freedom"))
|
| 82 | 6x |
c2 <- c(c2, c( |
| 83 | 6x |
sprintf(num.format, TEST[[block]]$stat), |
| 84 | 6x |
ifelse(TEST[[block]]$df %% 1 == 0, # integer |
| 85 | 6x |
TEST[[block]]$df, |
| 86 | 6x |
sprintf(num.format, TEST[[block]]$df) |
| 87 |
) |
|
| 88 |
)) |
|
| 89 | 6x |
c3 <- c(c3, c("", ""))
|
| 90 |
} else {
|
|
| 91 | 12x |
PLABEL <- "P-value" |
| 92 | 12x |
if (!is.null(TEST[[block]]$refdistr)) {
|
| 93 | 12x |
if (TEST[[block]]$refdistr == "chisq") {
|
| 94 | 12x |
PLABEL <- "P-value (Chi-square)" |
| 95 | ! |
} else if (TEST[[block]]$refdistr == "unknown") {
|
| 96 | ! |
PLABEL <- "P-value (Unknown)" |
| 97 | ! |
} else if (TEST[[block]]$refdistr == "bootstrap") {
|
| 98 | ! |
PLABEL <- "P-value (Bollen-Stine bootstrap)" |
| 99 |
} |
|
| 100 |
} |
|
| 101 | 12x |
c1 <- c(c1, c("Test statistic", "Degrees of freedom", PLABEL))
|
| 102 | 12x |
c2 <- c(c2, c( |
| 103 | 12x |
sprintf(num.format, TEST[[block]]$stat), |
| 104 | 12x |
ifelse(TEST[[block]]$df %% 1 == 0, # integer |
| 105 | 12x |
TEST[[block]]$df, |
| 106 | 12x |
sprintf(num.format, TEST[[block]]$df) |
| 107 |
), |
|
| 108 | 12x |
sprintf(num.format, TEST[[block]]$pvalue) |
| 109 |
)) |
|
| 110 | 12x |
c3 <- c(c3, c("", "", ""))
|
| 111 |
} |
|
| 112 | ||
| 113 |
# two-column |
|
| 114 |
} else {
|
|
| 115 |
# print label |
|
| 116 | 2x |
c1 <- c2 <- c3 <- character(0L) |
| 117 | 2x |
if (!is.null(TEST[[scaled.idx]]$label)) {
|
| 118 | ! |
c1 <- c(c1, TEST[[scaled.idx]]$label) |
| 119 | ! |
c2 <- c(c2, "") |
| 120 | ! |
c3 <- c(c3, "") |
| 121 |
} |
|
| 122 | 2x |
if (is.na(TEST[[block]]$df) || TEST[[block]]$df == 0L) {
|
| 123 | 1x |
c1 <- c(c1, c("Test Statistic", "Degrees of freedom"))
|
| 124 | 1x |
c2 <- c( |
| 125 | 1x |
c2, |
| 126 | 1x |
c( |
| 127 | 1x |
sprintf(num.format, TEST[[scaled.idx]]$stat), |
| 128 | 1x |
ifelse(TEST[[scaled.idx]]$df %% 1 == 0, # integer |
| 129 | 1x |
TEST[[scaled.idx]]$df, |
| 130 | 1x |
sprintf(num.format, TEST[[scaled.idx]]$df) |
| 131 |
) |
|
| 132 |
) |
|
| 133 |
) |
|
| 134 | 1x |
c3 <- c( |
| 135 | 1x |
c3, |
| 136 | 1x |
c( |
| 137 | 1x |
sprintf(num.format, TEST[[block]]$stat), |
| 138 | 1x |
ifelse(TEST[[block]]$df %% 1 == 0, # integer |
| 139 | 1x |
TEST[[block]]$df, |
| 140 | 1x |
sprintf(num.format, TEST[[block]]$df) |
| 141 |
) |
|
| 142 |
) |
|
| 143 |
) |
|
| 144 |
} else {
|
|
| 145 | 1x |
if (!is.null(TEST[[scaled.idx]]$refdistr)) {
|
| 146 | 1x |
if (TEST[[scaled.idx]]$refdistr == "chisq") {
|
| 147 | ! |
PLABEL <- "P-value (Chi-square)" |
| 148 | 1x |
} else if (TEST[[scaled.idx]]$refdistr == "unknown") {
|
| 149 | 1x |
PLABEL <- "P-value (Unknown)" |
| 150 |
} else {
|
|
| 151 | ! |
PLABEL <- "P-value" |
| 152 |
} |
|
| 153 |
} |
|
| 154 | 1x |
c1 <- c(c1, c( |
| 155 | 1x |
"Test Statistic", "Degrees of freedom", PLABEL, |
| 156 | 1x |
"Scaling correction factor" |
| 157 |
)) |
|
| 158 | 1x |
c2 <- c( |
| 159 | 1x |
c2, |
| 160 | 1x |
c( |
| 161 | 1x |
sprintf(num.format, TEST[[scaled.idx]]$stat), |
| 162 | 1x |
ifelse(TEST[[scaled.idx]]$df %% 1 == 0, # integer |
| 163 | 1x |
TEST[[scaled.idx]]$df, |
| 164 | 1x |
sprintf(num.format, TEST[[scaled.idx]]$df) |
| 165 |
), |
|
| 166 | 1x |
sprintf(num.format, TEST[[scaled.idx]]$pvalue), "" |
| 167 |
) |
|
| 168 |
) |
|
| 169 | 1x |
c3 <- c( |
| 170 | 1x |
c3, |
| 171 | 1x |
c( |
| 172 | 1x |
sprintf(num.format, TEST[[block]]$stat), |
| 173 | 1x |
ifelse(TEST[[block]]$df %% 1 == 0, # integer |
| 174 | 1x |
TEST[[block]]$df, |
| 175 | 1x |
sprintf(num.format, TEST[[block]]$df) |
| 176 |
), |
|
| 177 | 1x |
sprintf(num.format, TEST[[block]]$pvalue), |
| 178 | 1x |
sprintf(num.format, TEST[[block]]$scaling.factor) |
| 179 |
) |
|
| 180 |
) |
|
| 181 | ||
| 182 | 1x |
if (TEST[[block]]$test == "scaled.shifted") {
|
| 183 | 1x |
if (ngroups == 1L || |
| 184 | 1x |
length(TEST[[block]]$shift.parameter) == 1L) {
|
| 185 | 1x |
c1 <- c(c1, "Shift parameter") |
| 186 | 1x |
c2 <- c(c2, "") |
| 187 | 1x |
c3 <- c( |
| 188 | 1x |
c3, |
| 189 | 1x |
sprintf(num.format, TEST[[block]]$shift.parameter) |
| 190 |
) |
|
| 191 |
} else {
|
|
| 192 | ! |
c1 <- c(c1, "Shift parameter for each group:") |
| 193 | ! |
c2 <- c(c2, "") |
| 194 | ! |
c3 <- c(c3, "") |
| 195 | ! |
for (g in 1:ngroups) {
|
| 196 | ! |
c1 <- c(c1, sprintf(" %-38s", group.label[[g]]))
|
| 197 | ! |
c2 <- c(c2, "") |
| 198 | ! |
c3 <- c(c3, sprintf( |
| 199 | ! |
num.format, |
| 200 | ! |
TEST[[block]]$shift.parameter[g] |
| 201 |
)) |
|
| 202 |
} |
|
| 203 |
} |
|
| 204 |
} # shift |
|
| 205 | ||
| 206 |
# which correction factor? |
|
| 207 | 1x |
c1 <- c(c1, paste(" ", TEST[[block]]$label, sep = ""))
|
| 208 | 1x |
c2 <- c(c2, "") |
| 209 | 1x |
c3 <- c(c3, "") |
| 210 |
} |
|
| 211 |
} |
|
| 212 | ||
| 213 |
# if twocolumn, label first row |
|
| 214 | 20x |
if (twocolumn && block == BLOCKS[1]) {
|
| 215 | 2x |
c1 <- c("", c1)
|
| 216 | 2x |
c2 <- c("Standard", c2)
|
| 217 | 2x |
c3 <- c("Scaled", c3)
|
| 218 |
} else {
|
|
| 219 |
# empty row |
|
| 220 | 18x |
c1 <- c("", c1)
|
| 221 | 18x |
c2 <- c("", c2)
|
| 222 | 18x |
c3 <- c("", c3)
|
| 223 |
} |
|
| 224 | ||
| 225 |
# if information type is different from 'se', print it |
|
| 226 | 20x |
if (length(information) > 1L && |
| 227 | 20x |
information[1] != information[2]) {
|
| 228 | ! |
c1 <- c(c1, "Information") |
| 229 | ! |
tmp.txt <- information[2] |
| 230 | ! |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 231 | ! |
substring(tmp.txt, 2), |
| 232 | ! |
sep = "" |
| 233 |
)) |
|
| 234 | ! |
c3 <- c(c3, "") |
| 235 |
} |
|
| 236 |
# if h1.information type is different from 'se', print it |
|
| 237 | 20x |
if (length(h1.information) > 1L && |
| 238 | 20x |
h1.information[1] != h1.information[2]) {
|
| 239 | ! |
c1 <- c(c1, "Information saturated (h1) model") |
| 240 | ! |
tmp.txt <- h1.information[2] |
| 241 | ! |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 242 | ! |
substring(tmp.txt, 2), |
| 243 | ! |
sep = "" |
| 244 |
)) |
|
| 245 | ! |
c3 <- c(c3, "") |
| 246 |
} |
|
| 247 |
# if observed.information type is different from 'se', print it |
|
| 248 | 20x |
if (length(observed.information) > 1L && |
| 249 | 20x |
information[2] == "observed" && |
| 250 | 20x |
(observed.information[1] != |
| 251 | 20x |
observed.information[2])) {
|
| 252 | ! |
c1 <- c(c1, "Observed information based on") |
| 253 | ! |
tmp.txt <- observed.information[2] |
| 254 | ! |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 255 | ! |
substring(tmp.txt, 2), |
| 256 | ! |
sep = "" |
| 257 |
)) |
|
| 258 | ! |
c3 <- c(c3, "") |
| 259 |
} |
|
| 260 | ||
| 261 | ||
| 262 |
# format c1/c2/c3 (note: fitMeasures uses 35/16/8) |
|
| 263 | 20x |
c1 <- format(c1, width = 43L) |
| 264 | 20x |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 265 | 20x |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 266 | ||
| 267 |
# create character matrix |
|
| 268 | 20x |
if (twocolumn) {
|
| 269 | 2x |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 270 |
} else {
|
|
| 271 | 18x |
M <- cbind(c1, c2, deparse.level = 0) |
| 272 |
} |
|
| 273 | 20x |
colnames(M) <- rep("", ncol(M))
|
| 274 | 20x |
rownames(M) <- rep(" ", nrow(M))
|
| 275 | ||
| 276 |
|
|
| 277 | 20x |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 278 | ||
| 279 |
# multiple groups? |
|
| 280 | 20x |
ngroups <- ngroups |
| 281 | 20x |
if (ngroups > 1L && !is.null(TEST[[block]]$stat.group)) {
|
| 282 | 2x |
c1 <- c2 <- c3 <- character(ngroups) |
| 283 | 2x |
for (g in 1:ngroups) {
|
| 284 | 4x |
tmp <- sprintf(" %-40s", group.label[[g]])
|
| 285 | 4x |
c1[g] <- format(tmp, width = 43L) |
| 286 | 4x |
if (!twocolumn) {
|
| 287 | 4x |
tmp <- sprintf(num.format, TEST[[block]]$stat.group[g]) |
| 288 | 4x |
c2[g] <- format(tmp, |
| 289 | 4x |
width = 8L + max(0, (nd - 3L)) * 4L, |
| 290 | 4x |
justify = "right" |
| 291 |
) |
|
| 292 |
} else {
|
|
| 293 | ! |
tmp <- sprintf(num.format, TEST[[block]]$stat.group[g]) |
| 294 | ! |
c2[g] <- format(tmp, |
| 295 | ! |
width = 8L + max(0, (nd - 3L)) * 4L, |
| 296 | ! |
justify = "right" |
| 297 |
) |
|
| 298 | ! |
tmp <- sprintf(num.format, TEST[[block]]$stat.group[g]) |
| 299 | ! |
c3[g] <- format(tmp, width = 8L + nd, justify = "right") |
| 300 |
} |
|
| 301 |
} |
|
| 302 | 2x |
if (twocolumn) {
|
| 303 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 304 |
} else {
|
|
| 305 | 2x |
M <- cbind(c1, c2, deparse.level = 0) |
| 306 |
} |
|
| 307 | 2x |
colnames(M) <- rep("", ncol(M))
|
| 308 | 2x |
rownames(M) <- rep(" ", nrow(M))
|
| 309 | 2x |
cat(" Test statistic for each group:\n")
|
| 310 | 2x |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 311 |
} |
|
| 312 |
} # blocks |
|
| 313 | ||
| 314 |
# invisible(M) |
|
| 315 |
} |
| 1 |
lav_lavaan_step04_partable <- function(slotParTable = NULL, # nolint |
|
| 2 |
model = NULL, |
|
| 3 |
flat.model = NULL, |
|
| 4 |
lavoptions = NULL, |
|
| 5 |
lavdata = NULL, |
|
| 6 |
constraints = NULL) {
|
|
| 7 |
# # # # # # # # # # # # |
|
| 8 |
# # 4. lavpartable # # |
|
| 9 |
# # # # # # # # # # # # |
|
| 10 | ||
| 11 |
# if slotParTable not null |
|
| 12 |
# copy slotParTable to lavpartable |
|
| 13 |
# else |
|
| 14 |
# if model is character or formula |
|
| 15 |
# create a temporary variable tmp.data.ov equal to lavdata@ov |
|
| 16 |
# if estimator "catML" |
|
| 17 |
# set meanstructure to FALSE |
|
| 18 |
# set the member type in the temporary variable tmp.data.ov to a |
|
| 19 |
# numeric vector with all zeroes |
|
| 20 |
# create lavpartable via function lavParTable (=lav_model_partable) |
|
| 21 |
# using the temporary variable for parameter varTable |
|
| 22 |
# else |
|
| 23 |
# if model is lavaan object |
|
| 24 |
# set lavpartable = parTable(model) |
|
| 25 |
# else |
|
| 26 |
# if model is a list |
|
| 27 |
# set lavpartable to |
|
| 28 |
# as.list(lav_partable_complete(as.list(flat.model))) |
|
| 29 |
# else |
|
| 30 |
# *** error *** |
|
| 31 |
# if slotParTable is NULL check lavpartable via lav_partable_check |
|
| 32 |
# if lavoptions$optim.method is "em" and there are variances specified in |
|
| 33 |
# partable with free = 0L and |
|
| 34 |
# starting value ustart 0, set ustart for these variances to |
|
| 35 |
# lavoptions$em.zerovar.offset |
|
| 36 | ||
| 37 | 140x |
if (!is.null(slotParTable)) {
|
| 38 | ! |
lavpartable <- lav_partable_set_cache(slotParTable) |
| 39 | 140x |
} else if (is.character(model) || |
| 40 | 140x |
inherits(model, "formula") || |
| 41 |
# model was already a flat.model |
|
| 42 | 140x |
(is.list(model) && !is.null(model$mod.idx) && |
| 43 | 140x |
!is.null(attr(model, "modifiers")))) {
|
| 44 | 47x |
if (lav_verbose()) {
|
| 45 | ! |
cat("lavpartable ...")
|
| 46 |
} |
|
| 47 |
# check flat.model before we proceed |
|
| 48 | 47x |
if (lav_debug()) {
|
| 49 | ! |
print(as.data.frame(flat.model)) |
| 50 |
} |
|
| 51 |
# catch ~~ of fixed.x covariates if fixed.x = TRUE |
|
| 52 |
# --> done inside lav_model_partable! |
|
| 53 | ||
| 54 |
# if(lavoptions$fixed.x) {
|
|
| 55 |
# tmp <- lav_partable_vnames(flat.model, type = "ov.x", |
|
| 56 |
# ov.x.fatal = FALSE, warn = TRUE) |
|
| 57 |
# tmp <- try(lav_partable_vnames(flat.model, type = "ov.x", |
|
| 58 |
# ov.x.fatal = TRUE), |
|
| 59 |
# silent = TRUE) |
|
| 60 |
# if(inherits(tmp, "try-error")) {
|
|
| 61 |
# warning("lavaan WARNING: syntax contains parameters involving ",
|
|
| 62 |
# "exogenous covariates; switching to fixed.x = FALSE") |
|
| 63 |
# lavoptions$fixed.x <- FALSE |
|
| 64 |
# } |
|
| 65 |
# } |
|
| 66 |
# if(lavoptions$conditional.x) {
|
|
| 67 |
# tmp <- lav_partable_vnames(flat.model, type = "ov.x", ov.x.fatal = TRUE) |
|
| 68 |
# } |
|
| 69 | 47x |
tmp.data.ov <- lavdata@ov |
| 70 | 47x |
if (lavoptions$estimator == "catML") {
|
| 71 | ! |
lavoptions$meanstructure <- FALSE |
| 72 | ! |
tmp.data.ov$type <- rep("numeric", length(tmp.data.ov$type))
|
| 73 |
} |
|
| 74 | 47x |
lavpartable <- |
| 75 | 47x |
lavParTable( |
| 76 | 47x |
model = flat.model, |
| 77 | 47x |
constraints = constraints, |
| 78 | 47x |
varTable = tmp.data.ov, |
| 79 | 47x |
ngroups = lavdata@ngroups, |
| 80 | 47x |
meanstructure = lavoptions$meanstructure, |
| 81 | 47x |
int.ov.free = lavoptions$int.ov.free, |
| 82 | 47x |
int.lv.free = lavoptions$int.lv.free, |
| 83 | 47x |
marker.int.zero = lavoptions$marker.int.zero, |
| 84 | 47x |
orthogonal = lavoptions$orthogonal, |
| 85 | 47x |
orthogonal.x = lavoptions$orthogonal.x, |
| 86 | 47x |
orthogonal.y = lavoptions$orthogonal.y, |
| 87 | 47x |
orthogonal.efa = lavoptions$rotation.args$orthogonal, |
| 88 | 47x |
conditional.x = lavoptions$conditional.x, |
| 89 | 47x |
fixed.x = lavoptions$fixed.x, |
| 90 | 47x |
std.lv = lavoptions$std.lv, |
| 91 | 47x |
correlation = lavoptions$correlation, |
| 92 | 47x |
composites = lavoptions$composites, |
| 93 | 47x |
effect.coding = lavoptions$effect.coding, |
| 94 | 47x |
ceq.simple = lavoptions$ceq.simple, |
| 95 | 47x |
parameterization = lavoptions$parameterization, |
| 96 | 47x |
auto.fix.first = lavoptions$auto.fix.first, |
| 97 | 47x |
auto.fix.single = lavoptions$auto.fix.single, |
| 98 | 47x |
auto.var = lavoptions$auto.var, |
| 99 | 47x |
auto.cov.lv.x = lavoptions$auto.cov.lv.x, |
| 100 | 47x |
auto.cov.y = lavoptions$auto.cov.y, |
| 101 | 47x |
auto.th = lavoptions$auto.th, |
| 102 | 47x |
auto.delta = lavoptions$auto.delta, |
| 103 | 47x |
auto.efa = lavoptions$auto.efa, |
| 104 | 47x |
group.equal = lavoptions$group.equal, |
| 105 | 47x |
group.partial = lavoptions$group.partial, |
| 106 | 47x |
group.w.free = lavoptions$group.w.free, |
| 107 | 47x |
as.data.frame. = FALSE |
| 108 |
) |
|
| 109 | 47x |
lavpartable <- lav_partable_set_cache(lavpartable) |
| 110 | 47x |
if (lav_verbose()) {
|
| 111 | ! |
cat(" done.\n")
|
| 112 |
} |
|
| 113 | 93x |
} else if (inherits(model, "lavaan")) {
|
| 114 | ! |
lavpartable <- lav_partable_set_cache(as.list(parTable(model)), model@pta) |
| 115 | 93x |
} else if (is.list(model)) {
|
| 116 |
# we already checked this when creating flat.model |
|
| 117 |
# but we may need to complete it |
|
| 118 | 93x |
lavpartable <- as.list(flat.model) # in case model is a data.frame |
| 119 |
# complete table |
|
| 120 | 93x |
lavpartable <- as.list(lav_partable_complete(lavpartable)) |
| 121 | 93x |
lavpartable <- lav_partable_set_cache(lavpartable) |
| 122 |
} else {
|
|
| 123 | ! |
lav_msg_stop(gettextf( |
| 124 | ! |
"model [type = %s] is not of type character or list", class(model))) |
| 125 |
} |
|
| 126 | 140x |
if (lav_debug()) {
|
| 127 | ! |
print(as.data.frame(lavpartable)) |
| 128 |
} |
|
| 129 | ||
| 130 |
# at this point, we should check if the partable is complete |
|
| 131 |
# or not; this is especially relevant if the lavaan() function |
|
| 132 |
# was used, but the user has forgotten some variances/intercepts... |
|
| 133 | 140x |
if (is.null(slotParTable)) {
|
| 134 | 140x |
junk <- lav_partable_check(lavpartable, |
| 135 | 140x |
categorical = lavoptions$.categorical |
| 136 |
) |
|
| 137 | 140x |
rm(junk) |
| 138 |
} |
|
| 139 | ||
| 140 |
# for EM only (for now), force fixed-to-zero (residual) variances |
|
| 141 |
# to be slightly larger than zero |
|
| 142 | 140x |
if (lavoptions$optim.method == "em") {
|
| 143 | ! |
zero.var.idx <- which(lavpartable$op == "~~" & |
| 144 | ! |
lavpartable$lhs == lavpartable$rhs & |
| 145 | ! |
lavpartable$free == 0L & |
| 146 | ! |
lavpartable$ustart == 0) |
| 147 | ! |
if (length(zero.var.idx) > 0L) {
|
| 148 | ! |
lavpartable$ustart[zero.var.idx] <- lavoptions$em.zerovar.offset |
| 149 |
} |
|
| 150 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, NULL, force = TRUE) |
| 151 |
} |
|
| 152 | ||
| 153 | 140x |
list( |
| 154 | 140x |
lavoptions = lavoptions, |
| 155 | 140x |
lavpartable = lavpartable |
| 156 |
) |
|
| 157 |
} |
| 1 |
# initial version YR 02/08/2010 |
|
| 2 | ||
| 3 |
# YR 28 Jan 2017: add lavOptions(), lav_options_default() |
|
| 4 |
# LDW 16 Apr 2024: move lavOptions and lav_options_default to separate file |
|
| 5 | ||
| 6 |
# help functions for lav_options_set #### |
|
| 7 |
# help function to determine estimator 'group' |
|
| 8 |
lav_options_estimatorgroup <- function(estimator) {
|
|
| 9 | 388x |
goal <- switch(estimator, |
| 10 | 388x |
ml = , |
| 11 | 388x |
mlf = , |
| 12 | 388x |
mlm = , |
| 13 | 388x |
mlmv = , |
| 14 | 388x |
mlmvs = , |
| 15 | 388x |
mlr = "ML", |
| 16 | 388x |
catml = "catML", |
| 17 | 388x |
dwls = , |
| 18 | 388x |
wlsm = , |
| 19 | 388x |
wlsmv = , |
| 20 | 388x |
wlsmvs = "DWLS", |
| 21 | 388x |
uls = , |
| 22 | 388x |
ulsm = , |
| 23 | 388x |
ulsmv = , |
| 24 | 388x |
ulsmvs = "ULS", |
| 25 | 388x |
none = "none", |
| 26 | 388x |
toupper(estimator) |
| 27 |
) |
|
| 28 | 388x |
goal |
| 29 |
} |
|
| 30 |
lav_options_checkinterval <- function(x, nm, num2int) {
|
|
| 31 | 474x |
if (num2int) x <- as.integer(x) |
| 32 | 1975x |
oks <- vapply(x, function(x1) {
|
| 33 | 2054x |
(x1 > nm$bounds[1] || (x1 == nm$bounds[1] && nm$first.in)) && |
| 34 | 2054x |
(x1 < nm$bounds[2] || (x1 == nm$bounds[2] && nm$last.in)) |
| 35 | 1975x |
}, TRUE) |
| 36 | 1975x |
all(oks) |
| 37 |
} |
|
| 38 |
lav_options_checkvalues <- function(optname, optvalue, chr) {
|
|
| 39 | 3665x |
optvalid <- names(chr) |
| 40 | ! |
if (is.null(optvalid)) optvalid <- chr |
| 41 | 3665x |
if (any(optvalid == "empty.string")) {
|
| 42 | ! |
optvalid[optvalid == "empty.string"] <- "" |
| 43 |
} |
|
| 44 | 3665x |
optvals <- gsub("[_-]", ".", tolower(optvalue))
|
| 45 | 3665x |
optvalsok <- match(optvals, optvalid) |
| 46 | 3665x |
if (any(is.na(optvalsok))) {
|
| 47 | ! |
lav_msg_stop(sprintf( |
| 48 | ! |
ngettext( |
| 49 | ! |
length(optvalue[is.na(optvalsok)]), |
| 50 | ! |
"invalid value in %1$s option: %2$s.", |
| 51 | ! |
"invalid values in %1$s option: %2$s." |
| 52 |
), |
|
| 53 | ! |
optname, |
| 54 | ! |
lav_msg_view(optvalue[is.na(optvalsok)], log.sep = "none") |
| 55 |
)) |
|
| 56 |
} |
|
| 57 | 3665x |
as.vector(chr[optvalsok]) |
| 58 |
} |
|
| 59 |
lav_options_check <- function(opts, opt.check, subname) { # nolint
|
|
| 60 | 158x |
opt.names <- names(opts) |
| 61 | 158x |
hiddens <- startsWith(opt.names, ".") |
| 62 | 158x |
if (any(hiddens)) { # remove hidden options temporarily
|
| 63 | 79x |
opts.hidden <- opts[hiddens] |
| 64 | 79x |
opts <- opts[!hiddens] |
| 65 | 79x |
opt.names <- opt.names[!hiddens] |
| 66 |
} |
|
| 67 | 158x |
check.names <- names(opt.check) |
| 68 | 158x |
match.opt <- match(opt.names, check.names) |
| 69 | 158x |
if (any(is.na(match.opt))) {
|
| 70 | ! |
lav_msg_stop(gettextf( |
| 71 | ! |
"Some option(s) unknown: %s !", |
| 72 | ! |
lav_msg_view(opt.names[is.na(match.opt)], log.sep = "none") |
| 73 |
)) |
|
| 74 |
} |
|
| 75 | 158x |
for (j in seq_along(opts)) {
|
| 76 | 11534x |
opt.name <- opt.names[j] |
| 77 | 11534x |
opt.value <- opts[[j]] |
| 78 | 11534x |
opt.check1 <- opt.check[[match.opt[j]]] |
| 79 | 11534x |
if (!is.null(attr(opt.check1, "SUB"))) {
|
| 80 | 79x |
opts[[j]] <- lav_options_check( |
| 81 | 79x |
opt.value, opt.check1, |
| 82 | 79x |
paste0(opt.name, "$") |
| 83 |
) |
|
| 84 | 79x |
next |
| 85 |
} |
|
| 86 |
# check length of option value |
|
| 87 | 11455x |
if (length(opt.value) < opt.check1$oklen[1]) {
|
| 88 | ! |
lav_msg_stop(gettextf( |
| 89 | ! |
"Length of option '%1$s' value must be at least %2$s.", |
| 90 | ! |
paste0(subname, opt.name), opt.check1$oklen[1] |
| 91 |
)) |
|
| 92 |
} |
|
| 93 | 11455x |
if (length(opt.value) > abs(opt.check1$oklen[2])) {
|
| 94 | ! |
if (opt.check1$oklen[2] > 0L) {
|
| 95 | ! |
lav_msg_stop(gettextf( |
| 96 | ! |
"Length of option '%1$s' value must be maximum %2$s.", |
| 97 | ! |
paste0(subname, opt.name), opt.check1$oklen[2] |
| 98 |
)) |
|
| 99 |
} else {
|
|
| 100 | ! |
lav_msg_warn(gettextf( |
| 101 | ! |
"Length of option '%1$s' value should be maximum %2$s. |
| 102 | ! |
Only first %3$s elements used.", |
| 103 | ! |
paste0(subname, opt.name), -opt.check1$oklen[2], |
| 104 | ! |
-opt.check1$oklen[2] |
| 105 |
)) |
|
| 106 |
} |
|
| 107 |
} |
|
| 108 | 6162x |
if (is.null(opt.check1$bl)) opt.check1$bl <- FALSE |
| 109 | 11455x |
if (!is.null(opt.check1$chr) || !is.null(opt.check1$nm) || |
| 110 | 11455x |
opt.check1$bl) {
|
| 111 | 10270x |
if (!opt.check1$bl || !is.logical(opt.value)) {
|
| 112 | 5689x |
if (!is.null(opt.check1$nm) && is.numeric(opt.value)) {
|
| 113 | 1975x |
num2int <- FALSE |
| 114 | 474x |
if (!is.null(opt.check1$num2int)) num2int <- opt.check1$num2int |
| 115 | 1975x |
if (!lav_options_checkinterval(opt.value, opt.check1$nm, num2int)) {
|
| 116 | ! |
lav_msg_stop(gettextf( |
| 117 | ! |
"Value(s) of option %1$s out of range (%2$s)!", |
| 118 | ! |
paste0(subname, opt.name), |
| 119 | ! |
paste0( |
| 120 | ! |
opt.check1$nm$bounds[1], |
| 121 | ! |
if (opt.check1$nm$first.in) " <= " else " < ", |
| 122 | ! |
"x", |
| 123 | ! |
if (opt.check1$nm$last.in) " <= " else " < ", |
| 124 | ! |
opt.check1$nm$bounds[2] |
| 125 |
) |
|
| 126 |
)) |
|
| 127 |
} |
|
| 128 |
} |
|
| 129 | 5689x |
if (!is.null(opt.check1$chr) && is.character(opt.value)) {
|
| 130 | 3665x |
opt.value <- lav_options_checkvalues( |
| 131 | 3665x |
opt.name, opt.value, |
| 132 | 3665x |
opt.check1$chr |
| 133 |
) |
|
| 134 | 3665x |
opts[[j]] <- opt.value |
| 135 |
} |
|
| 136 |
} |
|
| 137 |
} |
|
| 138 |
} |
|
| 139 | 158x |
if (any(hiddens)) { # add hidden options
|
| 140 | 79x |
opts <- modifyList(opts, opts.hidden) |
| 141 |
} |
|
| 142 | 158x |
opts |
| 143 |
} |
|
| 144 |
# this function collects and checks the user-provided options/arguments, |
|
| 145 |
# and fills in the "default" values, or changes them in an attempt to |
|
| 146 |
# produce a consistent set of values... |
|
| 147 |
# |
|
| 148 |
# returns a list with the named options |
|
| 149 |
lav_options_set <- function(opt = NULL) {
|
|
| 150 |
# check the presence of necessary hidden options #### |
|
| 151 | 79x |
if (is.null(opt$.categorical) || is.null(opt$.multilevel) || |
| 152 | 79x |
is.null(opt$.clustered)) {
|
| 153 | ! |
lav_msg_fixme( |
| 154 | ! |
".categorical, .multilevel and .clustered must be present" |
| 155 |
) |
|
| 156 |
} |
|
| 157 | ||
| 158 |
# get opt.default and opt.check #### |
|
| 159 | ! |
if (!exists("opt.check", lavaan_cache_env)) lav_options_default()
|
| 160 | 79x |
opt.check <- get("opt.check", lavaan_cache_env)
|
| 161 | ||
| 162 | 79x |
if (lav_debug()) {
|
| 163 | ! |
cat("lavaan DEBUG: lavaanOptions IN\n")
|
| 164 | ! |
str(opt) |
| 165 | ! |
opt$optim.partrace <- TRUE |
| 166 |
} |
|
| 167 | ||
| 168 |
# options OPT for which there also exist OPT.args and opt$OPT is a list |
|
| 169 |
# -> split in opt$OPT and opt$OPT.args |
|
| 170 | 79x |
welke <- which(paste0(names(opt.check), ".args") %in% names(opt.check)) |
| 171 | 79x |
for (j in welke) {
|
| 172 | 158x |
optname <- names(opt.check)[j] |
| 173 | 158x |
optname.args <- paste0(optname, ".args") |
| 174 | 158x |
if (is.list(opt[[optname]])) {
|
| 175 | ! |
if (optname == "bootstrap" && !is.null(opt[[optname]][["R"]])) {
|
| 176 |
# special case for bootstrap, instead of "bootstrap" replications |
|
| 177 |
# argument can be "R" |
|
| 178 | ! |
opt[[optname]][[optname]] <- opt[[optname]][["R"]] |
| 179 | ! |
opt[[optname]][["R"]] <- NULL |
| 180 |
} |
|
| 181 | ! |
opt[[optname.args]] <- opt[[optname]] |
| 182 | ! |
opt[[optname.args]][[optname]] <- NULL |
| 183 | ! |
opt[[optname]] <- opt[[optname]][[optname]] |
| 184 |
} |
|
| 185 |
} |
|
| 186 | ||
| 187 |
# check options with definitions #### |
|
| 188 | 79x |
opt <- lav_options_check(opt, opt.check, "") |
| 189 | ||
| 190 |
# check option 'start' |
|
| 191 | 79x |
if (is.character(opt$start) && all(opt$start != c("default", "simple"))) {
|
| 192 | ! |
lav_msg_stop(gettext( |
| 193 | ! |
"start option must be 'default', 'simple', a fitted object, |
| 194 | ! |
a vector of parameter values, or a parameter table" |
| 195 |
)) |
|
| 196 |
} |
|
| 197 | ||
| 198 |
# first of all: set estimator #### |
|
| 199 | 79x |
if (opt$estimator == "default") {
|
| 200 | 64x |
if (opt$.categorical) {
|
| 201 | 2x |
opt$estimator <- "wlsmv" |
| 202 |
} else {
|
|
| 203 | 62x |
opt$estimator <- "ml" |
| 204 |
} |
|
| 205 |
} |
|
| 206 | ||
| 207 |
# defaults for opt$sample.cov.rescale |
|
| 208 | 79x |
if (opt$sample.cov.rescale == "default") {
|
| 209 | 47x |
opt$sample.cov.rescale <- switch(opt$estimator, |
| 210 | 47x |
dls = TRUE, |
| 211 | 47x |
fabin2 = , |
| 212 | 47x |
fabin3 = , |
| 213 | 47x |
mgm = , |
| 214 | 47x |
js = , |
| 215 | 47x |
jsa = , |
| 216 | 47x |
bentler1982 = TRUE, |
| 217 | 47x |
iv = TRUE, |
| 218 | 47x |
"default" |
| 219 |
) |
|
| 220 |
} |
|
| 221 | ||
| 222 |
# option defaults specific for mimic=... |
|
| 223 | 79x |
opt <- lav_options_mimic(opt) |
| 224 | ||
| 225 |
# store opt$estimator as estimator.orig in upper case |
|
| 226 | 79x |
opt$estimator.orig <- toupper(opt$estimator) |
| 227 | ||
| 228 |
# rename names of test statistics if needed, check for invalid values #### |
|
| 229 | 79x |
opt$test <- lav_test_rename(opt$test, check = TRUE) |
| 230 | ||
| 231 |
# same for standard.test |
|
| 232 | 79x |
opt$standard.test <- lav_test_rename(opt$standard.test, check = TRUE) |
| 233 | ||
| 234 |
# same for scaled.test |
|
| 235 | 79x |
opt$scaled.test <- lav_test_rename(opt$scaled.test, check = TRUE) |
| 236 | ||
| 237 |
# rename names of se values, check illegal combinations se/estimator #### |
|
| 238 |
# pass-through function: may change value of information |
|
| 239 |
# for backwards compatibility (eg if se = "expected") |
|
| 240 | 79x |
opt <- lav_options_check_se(opt) |
| 241 | ||
| 242 |
# do.fit FALSE implies se="none" and test="none" (unless not default) #### |
|
| 243 | 79x |
if (!opt$do.fit) {
|
| 244 | ! |
if (opt$se == "default") opt$se <- "none" |
| 245 | ! |
if (opt$test[1] == "default") opt$test <- "none" |
| 246 |
} |
|
| 247 | ||
| 248 |
# marker.int.fixed #### |
|
| 249 | 79x |
if (opt$marker.int.zero) {
|
| 250 | ! |
opt$meanstructure <- TRUE |
| 251 | ! |
opt$int.ov.free <- TRUE |
| 252 | ! |
if ((is.logical(opt$effect.coding) && opt$effect.coding) || |
| 253 | ! |
(is.character(opt$effect.coding) && nchar(opt$effect.coding) > 0L)) {
|
| 254 | ! |
lav_msg_stop(gettext( |
| 255 | ! |
"effect coding cannot be combined with marker.int.zero = TRUE option" |
| 256 |
)) |
|
| 257 |
} |
|
| 258 | ! |
if (opt$std.lv) {
|
| 259 | ! |
lav_msg_stop(gettext( |
| 260 | ! |
"std.lv = TRUE cannot be combined with marker.int.zero = TRUE" |
| 261 |
)) |
|
| 262 |
} |
|
| 263 |
} |
|
| 264 | ||
| 265 |
# group.equal and group.partial #### |
|
| 266 | 79x |
if (length(opt$group.equal) > 0L && opt$group.equal[1] == "none") {
|
| 267 | ! |
opt$group.equal <- character(0) |
| 268 | 79x |
} else if (is.null(opt$group.equal) || all(nchar(opt$group.equal) == 0L)) {
|
| 269 | 79x |
opt$group.equal <- character(0) |
| 270 |
} |
|
| 271 | ||
| 272 | 79x |
if (is.null(opt$group.partial) || all(nchar(opt$group.partial) == 0L)) {
|
| 273 | 79x |
opt$group.partial <- character(0) |
| 274 | ! |
} else if (length(opt$group.partial) == 0) {
|
| 275 |
# nothing to do |
|
| 276 |
} else {
|
|
| 277 |
# strip white space |
|
| 278 | ! |
opt$group.partial <- gsub("[[:space:]]+", "", opt$group.partial)
|
| 279 |
} |
|
| 280 | ||
| 281 |
# if categorical, and group.equal contains "intercepts", also add |
|
| 282 |
# thresholds (and vice versa) |
|
| 283 |
# not any longer since 0.6-20 |
|
| 284 |
# if (opt$.categorical && any("intercepts" == opt$group.equal)) {
|
|
| 285 |
# opt$group.equal <- unique(c(opt$group.equal, "thresholds")) |
|
| 286 |
# } |
|
| 287 |
# if (opt$.categorical && any("thresholds" == opt$group.equal)) {
|
|
| 288 |
# opt$group.equal <- unique(c(opt$group.equal, "intercepts")) |
|
| 289 |
# } |
|
| 290 | ||
| 291 |
# clustered #### |
|
| 292 |
# brute-force override (for now) |
|
| 293 | 79x |
if (opt$.clustered && !opt$.multilevel) {
|
| 294 | ! |
opt$meanstructure <- TRUE |
| 295 | ||
| 296 | ! |
if (opt$estimator == "mlr") {
|
| 297 | ! |
opt$estimator <- "ml" |
| 298 | ! |
opt$test <- "yuan.bentler.mplus" |
| 299 | ! |
opt$se <- "robust.cluster" |
| 300 | ! |
} else if (opt$estimator == "mlm") {
|
| 301 | ! |
opt$estimator <- "ml" |
| 302 | ! |
opt$test <- "satorra.bentler" |
| 303 | ! |
opt$se <- "robust.cluster.sem" |
| 304 | ! |
} else if (opt$.categorical && opt$estimator != "pml") {
|
| 305 | ! |
opt$test <- "satorra.bentler" |
| 306 | ! |
opt$se <- "robust.cluster.sem" |
| 307 |
} |
|
| 308 | ||
| 309 |
# test #### |
|
| 310 | ! |
if (length(opt$test) == 1L && opt$test == "default") {
|
| 311 | ! |
opt$test <- "yuan.bentler.mplus" |
| 312 | ! |
} else if (all(opt$test %in% c( |
| 313 | ! |
"none", "standard", |
| 314 | ! |
"satorra.bentler", |
| 315 | ! |
"yuan.bentler", "yuan.bentler.mplus" |
| 316 |
))) {
|
|
| 317 |
# nothing to do |
|
| 318 | ! |
} else if (opt$se == "robust") {
|
| 319 | ! |
opt$test <- "yuan.bentler.mplus" |
| 320 |
} else {
|
|
| 321 | ! |
lav_msg_stop( |
| 322 | ! |
gettextf( |
| 323 | ! |
"`test' argument must one of %s in the clustered case", |
| 324 | ! |
lav_msg_view(c( |
| 325 | ! |
"none", "yuan.bentler", "yuan.bentler.mplus", |
| 326 | ! |
"satorra.bentler" |
| 327 | ! |
), log.sep = "or") |
| 328 |
) |
|
| 329 |
) |
|
| 330 |
} |
|
| 331 | ||
| 332 |
# se #### |
|
| 333 | ! |
if (opt$se == "default") {
|
| 334 | ! |
opt$se <- "robust.cluster" |
| 335 | ! |
} else if (any(opt$se == c( |
| 336 | ! |
"none", "robust.cluster", |
| 337 | ! |
"robust.cluster.sem" |
| 338 |
))) {
|
|
| 339 |
# nothing to do |
|
| 340 | ! |
} else if (opt$se == "robust") {
|
| 341 | ! |
opt$se <- "robust.cluster" |
| 342 |
} |
|
| 343 | ||
| 344 |
# information #### |
|
| 345 | ! |
if (opt$information[1] == "default") {
|
| 346 | ! |
if (opt$se == "robust.cluster" && opt$estimator == "ml") {
|
| 347 | ! |
opt$information[1] <- "observed" |
| 348 |
} else {
|
|
| 349 | ! |
opt$information[1] <- "expected" |
| 350 |
} |
|
| 351 |
} |
|
| 352 | ! |
if (length(opt$information) > 1L && opt$information[2] == "default") {
|
| 353 | ! |
if (opt$se == "robust.cluster") {
|
| 354 | ! |
opt$information[2] <- "observed" |
| 355 |
} else {
|
|
| 356 | ! |
opt$information[2] <- "expected" |
| 357 |
} |
|
| 358 |
} |
|
| 359 |
} |
|
| 360 | ||
| 361 |
# multilevel #### |
|
| 362 |
# brute-force override (for now) |
|
| 363 | 79x |
if (opt$.multilevel) {
|
| 364 | 2x |
opt$meanstructure <- TRUE |
| 365 | ||
| 366 |
# test |
|
| 367 | 2x |
if (length(opt$test) == 1L && opt$test == "default") {
|
| 368 |
# ok, will be set later |
|
| 369 | ! |
} else if (all(opt$test %in% c( |
| 370 | ! |
"none", "standard", "yuan.bentler", |
| 371 | ! |
"yuan.bentler.mplus" |
| 372 |
))) {
|
|
| 373 |
# nothing to do |
|
| 374 |
} else {
|
|
| 375 | ! |
lav_msg_stop(gettextf( |
| 376 | ! |
"`test' argument must one of %s in the multilevel case", |
| 377 | ! |
lav_msg_view(c( |
| 378 | ! |
"none", "standard", "yuan.bentler", |
| 379 | ! |
"yuan.bentler.mplus" |
| 380 | ! |
), log.sep = "or") |
| 381 |
)) |
|
| 382 |
} |
|
| 383 | ||
| 384 |
# se |
|
| 385 | 2x |
if (opt$se == "default") {
|
| 386 |
# ok, will be set later |
|
| 387 | ! |
} else if (any(opt$se == c( |
| 388 | ! |
"none", "standard", "robust.huber.white", "sandwich" |
| 389 |
))) {
|
|
| 390 |
# nothing to do |
|
| 391 | ! |
} else if (opt$se == "robust") {
|
| 392 | ! |
opt$se <- "robust.huber.white" |
| 393 |
} else {
|
|
| 394 | ! |
lav_msg_stop(gettextf( |
| 395 | ! |
"`se' argument must one of %s in the multilevel case", |
| 396 | ! |
lav_msg_view(c("none", "standard", "robust.huber.white"),
|
| 397 | ! |
log.sep = "or" |
| 398 |
) |
|
| 399 |
)) |
|
| 400 |
} |
|
| 401 | ||
| 402 |
# information |
|
| 403 | 2x |
if (opt$information[1] == "default") {
|
| 404 | 2x |
opt$information[1] <- "observed" |
| 405 |
} |
|
| 406 | 2x |
if (length(opt$information) > 1L && opt$information[2] == "default") {
|
| 407 | 2x |
opt$information[2] <- "observed" |
| 408 |
} |
|
| 409 |
} |
|
| 410 | ||
| 411 |
# missing #### |
|
| 412 | 79x |
if (opt$missing == "default") {
|
| 413 | 25x |
opt$missing <- "listwise" |
| 414 | 54x |
} else if (opt$missing == "ml") {
|
| 415 | 8x |
if (opt$.categorical) {
|
| 416 | ! |
lav_msg_stop(gettextf( |
| 417 | ! |
"missing = %s not available in the categorical setting", |
| 418 | ! |
dQuote(opt$missing) |
| 419 |
)) |
|
| 420 |
} |
|
| 421 | 8x |
if (any(opt$estimator == c( |
| 422 | 8x |
"mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv", |
| 423 | 8x |
"uls", "ulsm", "ulsmv", "pml", "dls" |
| 424 |
))) {
|
|
| 425 | ! |
lav_msg_stop(gettextf( |
| 426 | ! |
"missing=%1$s is not allowed for estimator %2$s", |
| 427 | ! |
dQuote(opt$missing), |
| 428 | ! |
dQuote(lav_options_estimatorgroup(opt$estimator.orig)) |
| 429 |
)) |
|
| 430 |
} |
|
| 431 | 46x |
} else if (opt$missing == "ml.x") {
|
| 432 | ! |
if (opt$.categorical) {
|
| 433 | ! |
lav_msg_stop(gettextf( |
| 434 | ! |
"missing = %s not available in the categorical setting", |
| 435 | ! |
dQuote(opt$missing) |
| 436 |
)) |
|
| 437 |
} |
|
| 438 | ! |
if (any(opt$estimator == c( |
| 439 | ! |
"mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv", |
| 440 | ! |
"uls", "ulsm", "ulsmv", "pml", "dls" |
| 441 |
))) {
|
|
| 442 | ! |
lav_msg_stop(gettextf( |
| 443 | ! |
"missing=%1$s is not allowed for estimator %2$s", |
| 444 | ! |
dQuote(opt$missing), |
| 445 | ! |
dQuote(lav_options_estimatorgroup(opt$estimator.orig)) |
| 446 |
)) |
|
| 447 |
} |
|
| 448 | 46x |
} else if (opt$missing == "two.stage") {
|
| 449 | ! |
if (opt$.categorical) {
|
| 450 | ! |
lav_msg_stop(gettextf( |
| 451 | ! |
"missing = %s not available in the categorical setting", |
| 452 | ! |
dQuote(opt$missing) |
| 453 |
)) |
|
| 454 |
} |
|
| 455 | ! |
if (any(opt$estimator == c( |
| 456 | ! |
"mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv", |
| 457 | ! |
"uls", "ulsm", "ulsmv", "pml", "mml", "dls" |
| 458 |
))) {
|
|
| 459 | ! |
lav_msg_stop(gettextf( |
| 460 | ! |
"missing=%1$s is not allowed for estimator %2$s", |
| 461 | ! |
dQuote(opt$missing), |
| 462 | ! |
dQuote(lav_options_estimatorgroup(opt$estimator.orig)) |
| 463 |
)) |
|
| 464 |
} |
|
| 465 | 46x |
} else if (opt$missing == "robust.two.stage") {
|
| 466 | ! |
if (opt$.categorical) {
|
| 467 | ! |
lav_msg_stop(gettextf( |
| 468 | ! |
"missing = %s not available in the categorical setting", |
| 469 | ! |
dQuote(opt$missing) |
| 470 |
)) |
|
| 471 |
} |
|
| 472 | ! |
if (any(opt$estimator == c( |
| 473 | ! |
"mlm", "mlmv", "gls", "wls", "wlsm", "wlsmv", |
| 474 | ! |
"uls", "ulsm", "ulsmv", "pml", "mml", "dls" |
| 475 |
))) {
|
|
| 476 | ! |
lav_msg_stop(gettextf( |
| 477 | ! |
"missing=%1$s is not allowed for estimator %2$s", |
| 478 | ! |
dQuote(opt$missing), |
| 479 | ! |
dQuote(lav_options_estimatorgroup(opt$estimator.orig)) |
| 480 |
)) |
|
| 481 |
} |
|
| 482 | 46x |
} else if (opt$missing == "doubly.robust") {
|
| 483 | ! |
if (opt$estimator != "pml") {
|
| 484 | ! |
lav_msg_stop(gettextf( |
| 485 | ! |
"missing=%s option only available for estimator PML", |
| 486 | ! |
dQuote(opt$missing) |
| 487 |
)) |
|
| 488 |
} |
|
| 489 |
} |
|
| 490 | ||
| 491 |
# check missing #### |
|
| 492 | 79x |
if (any(opt$missing == c("ml", "ml.x")) &&
|
| 493 | 79x |
opt$se %in% c("robust.sem", "robust.sem.nt")) {
|
| 494 | ! |
lav_msg_warn(gettextf( |
| 495 | ! |
"missing will be set to %1$s for se = %2$s.", |
| 496 | ! |
dQuote("listwise"), dQuote(opt$se)
|
| 497 |
)) |
|
| 498 | ! |
opt$missing <- "listwise" |
| 499 |
} |
|
| 500 | 79x |
if (any(opt$missing == c("ml", "ml.x")) &&
|
| 501 | 79x |
any(opt$test %in% c( |
| 502 | 79x |
"satorra.bentler", |
| 503 | 79x |
"mean.var.adjusted", "scaled.shifted" |
| 504 |
))) {
|
|
| 505 | ! |
lav_msg_warn(gettextf( |
| 506 | ! |
"missing will be set to %s for satorra.bentler style test", |
| 507 | ! |
dQuote("listwise")
|
| 508 |
)) |
|
| 509 | ! |
opt$missing <- "listwise" |
| 510 |
} |
|
| 511 | ||
| 512 |
# checks if missing = "two.stage" or "robust.two.stage" #### |
|
| 513 | 79x |
if (any(opt$missing == c("two.stage", "robust.two.stage"))) {
|
| 514 | ! |
opt$meanstructure <- TRUE |
| 515 |
# se |
|
| 516 | ! |
if (opt$se == "default") {
|
| 517 | ! |
if (opt$missing == "two.stage") {
|
| 518 | ! |
opt$se <- "two.stage" |
| 519 |
} else {
|
|
| 520 | ! |
opt$se <- "robust.two.stage" |
| 521 |
} |
|
| 522 | ! |
} else if (opt$missing == "two.stage" && |
| 523 | ! |
opt$se == "two.stage") {
|
| 524 |
# nothing to do |
|
| 525 | ! |
} else if (opt$missing == "robust.two.stage" && |
| 526 | ! |
opt$se == "robust.two.stage") {
|
| 527 |
# nothing to do |
|
| 528 |
} else {
|
|
| 529 | ! |
lav_msg_warn(gettextf( |
| 530 | ! |
"se will be set to %1$s if missing = %2$s", |
| 531 | ! |
dQuote(opt$missing), dQuote(opt$missing) |
| 532 |
)) |
|
| 533 | ! |
opt$se <- opt$missing |
| 534 |
} |
|
| 535 |
# information |
|
| 536 | ! |
if (opt$information[1] == "default") {
|
| 537 |
# for both two.stage and robust.two.stage |
|
| 538 | ! |
opt$information[1] <- "observed" |
| 539 | ! |
} else if (opt$information[1] == "first.order") {
|
| 540 | ! |
lav_msg_warn(gettextf( |
| 541 | ! |
"information will be set to %1$s if missing = %2$s", |
| 542 | ! |
dQuote("observed"), dQuote(opt$missing)
|
| 543 |
)) |
|
| 544 | ! |
opt$information[1] <- "observed" |
| 545 |
} |
|
| 546 | ||
| 547 |
# observed.information (ALWAYS "h1" for now) |
|
| 548 | ! |
opt$observed.information[1] <- "h1" |
| 549 | ! |
opt$observed.information[2] <- "h1" |
| 550 | ||
| 551 |
# new in 0.6-9: ALWAYS h1.information = "unstructured" |
|
| 552 | ! |
opt$h1.information <- c("unstructured", "unstructured")
|
| 553 | ||
| 554 | ! |
if (length(opt$information) > 1L && opt$information[2] == "default") {
|
| 555 |
# for both two.stage and robust.two.stage |
|
| 556 | ! |
opt$information[2] <- "observed" |
| 557 |
} |
|
| 558 | ||
| 559 |
# test |
|
| 560 | ! |
if (length(opt$test) > 1L) {
|
| 561 | ! |
lav_msg_warn(gettextf( |
| 562 | ! |
"test= argument can only contain a single element if missing = %s |
| 563 | ! |
(taking the first)", dQuote(opt$missing) |
| 564 |
)) |
|
| 565 | ! |
opt$test <- opt$test[1] |
| 566 |
} |
|
| 567 | ||
| 568 | ! |
if (length(opt$test) == 1L && opt$test == "default") {
|
| 569 | ! |
opt$test <- "satorra.bentler" |
| 570 | ! |
} else if (length(opt$test) == 1L && any( |
| 571 | ! |
opt$test == c("satorra", "sb", "satorra.bentler", "satorra-bentler")
|
| 572 |
)) {
|
|
| 573 | ! |
opt$test <- "satorra.bentler" |
| 574 |
} else {
|
|
| 575 | ! |
lav_msg_warn(gettextf( |
| 576 | ! |
"test will be set to %1$s if missing = %2$s", |
| 577 | ! |
dQuote("satorra.bentler"), dQuote(opt$missing)
|
| 578 |
)) |
|
| 579 | ! |
opt$test <- "satorra.bentler" |
| 580 |
} |
|
| 581 |
} |
|
| 582 | ||
| 583 |
# meanstructure #### |
|
| 584 | 79x |
if (is.logical(opt$meanstructure)) {
|
| 585 | 47x |
if (opt$meanstructure == FALSE) {
|
| 586 | ! |
if (any(opt$missing == c("ml", "ml.x", "two.stage"))) {
|
| 587 | ! |
lav_msg_warn(gettextf( |
| 588 | ! |
"missing argument %s forces meanstructure = TRUE", |
| 589 | ! |
opt$missing |
| 590 |
)) |
|
| 591 |
} |
|
| 592 |
} |
|
| 593 | 32x |
} else if (opt$meanstructure == "default") {
|
| 594 |
# by default: no meanstructure! |
|
| 595 | 32x |
if (opt$estimator == "pml") {
|
| 596 | ! |
opt$meanstructure <- TRUE |
| 597 |
} else {
|
|
| 598 | 32x |
opt$meanstructure <- FALSE |
| 599 |
} |
|
| 600 |
} |
|
| 601 | ||
| 602 |
# bootstrap #### |
|
| 603 | 79x |
if (is.numeric(opt$bootstrap)) {
|
| 604 | 1x |
opt$bootstrap <- list(R = as.integer(opt$bootstrap)) |
| 605 |
} |
|
| 606 | 79x |
if (opt$se == "bootstrap") {
|
| 607 | 1x |
opt$information[1] <- "observed" |
| 608 | 1x |
if (length(opt$information) > 1L && opt$information[2] == "default") {
|
| 609 | ! |
opt$information[2] <- "observed" |
| 610 |
} |
|
| 611 |
} |
|
| 612 | ||
| 613 |
# specific per estimator (group) #### |
|
| 614 | 79x |
opt <- switch(opt$estimator, |
| 615 | 79x |
ml = , |
| 616 | 79x |
mlf = , |
| 617 | 79x |
mlm = , |
| 618 | 79x |
mlmv = , |
| 619 | 79x |
mlmvs = , |
| 620 | 79x |
mlr = lav_options_est_ml(opt), |
| 621 | 79x |
gls = lav_options_est_gls(opt), |
| 622 | 79x |
ntrls = lav_options_est_ntrls(opt), |
| 623 | 79x |
catml = lav_options_est_catml(opt), |
| 624 | 79x |
wls = lav_options_est_wls(opt), |
| 625 | 79x |
dls = lav_options_est_dls(opt), |
| 626 | 79x |
dwls = , |
| 627 | 79x |
wlsm = , |
| 628 | 79x |
wlsmv = , |
| 629 | 79x |
wlsmvs = lav_options_est_dwls(opt), |
| 630 | 79x |
uls = , |
| 631 | 79x |
ulsm = , |
| 632 | 79x |
ulsmv = , |
| 633 | 79x |
ulsmvs = lav_options_est_uls(opt), |
| 634 | 79x |
pml = lav_options_est_pml(opt), |
| 635 | 79x |
fml = lav_options_est_fml(opt), |
| 636 | 79x |
reml = lav_options_est_reml(opt), |
| 637 | 79x |
mml = lav_options_est_mml(opt), |
| 638 | 79x |
fabin2 = , |
| 639 | 79x |
fabin3 = , |
| 640 | 79x |
mgm = , |
| 641 | 79x |
js = , |
| 642 | 79x |
jsa = , |
| 643 | 79x |
bentler1982 = lav_options_est_fabin(opt), |
| 644 | 79x |
iv = lav_options_est_iv(opt), |
| 645 | 79x |
lav_options_est_none(opt) # estimator = none |
| 646 |
) |
|
| 647 | ||
| 648 |
# after code specific to estimator types #### |
|
| 649 |
# optim.method - if still "default" at this point -> set to "nlminb" |
|
| 650 | 79x |
if (opt$optim.method == "default") {
|
| 651 | 47x |
opt$optim.method <- "nlminb" |
| 652 |
} |
|
| 653 | ||
| 654 |
# special stuff for categorical |
|
| 655 | 79x |
if (opt$.categorical) {
|
| 656 | 2x |
opt$meanstructure <- TRUE # Mplus style |
| 657 | 2x |
if (lav_options_estimatorgroup(opt$estimator) == "ML") {
|
| 658 | ! |
lav_msg_stop(gettext( |
| 659 | ! |
"estimator ML for ordered data is not supported yet. Use WLSMV instead." |
| 660 |
)) |
|
| 661 |
} |
|
| 662 |
} |
|
| 663 | ||
| 664 |
# link |
|
| 665 | 79x |
if (opt$link == "logit") {
|
| 666 | ! |
if (opt$estimator != "mml") {
|
| 667 | ! |
lav_msg_warn(gettextf( |
| 668 | ! |
"link will be set to %1$s for estimator = %2$s", |
| 669 | ! |
dQuote("probit"), dQuote(opt$estimator)
|
| 670 |
)) |
|
| 671 |
} |
|
| 672 |
} |
|
| 673 | ||
| 674 |
# likelihood approach (wishart or normal) + sample.cov.rescale |
|
| 675 | 79x |
if (!any(lav_options_estimatorgroup(opt$estimator) == |
| 676 | 79x |
c("ML", "REML", "PML", "FML", "NTRLS", "catML"))) {
|
| 677 |
# if(opt$likelihood != "default") {
|
|
| 678 |
# lav_msg_stop(gettext( |
|
| 679 |
# "likelihood argument is only relevant if estimator = ML")) |
|
| 680 |
# } |
|
| 681 | 10x |
if (opt$sample.cov.rescale == "default") {
|
| 682 | 10x |
opt$sample.cov.rescale <- FALSE |
| 683 |
} # else {
|
|
| 684 |
# lav_msg_warn(gettext( |
|
| 685 |
# "sample.cov.rescale argument is only relevant if estimator = ML")) |
|
| 686 |
# } |
|
| 687 |
} else { # ml and friends
|
|
| 688 | 69x |
if (any(lav_options_estimatorgroup(opt$estimator) == c("PML", "FML"))) {
|
| 689 | ! |
opt$likelihood <- "normal" |
| 690 | 69x |
} else if (opt$likelihood == "default") {
|
| 691 | 65x |
opt$likelihood <- "normal" |
| 692 |
} |
|
| 693 | ||
| 694 | 69x |
if (opt$sample.cov.rescale == "default") {
|
| 695 | 37x |
opt$sample.cov.rescale <- FALSE |
| 696 | 37x |
if (opt$likelihood == "normal") {
|
| 697 | 33x |
opt$sample.cov.rescale <- TRUE |
| 698 |
} |
|
| 699 |
} |
|
| 700 |
} |
|
| 701 | ||
| 702 |
# se information |
|
| 703 | 79x |
if (opt$information[1] == "default") {
|
| 704 | 42x |
if (any(opt$missing == c("ml", "ml.x")) ||
|
| 705 | 42x |
any(opt$se == c("robust.huber.white", "first.order"))) {
|
| 706 |
# nchar(opt$constraints) > 0L) {
|
|
| 707 | 8x |
opt$information[1] <- "observed" |
| 708 |
} else {
|
|
| 709 | 34x |
opt$information[1] <- "expected" |
| 710 |
} |
|
| 711 |
} |
|
| 712 | ||
| 713 |
# first.order information can not be used with robust |
|
| 714 | 79x |
if (opt$information[1] == "first.order" && |
| 715 | 79x |
any(opt$se == c("robust.huber.white", "robust.sem", "robust.sem.nt"))) {
|
| 716 | ! |
lav_msg_stop(gettextf( |
| 717 | ! |
"information must be either %s if robust standard errors are requested.", |
| 718 | ! |
lav_msg_view(c("expected", "observed"), log.sep = "or")
|
| 719 |
)) |
|
| 720 |
} |
|
| 721 | ||
| 722 |
# test information |
|
| 723 | 79x |
if (length(opt$information) == 1L) {
|
| 724 | 35x |
opt$information <- rep(opt$information, 2L) |
| 725 |
} |
|
| 726 | 79x |
if (opt$information[2] == "default") {
|
| 727 | 42x |
if (any(opt$missing == c("ml", "ml.x")) ||
|
| 728 | 42x |
any(opt$se == c("robust.huber.white", "first.order"))) {
|
| 729 |
# nchar(opt$constraints) > 0L) {
|
|
| 730 | 8x |
opt$information[2] <- "observed" |
| 731 |
} else {
|
|
| 732 | 34x |
opt$information[2] <- "expected" |
| 733 |
} |
|
| 734 |
} |
|
| 735 | ||
| 736 |
# first.order information cannot be used with robust |
|
| 737 | 79x |
if (opt$information[2] == "first.order" && |
| 738 | 79x |
any(opt$test %in% c( |
| 739 | 79x |
"satorra.bentler", "yuan.bentler", |
| 740 | 79x |
"yuan.bentler.mplus", |
| 741 | 79x |
"mean.var.adjusted", "scaled.shifted" |
| 742 |
))) {
|
|
| 743 | ! |
lav_msg_stop(gettextf( |
| 744 | ! |
"information must be either %s if robust test statistics are requested.", |
| 745 | ! |
lav_msg_view(c("expected", "observed"), log.sep = "or")
|
| 746 |
)) |
|
| 747 |
} |
|
| 748 | ||
| 749 | ||
| 750 | 79x |
if (length(opt$observed.information) == 1L) {
|
| 751 | ! |
opt$observed.information <- rep(opt$observed.information, 2L) |
| 752 |
} |
|
| 753 | ||
| 754 | 79x |
if (all(opt$observed.information[2] != c("hessian", "h1"))) {
|
| 755 | 79x |
if (opt$observed.information[2] == "default") {
|
| 756 | 79x |
if (any(opt$test %in% c( |
| 757 | 79x |
"satorra.bentler", |
| 758 | 79x |
"yuan.bentler", |
| 759 | 79x |
"yuan.bentler.mplus", |
| 760 | 79x |
"mean.var.adjusted", |
| 761 | 79x |
"scaled.shifted" |
| 762 |
))) {
|
|
| 763 | 4x |
if (length(opt$test) > 1L) {
|
| 764 | ! |
opt$observed.information[2] <- "h1" # CHANGED in 0.6-6! |
| 765 | ! |
if (any(opt$test == "yuan.bentler.mplus")) {
|
| 766 | ! |
lav_msg_warn(gettext( |
| 767 | ! |
"observed.information for ALL test statistics is set to h1." |
| 768 |
)) |
|
| 769 |
} |
|
| 770 |
} else {
|
|
| 771 | 4x |
if (opt$estimator == "PML" || |
| 772 | 4x |
opt$test[1] == "yuan.bentler.mplus") {
|
| 773 | 2x |
opt$observed.information[2] <- "hessian" |
| 774 |
} else {
|
|
| 775 | 2x |
opt$observed.information[2] <- "h1" # CHANGED in 0.6-6! |
| 776 |
} |
|
| 777 |
} |
|
| 778 |
} else {
|
|
| 779 |
# default is "hessian" |
|
| 780 | 75x |
opt$observed.information[2] <- "hessian" |
| 781 |
} |
|
| 782 |
} |
|
| 783 |
} |
|
| 784 | ||
| 785 | 79x |
if (length(opt$h1.information) == 1L) {
|
| 786 | ! |
opt$h1.information <- rep(opt$h1.information, 2L) |
| 787 |
} |
|
| 788 | ||
| 789 | 79x |
if (opt$h1.information.meat == "default") {
|
| 790 | 79x |
opt$h1.information.meat <- opt$h1.information[1] |
| 791 |
} |
|
| 792 | ||
| 793 |
# check information if estimator is uls/wls and friends |
|
| 794 | 79x |
if (any(lav_options_estimatorgroup(opt$estimator) == |
| 795 | 79x |
c("ULS", "WLS", "DWLS"))) {
|
| 796 | 4x |
if (opt$information[1] != "expected") {
|
| 797 | ! |
lav_msg_warn(gettextf( |
| 798 | ! |
"information will be set to %1$s for estimator = %2$s", |
| 799 | ! |
dQuote("expected"), dQuote(opt$estimator)
|
| 800 |
)) |
|
| 801 | ! |
opt$information <- rep.int("expected", 2L)
|
| 802 |
} |
|
| 803 | 4x |
opt$h1.information <- rep.int("unstructured", 2L) # FIXME: allow option?
|
| 804 |
} |
|
| 805 | ||
| 806 | ||
| 807 |
# omega information |
|
| 808 | 79x |
if (opt$omega.information == "default") {
|
| 809 | 79x |
opt$omega.information <- opt$information[2] # test version! |
| 810 |
} |
|
| 811 | ||
| 812 | 79x |
if (opt$omega.h1.information == "default") {
|
| 813 |
# opt$omega.h1.information <- opt$h1.information[2] # test version! |
|
| 814 | 79x |
opt$omega.h1.information <- "unstructured" |
| 815 |
} |
|
| 816 | ||
| 817 | 79x |
if (opt$omega.h1.information.meat == "default") {
|
| 818 | 79x |
opt$omega.h1.information.meat <- opt$omega.h1.information |
| 819 |
} |
|
| 820 | ||
| 821 |
# conditional.x |
|
| 822 | 79x |
if (is.character(opt$conditional.x)) { # = "default"
|
| 823 | 4x |
if (opt$.categorical) {
|
| 824 | 2x |
opt$conditional.x <- TRUE |
| 825 |
} else {
|
|
| 826 | 2x |
opt$conditional.x <- FALSE |
| 827 |
} |
|
| 828 |
} |
|
| 829 | ||
| 830 |
# if conditional.x, always use a meanstructure |
|
| 831 | 79x |
if (opt$conditional.x) {
|
| 832 | 2x |
opt$meanstructure <- TRUE |
| 833 |
} |
|
| 834 | ||
| 835 |
# fixed.x |
|
| 836 | 79x |
if (is.logical(opt$fixed.x)) {
|
| 837 |
# if(opt$conditional.x && opt$fixed.x == FALSE && !opt$.multilevel) {
|
|
| 838 | 75x |
if (opt$conditional.x && opt$fixed.x == FALSE) {
|
| 839 | ! |
lav_msg_stop(gettext( |
| 840 | ! |
"fixed.x = FALSE is not supported when conditional.x = TRUE." |
| 841 |
)) |
|
| 842 |
} |
|
| 843 | 75x |
if (opt$fixed.x && is.character(opt$start) && opt$start == "simple") {
|
| 844 | ! |
lav_msg_warn(gettextf( |
| 845 | ! |
"start = %s implies fixed.x = FALSE", dQuote(opt$start) |
| 846 |
)) |
|
| 847 | ! |
opt$fixed.x <- FALSE |
| 848 |
} |
|
| 849 | 4x |
} else if (opt$fixed.x == "default") {
|
| 850 | 4x |
if (opt$conditional.x) {
|
| 851 | 2x |
opt$fixed.x <- TRUE |
| 852 |
} else {
|
|
| 853 | 2x |
opt$fixed.x <- FALSE |
| 854 |
} |
|
| 855 |
} |
|
| 856 | ||
| 857 |
# meanstructure again |
|
| 858 | 79x |
if (any(opt$missing == c("ml", "ml.x")) || opt$model.type == "growth") {
|
| 859 | 8x |
opt$meanstructure <- TRUE |
| 860 |
} |
|
| 861 | 79x |
if (any(c("intercepts", "means") %in% opt$group.equal)) {
|
| 862 | ! |
opt$meanstructure <- TRUE |
| 863 |
} |
|
| 864 |
# if(opt$se == "robust.huber.white" || |
|
| 865 |
# opt$se == "robust.sem" || |
|
| 866 |
# opt$test == "satorra.bentler" || |
|
| 867 |
# opt$test == "mean.var.adjusted" || |
|
| 868 |
# opt$test == "scaled.shifted" || |
|
| 869 |
# opt$test == "yuan.bentler") {
|
|
| 870 |
# opt$meanstructure <- TRUE |
|
| 871 |
# } |
|
| 872 | 79x |
if (!is.logical(opt$meanstructure)) {
|
| 873 | ! |
lav_msg_fixme("meanstructure must be logical at this point!")
|
| 874 |
} |
|
| 875 | ||
| 876 |
# zero cell frequencies |
|
| 877 | 79x |
if (is.character(opt$zero.add)) { # = "default"
|
| 878 | ! |
opt$zero.add <- c(0.5, 0.0) |
| 879 |
# FIXME: TODO: mimic EQS , LISREL (0.0, 0.0) |
|
| 880 |
} else {
|
|
| 881 | 79x |
if (length(opt$zero.add) == 1L) {
|
| 882 | ! |
opt$zero.add <- c(opt$zero.add, opt$zero.add) |
| 883 |
} |
|
| 884 |
} |
|
| 885 | ||
| 886 | 79x |
if (is.character(opt$zero.keep.margins)) { # = "default"
|
| 887 | ! |
opt$zero.keep.margins <- FALSE |
| 888 |
} |
|
| 889 | ||
| 890 | ||
| 891 |
# parameterization |
|
| 892 | 79x |
if (opt$parameterization == "default") {
|
| 893 |
# for now, default is always delta |
|
| 894 | 79x |
opt$parameterization <- "delta" |
| 895 |
} |
|
| 896 | ||
| 897 |
# std.lv vs auto.fix.first # new in 0.6-5 (used to be in sem/cfa/growth) |
|
| 898 | 79x |
if (opt$std.lv) {
|
| 899 | ! |
opt$auto.fix.first <- FALSE |
| 900 |
} |
|
| 901 | ||
| 902 |
# std.lv vs effect.coding # new in 0.6-4 |
|
| 903 | 79x |
if (is.logical(opt$effect.coding)) {
|
| 904 | 79x |
if (opt$effect.coding) {
|
| 905 | ! |
opt$effect.coding <- c("loadings", "intercepts")
|
| 906 |
} else {
|
|
| 907 | 79x |
opt$effect.coding <- "" |
| 908 |
} |
|
| 909 |
} |
|
| 910 | ||
| 911 |
# if we use effect coding for the factor loadings, we don't need/want |
|
| 912 |
# std.lv = TRUE |
|
| 913 | 79x |
if (any("loadings" == opt$effect.coding)) {
|
| 914 | ! |
if (opt$std.lv) {
|
| 915 | ! |
lav_msg_stop(gettextf( |
| 916 | ! |
"std.lv is set to FALSE but effect.coding contains %s", |
| 917 | ! |
dQuote("loadings")
|
| 918 |
)) |
|
| 919 |
} |
|
| 920 |
# shut off auto.fix.first |
|
| 921 | ! |
opt$auto.fix.first <- FALSE |
| 922 |
} |
|
| 923 | ||
| 924 |
# test again |
|
| 925 | ||
| 926 |
# unless test = "none", always add test = "standard" as the |
|
| 927 |
# first entry |
|
| 928 |
# NO: this breaks lavaan.survey pval.pFsum, which has the following check: |
|
| 929 |
# if (!lavInspect(lavaan.fit, "options")$test %in% c("satorra.bentler",
|
|
| 930 |
# "mean.var.adjusted", "Satterthwaite")) {
|
|
| 931 |
# lav_msg_stop( |
|
| 932 |
# gettext("Please refit the model with Satorra-Bentler (MLM)"),
|
|
| 933 |
# gettext(" or Satterthwaite (MLMVS) adjustment."))
|
|
| 934 |
# } |
|
| 935 |
# if(! (length(opt$test) == 1L && opt$test == "none") ) {
|
|
| 936 |
# opt$test <- c("standard", opt$test)
|
|
| 937 |
# opt$test <- unique(opt$test) |
|
| 938 |
# } |
|
| 939 | ||
| 940 |
# add standard.test to test (if not already there) |
|
| 941 | 79x |
if (opt$standard.test != "standard") {
|
| 942 | ! |
if (length(opt$test) == 1L && opt$test[1] == "standard") {
|
| 943 | ! |
opt$test <- unique(c(opt$test, opt$standard.test)) |
| 944 |
} else {
|
|
| 945 | ! |
opt$test <- unique(c(opt$standard.test, opt$test)) |
| 946 |
} |
|
| 947 |
} |
|
| 948 | ||
| 949 |
# add scaled.test to test (if not already there) |
|
| 950 | 79x |
if (opt$scaled.test != "standard") {
|
| 951 | ! |
if (length(opt$test) == 1L && opt$test[1] == "standard") {
|
| 952 | ! |
opt$test <- unique(c(opt$test, opt$scaled.test)) |
| 953 |
} else {
|
|
| 954 | ! |
opt$test <- unique(c(opt$scaled.test, opt$test)) |
| 955 |
} |
|
| 956 |
} |
|
| 957 | ||
| 958 |
# where does "standard" appear in the opt$test vector? |
|
| 959 | 79x |
if (opt$test[1] != "none") {
|
| 960 | 79x |
standard.idx <- which(opt$test == "standard")[1] |
| 961 | 79x |
if (is.na(standard.idx)) {
|
| 962 |
# "standard" is not in the opt$test vector at all, |
|
| 963 |
# so add it |
|
| 964 | 4x |
opt$test <- c("standard", opt$test)
|
| 965 | 75x |
} else if (length(standard.idx) > 0L && standard.idx != 1L) {
|
| 966 |
# make sure "standard" comes first |
|
| 967 | ! |
opt$test <- c("standard", opt$test[-standard.idx])
|
| 968 |
} |
|
| 969 |
} |
|
| 970 | ||
| 971 |
# final check |
|
| 972 | 79x |
wrong.idx <- which(!opt$test %in% c( |
| 973 | 79x |
"none", "standard", "satorra.bentler", |
| 974 | 79x |
"yuan.bentler", "yuan.bentler.mplus", |
| 975 | 79x |
"mean.var.adjusted", "scaled.shifted", |
| 976 | 79x |
"browne.residual.adf", "browne.residual.nt", |
| 977 | 79x |
"browne.residual.nt.model", |
| 978 | 79x |
"browne.residual.adf.model", |
| 979 | 79x |
"bollen.stine" |
| 980 |
)) |
|
| 981 | 79x |
if (length(wrong.idx) > 0L) {
|
| 982 | ! |
lav_msg_stop(gettextf( |
| 983 | ! |
"invalid option(s) for test argument: %1$s. Possible options are: %2$s.", |
| 984 | ! |
lav_msg_view(opt$test[wrong.idx]), |
| 985 | ! |
lav_msg_view(c( |
| 986 | ! |
"none", "standard", "browne.residual.adf", |
| 987 | ! |
"browne.residual.nt", "browne.residual.adf.model", |
| 988 | ! |
"browne.residual.nt.model", "satorra.bentler", |
| 989 | ! |
"yuan.bentler", "yuan.bentler.mplus", |
| 990 | ! |
"mean.var.adjusted", "scaled.shifted", |
| 991 | ! |
"bollen.stine" |
| 992 | ! |
), log.sep = "or") |
| 993 |
)) |
|
| 994 |
} |
|
| 995 | ||
| 996 |
# bounds |
|
| 997 | 79x |
if (is.null(opt$bounds)) {
|
| 998 | ! |
if (length(opt$optim.bounds) > 0L) {
|
| 999 | ! |
opt$bounds <- "user" |
| 1000 |
} else {
|
|
| 1001 | ! |
opt$bounds <- "none" # for now |
| 1002 |
} |
|
| 1003 | 79x |
} else if (is.logical(opt$bounds)) {
|
| 1004 | 2x |
if (opt$bounds) {
|
| 1005 | ! |
opt$bounds <- "wide" # default for most estimators |
| 1006 |
} else {
|
|
| 1007 | 2x |
opt$bounds <- "none" |
| 1008 |
} |
|
| 1009 |
} |
|
| 1010 | ||
| 1011 |
# optim.bounds |
|
| 1012 | 79x |
if (length(opt$optim.bounds) > 0L) {
|
| 1013 |
# opt$bounds should be "default", or "user" (or "none") |
|
| 1014 | ! |
if (any(opt$bounds == c("default", "none", "user"))) {
|
| 1015 | ! |
opt$bounds <- "user" |
| 1016 |
} else {
|
|
| 1017 | ! |
lav_msg_stop( |
| 1018 | ! |
gettext("bounds and optim.bounds arguments can not be used together;
|
| 1019 | ! |
remove the bounds= argument or set it to \"user\".") |
| 1020 |
) |
|
| 1021 |
} |
|
| 1022 |
} |
|
| 1023 | ||
| 1024 |
# handle different 'profiles' |
|
| 1025 | 79x |
if (opt$bounds == "none") {
|
| 1026 | 75x |
opt$optim.bounds <- list( |
| 1027 | 75x |
lower = character(0L), |
| 1028 | 75x |
upper = character(0L) |
| 1029 |
) |
|
| 1030 | 4x |
} else if (opt$bounds == "user") {
|
| 1031 | ! |
if (length(opt$optim.bounds) == 0L) {
|
| 1032 | ! |
lav_msg_stop(gettextf( |
| 1033 | ! |
"bounds= is %s but optim.bounds= argument is empty", dQuote("user")
|
| 1034 |
)) |
|
| 1035 |
} |
|
| 1036 | 4x |
} else if (opt$bounds == "default" || opt$bounds == "wide") {
|
| 1037 | ! |
opt$optim.bounds <- list( |
| 1038 | ! |
lower = c("ov.var", "lv.var", "loadings", "covariances"),
|
| 1039 | ! |
upper = c("ov.var", "lv.var", "loadings", "covariances"),
|
| 1040 | ! |
lower.factor = c(1.05, 1.0, 1.1, 1.0), |
| 1041 | ! |
upper.factor = c(1.20, 1.3, 1.1, 1.0), |
| 1042 | ! |
min.reliability.marker = 0.1, |
| 1043 | ! |
min.var.lv.endo = 0.005 |
| 1044 |
) |
|
| 1045 | 4x |
} else if (opt$bounds == "wide.zerovar") {
|
| 1046 | ! |
opt$optim.bounds <- list( |
| 1047 | ! |
lower = c("ov.var", "lv.var", "loadings", "covariances"),
|
| 1048 | ! |
upper = c("ov.var", "lv.var", "loadings", "covariances"),
|
| 1049 | ! |
lower.factor = c(1.00, 1.0, 1.1, 1.0), |
| 1050 | ! |
upper.factor = c(1.20, 1.3, 1.1, 1.0), |
| 1051 | ! |
min.reliability.marker = 0.1, |
| 1052 | ! |
min.var.lv.endo = 0.005 |
| 1053 |
) |
|
| 1054 | 4x |
} else if (opt$bounds == "standard") {
|
| 1055 | ! |
opt$optim.bounds <- list( |
| 1056 | ! |
lower = c("ov.var", "lv.var", "loadings", "covariances"),
|
| 1057 | ! |
upper = c("ov.var", "lv.var", "loadings", "covariances"),
|
| 1058 | ! |
lower.factor = c(1.0, 1.0, 1.0, 0.999), |
| 1059 | ! |
upper.factor = c(1.0, 1.0, 1.0, 0.999), |
| 1060 | ! |
min.reliability.marker = 0.1, |
| 1061 | ! |
min.var.lv.endo = 0.005 |
| 1062 |
) |
|
| 1063 | 4x |
} else if (opt$bounds == "pos.var") {
|
| 1064 | 4x |
opt$optim.bounds <- list( |
| 1065 | 4x |
lower = c("ov.var", "lv.var"),
|
| 1066 | 4x |
lower.factor = c(1, 1), |
| 1067 | 4x |
min.reliability.marker = 0.0, |
| 1068 | 4x |
min.var.lv.exo = 0.0, |
| 1069 | 4x |
min.var.lv.endo = 0.0 |
| 1070 |
) |
|
| 1071 | ! |
} else if (opt$bounds == "pos.ov.var") {
|
| 1072 | ! |
opt$optim.bounds <- list( |
| 1073 | ! |
lower = c("ov.var"),
|
| 1074 | ! |
lower.factor = 1 |
| 1075 |
) |
|
| 1076 | ! |
} else if (opt$bounds == "pos.lv.var") {
|
| 1077 | ! |
opt$optim.bounds <- list( |
| 1078 | ! |
lower = c("lv.var"),
|
| 1079 | ! |
lower.factor = 1, |
| 1080 | ! |
min.reliability.marker = 0.0, |
| 1081 | ! |
min.var.lv.exo = 0.0, |
| 1082 | ! |
min.var.lv.endo = 0.0 |
| 1083 |
) |
|
| 1084 |
} |
|
| 1085 | ||
| 1086 |
# rotations.args |
|
| 1087 | 79x |
if (!is.list(opt$rotation.args)) {
|
| 1088 | ! |
lav_msg_stop(gettext("rotation.args should be be list."))
|
| 1089 |
} |
|
| 1090 | ||
| 1091 |
# force orthogonal for some rotation algorithms |
|
| 1092 | 79x |
if (any(opt$rotation == c( |
| 1093 | 79x |
"varimax", "entropy", "mccammon", |
| 1094 | 79x |
"tandem1", "tandem2" |
| 1095 |
))) {
|
|
| 1096 | ! |
opt$rotation.args$orthogonal <- TRUE |
| 1097 |
} |
|
| 1098 | ||
| 1099 |
# if target, check target matrix, and set order.lv.by to = "none" |
|
| 1100 | 79x |
if (opt$rotation == "target.strict" || opt$rotation == "pst") {
|
| 1101 | ! |
target <- opt$rotation.args$target |
| 1102 | ! |
if (is.null(target)) {
|
| 1103 | ! |
lav_msg_stop(gettext("rotation target matrix is NULL"))
|
| 1104 |
} |
|
| 1105 | ! |
if (is.list(target)) {
|
| 1106 | ! |
if (!all(sapply(target, is.matrix))) {
|
| 1107 | ! |
lav_msg_stop(gettext("the target list contains
|
| 1108 | ! |
elements that are not a matrix")) |
| 1109 |
} |
|
| 1110 | ! |
} else if (!is.matrix(target)) {
|
| 1111 | ! |
lav_msg_stop(gettext("rotation target matrix is not a matrix"))
|
| 1112 |
} |
|
| 1113 | ! |
opt$rotation.args$order.lv.by <- "none" |
| 1114 |
} |
|
| 1115 | ||
| 1116 | 79x |
if (opt$rotation == "pst") {
|
| 1117 | ! |
target.mask <- opt$rotation.args$target.mask |
| 1118 | ! |
if (is.null(target.mask) || length(target.mask) == 0L) {
|
| 1119 |
# lav_msg_stop(gettext("rotation target.mask matrix is NULL"))
|
|
| 1120 | ! |
if (is.matrix(target)) {
|
| 1121 | ! |
tmp <- matrix(1L, nrow = nrow(target), ncol = ncol(target)) |
| 1122 | ! |
tmp[target != 0] <- 0L # ignore these (non-zero) elements |
| 1123 | ! |
opt$rotation.args$target.mask <- target.mask <- tmp |
| 1124 | ! |
} else if (is.list(target)) {
|
| 1125 | ! |
out <- lapply(seq_along(target), function(g) {
|
| 1126 | ! |
tmp <- matrix(1L, |
| 1127 | ! |
nrow = nrow(target[[g]]), |
| 1128 | ! |
ncol = ncol(target[[g]]) |
| 1129 |
) |
|
| 1130 | ! |
tmp[target[[g]] != 0] <- 0L # ignore these (non-zero) elements |
| 1131 | ! |
tmp |
| 1132 |
}) |
|
| 1133 | ! |
opt$rotation.args$target.mask <- target.mask <- out |
| 1134 |
} |
|
| 1135 |
} |
|
| 1136 | ! |
if (is.list(target.mask)) {
|
| 1137 | ! |
if (!all(sapply(target.mask, is.matrix))) {
|
| 1138 | ! |
lav_msg_stop(gettext("the target.mask list contains
|
| 1139 | ! |
elements that are not a matrix")) |
| 1140 |
} |
|
| 1141 | ! |
} else if (!is.matrix(target.mask)) {
|
| 1142 | ! |
lav_msg_stop(gettext("rotation target.mask matrix is not a matrix"))
|
| 1143 |
} |
|
| 1144 | ! |
if (is.list(target) && !is.list(target.mask)) {
|
| 1145 | ! |
lav_msg_stop(gettext("target is a list, but target.mask is not a list"))
|
| 1146 |
} |
|
| 1147 | ! |
if (is.list(target.mask) && !is.list(target)) {
|
| 1148 | ! |
lav_msg_stop(gettext("target.mask is a list, but target is not a list"))
|
| 1149 |
} |
|
| 1150 | ! |
if (is.list(target) && is.list(target.mask)) {
|
| 1151 | ! |
if (length(target) != length(target.mask)) {
|
| 1152 | ! |
lav_msg_stop(gettext("length(target) != length(target.mask)"))
|
| 1153 |
} |
|
| 1154 |
} |
|
| 1155 |
} |
|
| 1156 | ||
| 1157 |
# if NAs, force opt$rotation to be 'pst' and create target.mask |
|
| 1158 | 79x |
if (opt$rotation == "target.strict") {
|
| 1159 |
# matrix |
|
| 1160 | ! |
warn.flag <- FALSE |
| 1161 | ! |
if (is.matrix(target) && anyNA(target)) {
|
| 1162 | ! |
warn.flag <- TRUE |
| 1163 | ! |
opt$rotation <- "pst" |
| 1164 | ! |
target.mask <- matrix(1, nrow = nrow(target), ncol = ncol(target)) |
| 1165 | ! |
target.mask[is.na(target)] <- 0 |
| 1166 | ! |
opt$rotation.args$target.mask <- target.mask |
| 1167 | ||
| 1168 |
# list |
|
| 1169 | ! |
} else if (is.list(target)) {
|
| 1170 | ! |
ngroups <- length(target) |
| 1171 | ! |
for (g in seq_len(ngroups)) {
|
| 1172 | ! |
if (anyNA(target[[g]])) {
|
| 1173 | ! |
warn.flag <- TRUE |
| 1174 |
# is target.mask just a <0 x 0 matrix>? create list! |
|
| 1175 | ! |
if (is.matrix(opt$rotation.args$target.mask)) {
|
| 1176 | ! |
opt$rotation.args$target.mask <- vector("list", length = ngroups)
|
| 1177 |
} |
|
| 1178 | ! |
opt$rotation <- "pst" |
| 1179 | ! |
target.mask <- matrix(1, |
| 1180 | ! |
nrow = nrow(target[[g]]), |
| 1181 | ! |
ncol = ncol(target[[g]]) |
| 1182 |
) |
|
| 1183 | ! |
target.mask[is.na(target[[g]])] <- 0 |
| 1184 | ! |
opt$rotation.args$target.mask[[g]] <- target.mask |
| 1185 |
} |
|
| 1186 |
} |
|
| 1187 |
} |
|
| 1188 | ! |
if (warn.flag) {
|
| 1189 | ! |
lav_msg_warn(gettext( |
| 1190 | ! |
"switching to PST rotation as target matrix contains NA values" |
| 1191 |
)) |
|
| 1192 |
} |
|
| 1193 |
} |
|
| 1194 | ||
| 1195 |
# set row.weights |
|
| 1196 | 79x |
opt$rotation.args$row.weights <- tolower(opt$rotation.args$row.weights) |
| 1197 | 79x |
if (opt$rotation.args$row.weights == "default") {
|
| 1198 |
# the default is "none", except for varimax and promax |
|
| 1199 | 79x |
if (any(opt$rotation == c("varimax", "promax"))) {
|
| 1200 | ! |
opt$rotation.args$row.weights <- "kaiser" |
| 1201 |
} else {
|
|
| 1202 | 79x |
opt$rotation.args$row.weights <- "none" |
| 1203 |
} |
|
| 1204 |
} |
|
| 1205 | ||
| 1206 |
# override if bifactor |
|
| 1207 | 79x |
if (any(opt$rotation == c( |
| 1208 | 79x |
"bi-geomin", "bigeomin", "bi-quartimin", |
| 1209 | 79x |
"biquartimin" |
| 1210 |
))) {
|
|
| 1211 | ! |
opt$rotation.args$order.lv.by <- "none" |
| 1212 |
} |
|
| 1213 | ||
| 1214 |
# no standard errors for promax (for now)... |
|
| 1215 | 79x |
if (opt$rotation == "promax") {
|
| 1216 | ! |
opt$se <- "none" |
| 1217 | ! |
opt$rotation.args$algorithm <- "promax" |
| 1218 | ! |
opt$rotation.args$rstarts <- 0L |
| 1219 |
} |
|
| 1220 | ||
| 1221 |
# correlation |
|
| 1222 | 79x |
if (opt$correlation) {
|
| 1223 |
# standardize |
|
| 1224 | ! |
opt$std.ov <- TRUE |
| 1225 |
# if ML, switch to GLS |
|
| 1226 | ! |
if (opt$estimator == "ml") {
|
| 1227 |
# lav_msg_warn(gettext( |
|
| 1228 |
# "GLS should be used for correlation structures instead of ML.")) |
|
| 1229 | ! |
opt$estimator <- "gls" |
| 1230 |
} |
|
| 1231 | ! |
if (opt$missing == "ml") {
|
| 1232 | ! |
lav_msg_stop(gettext( |
| 1233 | ! |
"correlation structures only work for complete data (for now)." |
| 1234 |
)) |
|
| 1235 |
} |
|
| 1236 | ! |
if (opt$.multilevel) {
|
| 1237 | ! |
lav_msg_stop(gettext( |
| 1238 | ! |
"correlation structures only work for single-level data." |
| 1239 |
)) |
|
| 1240 |
} |
|
| 1241 | ! |
if (opt$conditional.x) {
|
| 1242 | ! |
lav_msg_stop(gettext( |
| 1243 | ! |
"correlation structures only work for conditional.x = FALSE (for now)." |
| 1244 |
)) |
|
| 1245 |
} |
|
| 1246 | ! |
if (opt$representation == "RAM") {
|
| 1247 | ! |
lav_msg_stop(gettext( |
| 1248 | ! |
"correlation structures only work for representation = \"LISREL\"." |
| 1249 |
)) |
|
| 1250 |
} |
|
| 1251 | ! |
if (opt$fixed.x) {
|
| 1252 | ! |
lav_msg_stop(gettext( |
| 1253 | ! |
"correlation structures only work for fixed.x = FALSE (for now)." |
| 1254 |
)) |
|
| 1255 |
} |
|
| 1256 |
} |
|
| 1257 | ||
| 1258 |
# sample.cov.robust |
|
| 1259 |
# new in 0.6-17 |
|
| 1260 |
# sample.cov.robust cannot be used if: |
|
| 1261 |
# - data is missing (for now), |
|
| 1262 |
# - sampling weights are used |
|
| 1263 |
# - estimator is (D)WLS |
|
| 1264 |
# - multilevel |
|
| 1265 |
# - conditional.x |
|
| 1266 | 79x |
if (opt$sample.cov.robust) {
|
| 1267 | ! |
if (opt$missing != "listwise") {
|
| 1268 | ! |
lav_msg_stop(gettext( |
| 1269 | ! |
"sample.cov.robust = TRUE does not work (yet) if data is missing." |
| 1270 |
)) |
|
| 1271 |
} |
|
| 1272 | ! |
if (opt$.categorical) {
|
| 1273 | ! |
lav_msg_stop(gettext( |
| 1274 | ! |
"sample.cov.robust = TRUE does not work (yet) if data is categorical" |
| 1275 |
)) |
|
| 1276 |
} |
|
| 1277 | ! |
if (opt$.clustered || opt$.multilevel) {
|
| 1278 | ! |
lav_msg_stop(gettext( |
| 1279 | ! |
"sample.cov.robust = TRUE does not work (yet) if data is clustered" |
| 1280 |
)) |
|
| 1281 |
} |
|
| 1282 | ! |
if (opt$conditional.x) {
|
| 1283 | ! |
lav_msg_stop(gettext( |
| 1284 | ! |
"sample.cov.robust = TRUE does not work (yet) if conditional.x = TRUE" |
| 1285 |
)) |
|
| 1286 |
} |
|
| 1287 | ! |
if (all(lav_options_estimatorgroup(opt$estimator) != c("ML", "GLS"))) {
|
| 1288 | ! |
lav_msg_stop(gettext( |
| 1289 | ! |
"sample.cov.robust = TRUE does not work (yet) |
| 1290 | ! |
if estimator is not GLS or ML" |
| 1291 |
)) |
|
| 1292 |
} |
|
| 1293 |
} |
|
| 1294 | ||
| 1295 | 79x |
opt$estimator <- lav_options_estimatorgroup(opt$estimator) |
| 1296 | ||
| 1297 |
# group.w.free |
|
| 1298 |
# if(opt$group.w.free && opt$.categorical) {
|
|
| 1299 |
# lav_msg_stop(gettext( |
|
| 1300 |
# "group.w.free = TRUE is not supported (yet) in the categorical setting." |
|
| 1301 |
# )) |
|
| 1302 |
# } |
|
| 1303 | ||
| 1304 |
# in order not to break semTools and blavaan, we restore categorical: |
|
| 1305 | 79x |
opt$categorical <- opt$.categorical |
| 1306 | ||
| 1307 | 79x |
if (lav_debug()) {
|
| 1308 | ! |
cat("lavaan DEBUG: lavaanOptions OUT\n")
|
| 1309 | ! |
str(opt) |
| 1310 |
} |
|
| 1311 | ||
| 1312 | 79x |
opt |
| 1313 |
} |
| 1 |
# |
|
| 2 |
# the lavData class describes how the data looks like |
|
| 3 |
# - do we have a full data frame, or only sample statistics? |
|
| 4 |
# (TODO: allow for patterns + freq, if data is categorical) |
|
| 5 |
# - variable type ("numeric", "ordered", ...)
|
|
| 6 |
# - how many groups, how many observations, ... |
|
| 7 |
# - what about missing patterns? |
|
| 8 |
# |
|
| 9 |
# initial version: YR 14 April 2012 |
|
| 10 | ||
| 11 |
# YR 23 Feb 2017: blocks/levels/groups, but everything is group-based! |
|
| 12 | ||
| 13 |
# FIXME: if nlevels > 1L, and ngroups > 1L, we should check that |
|
| 14 |
# group is at the upper-level |
|
| 15 | ||
| 16 |
# YR 08 May 2019: sampling weights normalization -> different options |
|
| 17 | ||
| 18 |
# extract the data we need for this particular model |
|
| 19 |
lav_lavdata <- function(data = NULL, # data.frame |
|
| 20 |
group = NULL, # multiple groups? |
|
| 21 |
cluster = NULL, # clusters? |
|
| 22 |
ov.names = NULL, # variables in model |
|
| 23 |
ov.names.x = character(0), # exo variables |
|
| 24 |
ov.names.l = list(), # names per level |
|
| 25 |
ordered = NULL, # ordered variables |
|
| 26 |
sampling.weights = NULL, # sampling weights |
|
| 27 |
sample.cov = NULL, # sample covariance(s) |
|
| 28 |
sample.mean = NULL, # sample mean vector(s) |
|
| 29 |
sample.th = NULL, # sample thresholds |
|
| 30 |
sample.nobs = NULL, # sample nobs |
|
| 31 |
lavoptions = lavOptions(), # lavoptions |
|
| 32 |
allow.single.case = FALSE # for newdata in predict |
|
| 33 |
) {
|
|
| 34 |
# get info from lavoptions |
|
| 35 | ||
| 36 |
# group.labels |
|
| 37 | 139x |
group.label <- lavoptions$group.label |
| 38 | 139x |
if (is.null(group.label)) {
|
| 39 | 139x |
group.label <- character(0L) |
| 40 |
} |
|
| 41 | ||
| 42 |
# level.labels |
|
| 43 | 139x |
level.label <- lavoptions$level.label |
| 44 | 139x |
if (is.null(level.label)) {
|
| 45 | 139x |
level.label <- character(0L) |
| 46 |
} |
|
| 47 | ||
| 48 |
# allow empty categories of ordinal variable |
|
| 49 | 139x |
allow.empty.cell <- lavoptions$allow.empty.cell |
| 50 | ||
| 51 |
# block.labels |
|
| 52 | 139x |
block.label <- character(0L) |
| 53 | 139x |
if (length(group.label) > 0L && length(level.label) == 0L) {
|
| 54 | ! |
block.label <- group.label |
| 55 | 139x |
} else if (length(level.label) > 0L && length(group.label) == 0L) {
|
| 56 | ! |
block.label <- level.label |
| 57 | 139x |
} else if (length(group.label) > 0L && |
| 58 | 139x |
length(level.label) > 0L) {
|
| 59 | ! |
block.label <- paste(rep(group.label, each = length(level.label)), |
| 60 | ! |
rep(level.label, times = length(group.label)), |
| 61 | ! |
sep = "." |
| 62 |
) |
|
| 63 |
} |
|
| 64 | ||
| 65 |
# std.ov? |
|
| 66 | 139x |
std.ov <- lavoptions$std.ov |
| 67 | 139x |
if (is.null(std.ov)) {
|
| 68 | ! |
std.ov <- FALSE |
| 69 |
} |
|
| 70 | ||
| 71 |
# missing? (lav_object_cor() does not parse options before calling lavdata...) |
|
| 72 | 139x |
missing <- tolower(lavoptions$missing) |
| 73 | 139x |
if (is.null(missing) || missing == "default") {
|
| 74 | 60x |
missing <- "listwise" |
| 75 | 79x |
} else if (missing %in% c("ml", "fiml", "direct")) {
|
| 76 | 8x |
missing <- "ml" |
| 77 | 71x |
} else if (missing %in% c("ml.x", "fiml.x", "direct.x")) {
|
| 78 | ! |
missing <- "ml.x" |
| 79 |
} |
|
| 80 | ||
| 81 |
# warn? |
|
| 82 | 139x |
if (allow.single.case) { # eg, in lavPredict
|
| 83 | ! |
current.warn <- lav_warn() |
| 84 | ! |
if (lav_warn(FALSE)) |
| 85 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 86 |
} |
|
| 87 | ||
| 88 |
# four scenarios: |
|
| 89 |
# 0) data is already a lavData object: do nothing |
|
| 90 |
# 1) data is full data.frame (or a matrix) |
|
| 91 |
# 2) data are sample statistics only |
|
| 92 |
# 3) no data at all |
|
| 93 | ||
| 94 |
# 1) full data |
|
| 95 | 139x |
if (!is.null(data)) {
|
| 96 |
# catch lavaan/lavData objects |
|
| 97 | 95x |
if (inherits(data, "lavData")) {
|
| 98 | ! |
return(data) |
| 99 | 95x |
} else if (inherits(data, "lavaan")) {
|
| 100 | 60x |
return(data@Data) |
| 101 |
} |
|
| 102 | ||
| 103 |
# catch matrix |
|
| 104 | 35x |
if (!is.data.frame(data)) {
|
| 105 |
# is it a matrix? |
|
| 106 | ! |
if (is.matrix(data)) {
|
| 107 | ! |
if (nrow(data) == ncol(data)) {
|
| 108 |
# perhaps it is a covariance matrix? |
|
| 109 | ! |
if (isSymmetric(data)) {
|
| 110 | ! |
lav_msg_warn( |
| 111 | ! |
gettext("data argument looks like a covariance matrix;
|
| 112 | ! |
please use the sample.cov argument instead")) |
| 113 |
} |
|
| 114 |
} |
|
| 115 |
# or perhaps it is a data matrix? |
|
| 116 |
### FIXME, we should avoid as.data.frame() and handle |
|
| 117 |
### data matrices directly |
|
| 118 | ! |
data <- as.data.frame(data, stringsAsFactors = FALSE) |
| 119 |
} else {
|
|
| 120 | ! |
lav_msg_stop(gettextf( |
| 121 | ! |
"data= argument is not a data.frame, but of class %s", |
| 122 | ! |
sQuote(class(data)))) |
| 123 |
} |
|
| 124 |
} |
|
| 125 | ||
| 126 |
# no ov.names? |
|
| 127 | 35x |
if (is.null(ov.names)) {
|
| 128 | ! |
ov.names <- names(data) |
| 129 |
# remove group variable, if provided |
|
| 130 | ! |
if (length(group) > 0L) {
|
| 131 | ! |
group.idx <- which(ov.names == group) |
| 132 | ! |
ov.names <- ov.names[-group.idx] |
| 133 |
} |
|
| 134 |
# remove cluster variable, if provided |
|
| 135 | ! |
if (length(cluster) > 0L) {
|
| 136 | ! |
cluster.idx <- which(ov.names == cluster) |
| 137 | ! |
ov.names <- ov.names[-cluster.idx] |
| 138 |
} |
|
| 139 |
} |
|
| 140 | ||
| 141 | 35x |
lavData <- lav_data_full( |
| 142 | 35x |
data = data, |
| 143 | 35x |
group = group, |
| 144 | 35x |
cluster = cluster, |
| 145 | 35x |
group.label = group.label, |
| 146 | 35x |
level.label = level.label, |
| 147 | 35x |
block.label = block.label, |
| 148 | 35x |
ov.names = ov.names, |
| 149 | 35x |
ordered = ordered, |
| 150 | 35x |
sampling.weights = sampling.weights, |
| 151 | 35x |
sampling.weights.normalization = |
| 152 | 35x |
lavoptions$sampling.weights.normalization, |
| 153 | 35x |
ov.names.x = ov.names.x, |
| 154 | 35x |
ov.names.l = ov.names.l, |
| 155 | 35x |
std.ov = std.ov, |
| 156 | 35x |
missing = missing, |
| 157 | 35x |
allow.single.case = allow.single.case, |
| 158 | 35x |
allow.empty.cell = allow.empty.cell |
| 159 |
) |
|
| 160 | 35x |
sample.cov <- NULL # not needed, but just in case |
| 161 |
} |
|
| 162 | ||
| 163 | ||
| 164 |
# 2) sample moments |
|
| 165 | 79x |
if (is.null(data) && !is.null(sample.cov)) {
|
| 166 |
# for now: no levels!! |
|
| 167 | 42x |
nlevels <- 1L |
| 168 | ||
| 169 |
# we also need the number of observations (per group) |
|
| 170 | 42x |
if (is.null(sample.nobs)) {
|
| 171 | ! |
lav_msg_stop(gettext("please specify number of observations"))
|
| 172 |
} |
|
| 173 | ||
| 174 |
# if a 'group' argument was provided, keep it -- new in 0.6-4 |
|
| 175 | 42x |
if (is.null(group)) {
|
| 176 | 42x |
group <- character(0L) |
| 177 | ! |
} else if (is.character(group)) {
|
| 178 |
# nothing to do, just store it |
|
| 179 |
} else {
|
|
| 180 | ! |
lav_msg_stop(gettext("group argument should be a string"))
|
| 181 |
} |
|
| 182 | ||
| 183 |
# list? |
|
| 184 | 42x |
if (is.list(sample.cov)) {
|
| 185 |
# multiple groups, multiple cov matrices |
|
| 186 | 34x |
if (!is.null(sample.mean)) {
|
| 187 | 34x |
stopifnot(length(sample.mean) == length(sample.cov)) |
| 188 |
} |
|
| 189 | 34x |
if (!is.null(sample.th)) {
|
| 190 | ! |
stopifnot(length(sample.th) == length(sample.cov)) |
| 191 |
} |
|
| 192 |
# multiple groups, multiple cov matrices |
|
| 193 | 34x |
ngroups <- length(sample.cov) |
| 194 | 34x |
LABEL <- names(sample.cov) |
| 195 | 34x |
if (is.null(group.label) || length(group.label) == 0L) {
|
| 196 | 34x |
if (is.null(LABEL)) {
|
| 197 | 32x |
group.label <- paste("Group ", 1:ngroups, sep = "")
|
| 198 |
} else {
|
|
| 199 | 2x |
group.label <- LABEL |
| 200 |
} |
|
| 201 |
} else {
|
|
| 202 | ! |
if (is.null(LABEL)) {
|
| 203 | ! |
stopifnot(length(group.label) == ngroups) |
| 204 |
} else {
|
|
| 205 |
# FIXME!!!! |
|
| 206 |
# check if they match |
|
| 207 |
} |
|
| 208 |
} |
|
| 209 |
} else {
|
|
| 210 | 8x |
ngroups <- 1L |
| 211 | 8x |
group.label <- character(0) |
| 212 | 8x |
if (!is.matrix(sample.cov)) {
|
| 213 | ! |
lav_msg_stop(gettext( |
| 214 | ! |
"sample.cov must be a matrix or a list of matrices")) |
| 215 |
} |
|
| 216 | 8x |
sample.cov <- list(sample.cov) |
| 217 |
} |
|
| 218 | ||
| 219 |
# get ov.names |
|
| 220 | 42x |
if (is.null(ov.names)) {
|
| 221 | ! |
ov.names <- lapply(sample.cov, row.names) |
| 222 | 42x |
} else if (!is.list(ov.names)) {
|
| 223 |
# duplicate ov.names for each group |
|
| 224 | 42x |
tmp <- ov.names |
| 225 | 42x |
ov.names <- vector("list", length = ngroups)
|
| 226 | 42x |
ov.names[1:ngroups] <- list(tmp) |
| 227 |
} else {
|
|
| 228 | ! |
if (length(ov.names) != ngroups) {
|
| 229 | ! |
lav_msg_stop(gettextf( |
| 230 | ! |
"ov.names assumes %1$s groups; data contains %2$s groups", |
| 231 | ! |
length(ov.names), ngroups)) |
| 232 |
} |
|
| 233 |
# nothing to do |
|
| 234 |
} |
|
| 235 | ||
| 236 |
# handle ov.names.x |
|
| 237 | 42x |
if (!is.list(ov.names.x)) {
|
| 238 | 42x |
tmp <- ov.names.x |
| 239 | 42x |
ov.names.x <- vector("list", length = ngroups)
|
| 240 | 42x |
ov.names.x[1:ngroups] <- list(tmp) |
| 241 |
} else {
|
|
| 242 | ! |
if (length(ov.names.x) != ngroups) {
|
| 243 | ! |
lav_msg_stop(gettextf( |
| 244 | ! |
"ov.names.x assumes %1$s groups; data contains %2$s groups", |
| 245 | ! |
length(ov.names.x), ngroups)) |
| 246 |
} |
|
| 247 |
} |
|
| 248 | ||
| 249 | 42x |
ov <- list() |
| 250 | 42x |
ov$name <- unique(unlist(c(ov.names, ov.names.x))) |
| 251 | 42x |
nvar <- length(ov$name) |
| 252 | 42x |
ov$idx <- rep(NA, nvar) |
| 253 | 42x |
ov$nobs <- rep(sum(unlist(sample.nobs)), nvar) |
| 254 | 42x |
ov$type <- rep("numeric", nvar)
|
| 255 | 42x |
ov$nlev <- rep(0, nvar) |
| 256 |
# check for categorical |
|
| 257 | 42x |
if (!is.null(sample.th)) {
|
| 258 | ! |
th.idx <- attr(sample.th, "th.idx") |
| 259 | ! |
if (is.list(th.idx)) {
|
| 260 | ! |
th.idx <- th.idx[[1]] ## FIRST group only (assuming same ths!) |
| 261 |
} |
|
| 262 | ! |
if (any(th.idx > 0)) {
|
| 263 | ! |
TAB <- table(th.idx[th.idx > 0]) |
| 264 | ! |
ord.idx <- as.numeric(names(TAB)) |
| 265 | ! |
nlev <- as.integer(unname(TAB) + 1) |
| 266 | ! |
ov$type[ord.idx] <- "ordered" |
| 267 | ! |
ov$nlev[ord.idx] <- nlev |
| 268 |
} |
|
| 269 |
} |
|
| 270 | ||
| 271 |
# if std.ov = TRUE, give a warning (suggested by Peter Westfall) |
|
| 272 | 42x |
if (std.ov && !lavoptions$correlation) {
|
| 273 | ! |
lav_msg_warn(gettext( |
| 274 | ! |
"std.ov argument is ignored if only sample statistics are provided.")) |
| 275 |
} |
|
| 276 | ||
| 277 |
# check variances (new in 0.6-7) |
|
| 278 | 42x |
if (!allow.single.case) {
|
| 279 | 42x |
for (g in seq_len(ngroups)) {
|
| 280 | 44x |
VAR <- diag(sample.cov[[g]]) |
| 281 |
# 1. finite? |
|
| 282 | 44x |
if (!all(is.finite(VAR))) {
|
| 283 | ! |
lav_msg_stop(gettext( |
| 284 | ! |
"at least one variance in the sample covariance matrix is not finite.")) |
| 285 |
} |
|
| 286 |
# 2. near zero (or negative)? |
|
| 287 | 44x |
if (any(VAR < .Machine$double.eps)) {
|
| 288 | ! |
lav_msg_stop( |
| 289 | ! |
gettext("at least one variance in the sample covariance matrix is
|
| 290 | ! |
(near) zero or negative.")) |
| 291 |
} |
|
| 292 |
# 3. very large? |
|
| 293 | 44x |
max.var <- max(VAR) |
| 294 | 44x |
if (max.var > 1000000) {
|
| 295 | ! |
lav_msg_warn( |
| 296 | ! |
gettext("some observed variances in the sample covariance matrix
|
| 297 | ! |
are larger than 1000000.")) |
| 298 |
} |
|
| 299 |
} |
|
| 300 |
} |
|
| 301 | ||
| 302 |
# block.labels |
|
| 303 | 42x |
block.label <- character(0L) |
| 304 | 42x |
if (length(group.label) > 0L && length(level.label) == 0L) {
|
| 305 | 34x |
block.label <- group.label |
| 306 | 8x |
} else if (length(level.label) > 0L && length(group.label) == 0L) {
|
| 307 | ! |
block.label <- level.label |
| 308 | 8x |
} else if (length(group.label) > 0L && |
| 309 | 8x |
length(level.label) > 0L) {
|
| 310 | ! |
block.label <- paste(rep(group.label, each = length(level.label)), |
| 311 | ! |
rep(level.label, times = length(group.label)), |
| 312 | ! |
sep = "." |
| 313 |
) |
|
| 314 |
} |
|
| 315 | ||
| 316 |
# construct lavData object |
|
| 317 | 42x |
lavData <- new("lavData",
|
| 318 | 42x |
data.type = "moment", |
| 319 | 42x |
ngroups = ngroups, |
| 320 | 42x |
group = group, |
| 321 | 42x |
nlevels = 1L, # for now |
| 322 | 42x |
cluster = character(0L), |
| 323 | 42x |
group.label = group.label, |
| 324 | 42x |
level.label = character(0L), |
| 325 | 42x |
block.label = block.label, |
| 326 | 42x |
nobs = as.list(sample.nobs), |
| 327 | 42x |
norig = as.list(sample.nobs), |
| 328 | 42x |
ov.names = ov.names, |
| 329 | 42x |
ov.names.x = ov.names.x, |
| 330 | 42x |
ov.names.l = ov.names.l, |
| 331 | 42x |
ordered = as.character(ordered), |
| 332 | 42x |
weights = vector("list", length = ngroups),
|
| 333 | 42x |
sampling.weights = character(0L), |
| 334 | 42x |
ov = ov, |
| 335 | 42x |
std.ov = FALSE, |
| 336 | 42x |
missing = "listwise", |
| 337 | 42x |
case.idx = vector("list", length = ngroups),
|
| 338 | 42x |
Mp = vector("list", length = ngroups),
|
| 339 | 42x |
Rp = vector("list", length = ngroups),
|
| 340 | 42x |
Lp = vector("list", length = ngroups),
|
| 341 | 42x |
X = vector("list", length = ngroups),
|
| 342 | 42x |
eXo = vector("list", length = ngroups)
|
| 343 |
) |
|
| 344 |
} |
|
| 345 | ||
| 346 |
# 3) data.type = "none": both data and sample.cov are NULL |
|
| 347 | 79x |
if (is.null(data) && is.null(sample.cov)) {
|
| 348 |
# clustered/multilevel? --> ov.names.l should be filled in |
|
| 349 | 2x |
if (length(ov.names.l) > 0L) {
|
| 350 | ! |
nlevels <- length(ov.names.l[[1]]) # we assume the same number |
| 351 |
# of levels in each group! |
|
| 352 | ||
| 353 |
# do we have a cluster argument? if not, create one |
|
| 354 | ! |
if (is.null(cluster)) {
|
| 355 | ! |
if (nlevels == 2L) {
|
| 356 | ! |
cluster <- "cluster" |
| 357 |
} else {
|
|
| 358 | ! |
cluster <- paste0("cluster", seq_len(nlevels - 1L))
|
| 359 |
} |
|
| 360 |
} |
|
| 361 | ||
| 362 |
# default level.labels |
|
| 363 | ! |
if (length(level.label) == 0L) {
|
| 364 | ! |
level.label <- c("within", cluster)
|
| 365 |
} else {
|
|
| 366 |
# check if length(level.label) = 1 + length(cluster) |
|
| 367 | ! |
if (length(level.label) != length(cluster) + 1L) {
|
| 368 | ! |
lav_msg_stop(gettext("length(level.label) != length(cluster) + 1L"))
|
| 369 |
} |
|
| 370 |
# nothing to do |
|
| 371 |
} |
|
| 372 |
} else {
|
|
| 373 | 2x |
nlevels <- 1L |
| 374 | 2x |
cluster <- character(0L) |
| 375 | 2x |
level.label <- character(0L) |
| 376 |
} |
|
| 377 | ||
| 378 |
# ngroups: ov.names (when group: is used), or sample.nobs |
|
| 379 | 2x |
if (is.null(ov.names)) {
|
| 380 | ! |
lav_msg_warn(gettext("ov.names is NULL"))
|
| 381 | ! |
ov.names <- character(0L) |
| 382 | ! |
if (is.null(sample.nobs)) {
|
| 383 | ! |
ngroups <- 1L |
| 384 | ! |
sample.nobs <- rep(list(0L), ngroups) |
| 385 |
} else {
|
|
| 386 | ! |
sample.nobs <- as.list(sample.nobs) |
| 387 | ! |
ngroups <- length(sample.nobs) |
| 388 |
} |
|
| 389 | 2x |
} else if (!is.list(ov.names)) {
|
| 390 | 2x |
if (is.null(sample.nobs)) {
|
| 391 | 1x |
ngroups <- 1L |
| 392 | 1x |
sample.nobs <- rep(list(0L), ngroups) |
| 393 |
} else {
|
|
| 394 | 1x |
sample.nobs <- as.list(sample.nobs) |
| 395 | 1x |
ngroups <- length(sample.nobs) |
| 396 |
} |
|
| 397 | 2x |
ov.names <- rep(list(ov.names), ngroups) |
| 398 | ! |
} else if (is.list(ov.names)) {
|
| 399 | ! |
ngroups <- length(ov.names) |
| 400 | ! |
if (is.null(sample.nobs)) {
|
| 401 | ! |
sample.nobs <- rep(list(0L), ngroups) |
| 402 |
} else {
|
|
| 403 | ! |
sample.nobs <- as.list(sample.nobs) |
| 404 | ! |
if (length(sample.nobs) != ngroups) {
|
| 405 | ! |
lav_msg_stop(gettextf( |
| 406 | ! |
"length(sample.nobs) = %1$s but syntax implies ngroups = %2$s", |
| 407 | ! |
length(sample.nobs), ngroups)) |
| 408 |
} |
|
| 409 |
} |
|
| 410 |
} |
|
| 411 | ||
| 412 | ||
| 413 |
# group.label |
|
| 414 | 2x |
if (ngroups > 1L) {
|
| 415 | 1x |
if (is.null(group)) {
|
| 416 | 1x |
group <- "group" |
| 417 |
} |
|
| 418 | 1x |
group.label <- paste("Group", 1:ngroups, sep = "")
|
| 419 |
} else {
|
|
| 420 | 1x |
group <- character(0L) |
| 421 | 1x |
group.label <- character(0L) |
| 422 |
} |
|
| 423 | ||
| 424 |
# handle ov.names.x |
|
| 425 | 2x |
if (!is.list(ov.names.x)) {
|
| 426 | 2x |
ov.names.x <- rep(list(ov.names.x), ngroups) |
| 427 |
} |
|
| 428 | ||
| 429 | 2x |
ov <- list() |
| 430 | 2x |
ov$name <- unique(unlist(c(ov.names, ov.names.x))) |
| 431 | 2x |
nvar <- length(ov$name) |
| 432 | 2x |
ov$idx <- rep(NA, nvar) |
| 433 | 2x |
ov$nobs <- rep(0L, nvar) |
| 434 | 2x |
ov$type <- rep("numeric", nvar)
|
| 435 | 2x |
ov$nlev <- rep(0L, nvar) |
| 436 | ||
| 437 |
# collect information per upper-level group |
|
| 438 | 2x |
Lp <- vector("list", length = ngroups)
|
| 439 | 2x |
for (g in 1:ngroups) {
|
| 440 | 3x |
if (nlevels > 1L) {
|
| 441 |
# ALWAYS add ov.names.x at the end, even if conditional.x |
|
| 442 | ! |
OV.NAMES <- unique(c(ov.names[[g]], ov.names.x[[g]])) |
| 443 | ! |
Lp[[g]] <- lav_data_cluster_patterns( |
| 444 | ! |
Y = NULL, clus = NULL, |
| 445 | ! |
cluster = cluster, |
| 446 | ! |
multilevel = TRUE, |
| 447 | ! |
ov.names = OV.NAMES, |
| 448 | ! |
ov.names.x = ov.names.x[[g]], |
| 449 | ! |
ov.names.l = ov.names.l[[g]] |
| 450 |
) |
|
| 451 |
} |
|
| 452 |
} # g |
|
| 453 | ||
| 454 |
# block.labels |
|
| 455 | 2x |
block.label <- character(0L) |
| 456 | 2x |
if (length(group.label) > 0L && length(level.label) == 0L) {
|
| 457 | 1x |
block.label <- group.label |
| 458 | 1x |
} else if (length(level.label) > 0L && length(group.label) == 0L) {
|
| 459 | ! |
block.label <- level.label |
| 460 | 1x |
} else if (length(group.label) > 0L && |
| 461 | 1x |
length(level.label) > 0L) {
|
| 462 | ! |
block.label <- paste(rep(group.label, each = length(level.label)), |
| 463 | ! |
rep(level.label, times = length(group.label)), |
| 464 | ! |
sep = "." |
| 465 |
) |
|
| 466 |
} |
|
| 467 | ||
| 468 |
# construct lavData object |
|
| 469 | 2x |
lavData <- new("lavData",
|
| 470 | 2x |
data.type = "none", |
| 471 | 2x |
ngroups = ngroups, |
| 472 | 2x |
group = group, |
| 473 | 2x |
nlevels = nlevels, |
| 474 | 2x |
cluster = cluster, |
| 475 | 2x |
group.label = group.label, |
| 476 | 2x |
level.label = level.label, |
| 477 | 2x |
block.label = block.label, |
| 478 | 2x |
nobs = sample.nobs, |
| 479 | 2x |
norig = sample.nobs, |
| 480 | 2x |
ov.names = ov.names, |
| 481 | 2x |
ov.names.x = ov.names.x, |
| 482 | 2x |
ov.names.l = ov.names.l, |
| 483 | 2x |
ordered = as.character(ordered), |
| 484 | 2x |
weights = vector("list", length = ngroups),
|
| 485 | 2x |
sampling.weights = character(0L), |
| 486 | 2x |
ov = ov, |
| 487 | 2x |
missing = "listwise", |
| 488 | 2x |
case.idx = vector("list", length = ngroups),
|
| 489 | 2x |
Mp = vector("list", length = ngroups),
|
| 490 | 2x |
Rp = vector("list", length = ngroups),
|
| 491 | 2x |
Lp = Lp, |
| 492 | 2x |
X = vector("list", length = ngroups),
|
| 493 | 2x |
eXo = vector("list", length = ngroups)
|
| 494 |
) |
|
| 495 |
} |
|
| 496 | ||
| 497 | 79x |
lavData |
| 498 |
} |
|
| 499 | ||
| 500 | ||
| 501 |
# handle full data |
|
| 502 |
lav_data_full <- function(data = NULL, # data.frame |
|
| 503 |
group = NULL, # multiple groups? |
|
| 504 |
cluster = NULL, # clustered? |
|
| 505 |
group.label = NULL, # custom group labels? |
|
| 506 |
level.label = NULL, |
|
| 507 |
block.label = NULL, |
|
| 508 |
ov.names = NULL, # variables needed |
|
| 509 |
# in model |
|
| 510 |
ordered = NULL, # ordered variables |
|
| 511 |
sampling.weights = NULL, # sampling weights |
|
| 512 |
sampling.weights.normalization = "none", |
|
| 513 |
ov.names.x = character(0L), # exo variables |
|
| 514 |
ov.names.l = list(), # var per level |
|
| 515 |
std.ov = FALSE, # standardize ov's? |
|
| 516 |
missing = "listwise", # remove missings? |
|
| 517 |
allow.single.case = FALSE, # allow single case? |
|
| 518 |
allow.empty.cell = FALSE |
|
| 519 |
) {
|
|
| 520 |
# number of groups and group labels |
|
| 521 | 35x |
if (!is.null(group) && length(group) > 0L) {
|
| 522 | 2x |
if (!(group %in% names(data))) {
|
| 523 | ! |
lav_msg_stop(gettextf( |
| 524 | ! |
"grouping variable %1$s not found; variable names |
| 525 | ! |
found in data frame are: %2$s", |
| 526 | ! |
sQuote(group),paste(names(data), collapse = " "))) |
| 527 |
} |
|
| 528 |
# note: by default, we use the order as in the data; |
|
| 529 |
# not as in levels(data[,group]) |
|
| 530 | 2x |
if (length(group.label) == 0L) {
|
| 531 | 2x |
group.label <- unique(as.character(data[[group]])) |
| 532 | 2x |
if (any(is.na(group.label))) {
|
| 533 | ! |
lav_msg_warn(gettextf("group variable %s contains missing values",
|
| 534 | ! |
sQuote(group))) |
| 535 |
} |
|
| 536 | 2x |
group.label <- group.label[!is.na(group.label)] |
| 537 |
} else {
|
|
| 538 | ! |
group.label <- unique(as.character(group.label)) |
| 539 |
# check if user-provided group labels exist |
|
| 540 | ! |
LABEL <- unique(as.character(data[[group]])) |
| 541 | ! |
idx <- match(group.label, LABEL) |
| 542 | ! |
if (any(is.na(idx))) {
|
| 543 | ! |
lav_msg_warn(gettextf( |
| 544 | ! |
"some group.labels do not appear in the grouping variable: %s", |
| 545 | ! |
lav_msg_view(group.label[which(is.na(idx))], log.sep = "none")) |
| 546 |
) |
|
| 547 |
} |
|
| 548 | ! |
group.label <- group.label[!is.na(idx)] |
| 549 |
# any groups left? |
|
| 550 | ! |
if (length(group.label) == 0L) {
|
| 551 | ! |
lav_msg_stop(gettext( |
| 552 | ! |
"no group levels left; check the group.label argument")) |
| 553 |
} |
|
| 554 |
} |
|
| 555 | 2x |
ngroups <- length(group.label) |
| 556 |
} else {
|
|
| 557 | 33x |
if (length(group.label) > 0L) {
|
| 558 | ! |
lav_msg_warn(gettext( |
| 559 | ! |
"`group.label' argument will be ignored if `group' argument is missing")) |
| 560 |
} |
|
| 561 | 33x |
ngroups <- 1L |
| 562 | 33x |
group.label <- character(0L) |
| 563 | 33x |
group <- character(0L) |
| 564 |
} |
|
| 565 | ||
| 566 |
# ensure allow.empty.cell is logical |
|
| 567 | ! |
if (is.null(allow.empty.cell)) allow.empty.cell <- FALSE |
| 568 | ||
| 569 |
# sampling weights |
|
| 570 | 35x |
if (!is.null(sampling.weights)) {
|
| 571 | ! |
if (is.character(sampling.weights)) {
|
| 572 | ! |
if (!(sampling.weights %in% names(data))) {
|
| 573 | ! |
lav_msg_stop( |
| 574 | ! |
gettextf("sampling weights variable %1$s not found;
|
| 575 | ! |
variable names found in data frame are: %2$s", |
| 576 | ! |
sQuote(sampling.weights), paste(names(data), collapse = " "))) |
| 577 |
} |
|
| 578 |
# check for missing values in sampling weight variable |
|
| 579 | ! |
if (any(is.na(data[[sampling.weights]]))) {
|
| 580 | ! |
lav_msg_stop( |
| 581 | ! |
gettextf("sampling.weights variable %s contains missing values",
|
| 582 | ! |
sQuote(sampling.weights))) |
| 583 |
} |
|
| 584 |
} else {
|
|
| 585 | ! |
lav_msg_stop(gettext( |
| 586 | ! |
"sampling weights argument should be a variable name in the data.frame" |
| 587 |
)) |
|
| 588 |
} |
|
| 589 |
} |
|
| 590 | ||
| 591 |
# clustered? |
|
| 592 | 35x |
if (!is.null(cluster) && length(cluster) > 0L) {
|
| 593 |
# cluster variable in data? |
|
| 594 | 2x |
if (!all(cluster %in% names(data))) {
|
| 595 |
# which one did we not find? |
|
| 596 | ! |
not.ok <- which(!cluster %in% names(data)) |
| 597 | ! |
lav_msg_stop(gettextf( |
| 598 | ! |
"cluster variable(s) %1$s not found; |
| 599 | ! |
variable names found in data frame are: %2$s", |
| 600 | ! |
sQuote(cluster[not.ok]), paste(names(data), collapse = " "))) |
| 601 |
} |
|
| 602 | ||
| 603 |
# check for missing values in cluster variable(s) |
|
| 604 | 2x |
for (cl in 1:length(cluster)) {
|
| 605 | 2x |
if (anyNA(data[[cluster[cl]]])) {
|
| 606 | ! |
lav_msg_warn(gettextf("cluster variable %s contains missing values",
|
| 607 | ! |
sQuote(cluster[cl]))) |
| 608 |
} |
|
| 609 |
} |
|
| 610 | ||
| 611 |
# multilevel? |
|
| 612 | 2x |
if (length(ov.names.l) > 0L) {
|
| 613 |
# default level.labels |
|
| 614 | 2x |
if (length(level.label) == 0L) {
|
| 615 | 2x |
level.label <- c("within", cluster)
|
| 616 |
} else {
|
|
| 617 |
# check if length(level.label) = 1 + length(cluster) |
|
| 618 | ! |
if (length(level.label) != length(cluster) + 1L) {
|
| 619 | ! |
lav_msg_stop(gettext("length(level.label) != length(cluster) + 1L"))
|
| 620 |
} |
|
| 621 |
# nothing to do |
|
| 622 |
} |
|
| 623 | 2x |
nlevels <- length(level.label) |
| 624 |
} else {
|
|
| 625 |
# just clustered data, but no random effects |
|
| 626 | ! |
nlevels <- 1L |
| 627 | ! |
level.label <- character(0L) |
| 628 |
} |
|
| 629 |
} else {
|
|
| 630 | 33x |
if (length(level.label) > 0L) {
|
| 631 | ! |
lav_msg_warn(gettext( |
| 632 | ! |
"`level.label' argument will be ignored if `cluster' argument is missing" |
| 633 |
)) |
|
| 634 |
} |
|
| 635 | 33x |
nlevels <- 1L |
| 636 | 33x |
level.label <- character(0L) |
| 637 | 33x |
cluster <- character(0L) |
| 638 |
} |
|
| 639 | ||
| 640 |
# check ov.names vs ngroups |
|
| 641 | 35x |
if (ngroups > 1L) {
|
| 642 | 2x |
if (is.list(ov.names)) {
|
| 643 | 2x |
if (length(ov.names) != ngroups) {
|
| 644 | ! |
lav_msg_stop(gettextf( |
| 645 | ! |
"ov.names assumes %1$s groups; data contains %2$s groups", |
| 646 | ! |
length(ov.names), ngroups)) |
| 647 |
} |
|
| 648 |
} else {
|
|
| 649 | ! |
tmp <- ov.names |
| 650 | ! |
ov.names <- vector("list", length = ngroups)
|
| 651 | ! |
ov.names[1:ngroups] <- list(tmp) |
| 652 |
} |
|
| 653 | 2x |
if (is.list(ov.names.x)) {
|
| 654 | ! |
if (length(ov.names.x) != ngroups) {
|
| 655 | ! |
lav_msg_stop(gettextf( |
| 656 | ! |
"ov.names.x assumes %1$s groups; data contains %2$s groups", |
| 657 | ! |
length(ov.names.x), ngroups)) |
| 658 |
} |
|
| 659 |
} else {
|
|
| 660 | 2x |
tmp <- ov.names.x |
| 661 | 2x |
ov.names.x <- vector("list", length = ngroups)
|
| 662 | 2x |
ov.names.x[1:ngroups] <- list(tmp) |
| 663 |
} |
|
| 664 |
} else {
|
|
| 665 | 33x |
if (is.list(ov.names)) {
|
| 666 | ! |
if (length(ov.names) > 1L) {
|
| 667 | ! |
lav_msg_stop(gettext( |
| 668 | ! |
"model syntax defines multiple groups; data suggests a single group")) |
| 669 |
} |
|
| 670 |
} else {
|
|
| 671 | 33x |
ov.names <- list(ov.names) |
| 672 |
} |
|
| 673 | 33x |
if (is.list(ov.names.x)) {
|
| 674 | ! |
if (length(ov.names.x) > 1L) {
|
| 675 | ! |
lav_msg_stop(gettext( |
| 676 | ! |
"model syntax defines multiple groups; data suggests a single group")) |
| 677 |
} |
|
| 678 |
} else {
|
|
| 679 | 33x |
ov.names.x <- list(ov.names.x) |
| 680 |
} |
|
| 681 |
} |
|
| 682 | ||
| 683 |
# check if all ov.names can be found in the data.frame |
|
| 684 | 35x |
for (g in 1:ngroups) {
|
| 685 |
# does the data contain all the observed variables |
|
| 686 |
# needed in the user-specified model for this group |
|
| 687 | 37x |
ov.all <- unique(c(ov.names[[g]], ov.names.x[[g]])) # no overlap if categ |
| 688 | ||
| 689 |
# handle interactions |
|
| 690 | 37x |
ov.int.names <- ov.all[grepl(":", ov.all)]
|
| 691 | 37x |
n.int <- length(ov.int.names) |
| 692 | 37x |
if (n.int > 0L) {
|
| 693 | ! |
ov.names.noint <- ov.all[!ov.all %in% ov.int.names] |
| 694 | ! |
for (iv in seq_len(n.int)) {
|
| 695 | ! |
NAMES <- strsplit(ov.int.names[iv], ":", fixed = TRUE)[[1L]] |
| 696 | ! |
if (all(NAMES %in% ov.names.noint)) {
|
| 697 |
# add this interaction term to the data.frame, unless |
|
| 698 |
# it already exists |
|
| 699 | ! |
if (is.null(data[[ov.int.names[iv]]])) {
|
| 700 | ! |
data[[ov.int.names[iv]]] <- |
| 701 | ! |
data[[NAMES[1L]]] * data[[NAMES[2L]]] |
| 702 |
} |
|
| 703 |
} |
|
| 704 |
} |
|
| 705 |
} |
|
| 706 | ||
| 707 |
# check for missing observed variables |
|
| 708 | 37x |
idx.missing <- which(!(ov.all %in% names(data))) |
| 709 | ||
| 710 | 37x |
if (length(idx.missing)) {
|
| 711 | ! |
lav_msg_stop( |
| 712 | ! |
gettextf("some (observed) variables specified in the model are
|
| 713 | ! |
not found in the dataset: %s", |
| 714 | ! |
paste(ov.all[idx.missing], collapse = " "))) |
| 715 |
} |
|
| 716 |
} |
|
| 717 | ||
| 718 | ||
| 719 |
# here, we know for sure all ov.names exist in the data.frame |
|
| 720 |
# create varTable |
|
| 721 |
# FIXME: should we add the 'group'/'cluster' variable (no for now) |
|
| 722 | 35x |
ov <- lav_dataframe_vartable( |
| 723 | 35x |
frame = data, ov.names = ov.names, |
| 724 | 35x |
ov.names.x = ov.names.x, ordered = ordered, |
| 725 | 35x |
as.data.frame. = FALSE, allow.empty.cell = allow.empty.cell |
| 726 |
) |
|
| 727 | ||
| 728 |
# do some checking |
|
| 729 |
# check for unordered factors (but only if nlev > 2) |
|
| 730 | 35x |
if ("factor" %in% ov$type) {
|
| 731 | ! |
f.names <- ov$name[ov$type == "factor" & ov$nlev > 2L] |
| 732 | ! |
f.names.all <- ov$name[ov$type == "factor"] |
| 733 | ! |
OV.names <- unlist(ov.names) |
| 734 | ! |
OV.names.x <- unlist(ov.names.x) |
| 735 | ! |
OV.names.nox <- OV.names[!OV.names %in% OV.names.x] |
| 736 | ! |
if (any(f.names %in% OV.names.x)) {
|
| 737 | ! |
lav_msg_stop( |
| 738 | ! |
gettext("unordered factor(s) with more than 2 levels detected
|
| 739 | ! |
as exogenous covariate(s): "), |
| 740 | ! |
paste(f.names, collapse = " ")) |
| 741 | ! |
} else if (any(f.names.all %in% OV.names.nox)) {
|
| 742 | ! |
lav_msg_stop( |
| 743 | ! |
gettext("unordered factor(s) detected; make them numeric or ordered:"),
|
| 744 | ! |
paste(f.names.all, collapse = " ")) |
| 745 |
} |
|
| 746 |
} |
|
| 747 |
# check for ordered exogenous variables |
|
| 748 | 35x |
if ("ordered" %in% ov$type[ov$name %in% unlist(ov.names.x)]) {
|
| 749 | ! |
f.names <- ov$name[ov$type == "ordered" & |
| 750 | ! |
ov$name %in% unlist(ov.names.x)] |
| 751 | ! |
if (any(f.names %in% unlist(ov.names.x))) {
|
| 752 | ! |
lav_msg_warn(gettextf( |
| 753 | ! |
"exogenous variable(s) declared as ordered in data: %s", |
| 754 | ! |
lav_msg_view(f.names, log.sep = "none"))) |
| 755 |
} |
|
| 756 |
} |
|
| 757 |
# check for ordered endogenous variables with more than 12 levels |
|
| 758 | 35x |
if ("ordered" %in% ov$type[!ov$name %in% unlist(ov.names.x)]) {
|
| 759 | 2x |
f.names <- ov$name[ov$type == "ordered" & |
| 760 | 2x |
!ov$name %in% unlist(ov.names.x) & |
| 761 | 2x |
ov$nlev > 12L] |
| 762 | 2x |
if (length(f.names) > 0L) {
|
| 763 | ! |
lav_msg_warn(gettextf( |
| 764 | ! |
"some ordered categorical variable(s) have more than 12 levels: %s", |
| 765 | ! |
lav_msg_view(f.names, log.sep = "none"))) |
| 766 |
} |
|
| 767 |
} |
|
| 768 |
# check for zero-cases |
|
| 769 | 35x |
idx <- which(ov$nobs == 0L | ov$var == 0) |
| 770 | 35x |
if (!allow.single.case && length(idx) > 0L) {
|
| 771 | ! |
OV <- as.data.frame(ov) |
| 772 | ! |
rn <- rownames(OV) |
| 773 | ! |
rn[idx] <- paste(rn[idx], "***", sep = "") |
| 774 | ! |
rownames(OV) <- rn |
| 775 | ! |
print(OV) |
| 776 | ! |
lav_msg_stop(gettext( |
| 777 | ! |
"some variables have no values (only missings) or no variance")) |
| 778 |
} |
|
| 779 |
# check for single cases (no variance!) |
|
| 780 | 35x |
idx <- which(ov$nobs == 1L | (ov$type == "numeric" & !is.finite(ov$var))) |
| 781 | 35x |
if (!allow.single.case && length(idx) > 0L) {
|
| 782 | ! |
OV <- as.data.frame(ov) |
| 783 | ! |
rn <- rownames(OV) |
| 784 | ! |
rn[idx] <- paste(rn[idx], "***", sep = "") |
| 785 | ! |
rownames(OV) <- rn |
| 786 | ! |
print(OV) |
| 787 | ! |
lav_msg_stop(gettext( |
| 788 | ! |
"some variables have only 1 observation or no finite variance")) |
| 789 |
} |
|
| 790 |
# check for ordered variables with only 1 level |
|
| 791 | 35x |
idx <- which(ov$type == "ordered" & ov$nlev == 1L) |
| 792 | 35x |
if (!allow.single.case && length(idx) > 0L) {
|
| 793 | ! |
OV <- as.data.frame(ov) |
| 794 | ! |
rn <- rownames(OV) |
| 795 | ! |
rn[idx] <- paste(rn[idx], "***", sep = "") |
| 796 | ! |
rownames(OV) <- rn |
| 797 | ! |
print(OV) |
| 798 | ! |
lav_msg_stop(gettext("ordered variable(s) has/have only 1 level"))
|
| 799 |
} |
|
| 800 |
# check for mix small/large variances (NOT including exo variables) |
|
| 801 | 35x |
if (!std.ov && !allow.single.case && any(ov$type == "numeric")) {
|
| 802 | 35x |
num.idx <- which(ov$type == "numeric" & ov$exo == 0L) |
| 803 | 35x |
if (length(num.idx) > 0L) {
|
| 804 | 35x |
min.var <- min(ov$var[num.idx]) |
| 805 | 35x |
max.var <- max(ov$var[num.idx]) |
| 806 | 35x |
rel.var <- max.var / min.var |
| 807 | 35x |
if (rel.var > 1000) {
|
| 808 | 2x |
lav_msg_warn( |
| 809 | 2x |
gettext("some observed variances are (at least) a factor 1000 times
|
| 810 | 2x |
larger than others; use varTable(fit) to investigate")) |
| 811 |
} |
|
| 812 |
} |
|
| 813 |
} |
|
| 814 |
# check for really large variances (perhaps -999999 for missing?) |
|
| 815 | 35x |
if (!allow.single.case && !std.ov && any(ov$type == "numeric")) {
|
| 816 | 35x |
num.idx <- which(ov$type == "numeric" & ov$exo == 0L) |
| 817 | 35x |
if (length(num.idx) > 0L) {
|
| 818 | 35x |
max.var <- max(ov$var[num.idx]) |
| 819 | 35x |
if (max.var > 1000000) {
|
| 820 | ! |
lav_msg_warn( |
| 821 | ! |
gettext("some observed variances are larger than 1000000
|
| 822 | ! |
use varTable(fit) to investigate")) |
| 823 |
} |
|
| 824 |
} |
|
| 825 |
} |
|
| 826 |
# check for all-exogenous variables (eg in f <~ x1 + x2 + x3) |
|
| 827 | 35x |
if (all(ov$exo == 1L)) {
|
| 828 | ! |
lav_msg_warn(gettext( |
| 829 | ! |
"all observed variables are exogenous; model may not be identified")) |
| 830 |
} |
|
| 831 |
# check for perfect correlations (NOT including exo variables) |
|
| 832 | 35x |
if (!allow.single.case && any(ov$type == "numeric")) {
|
| 833 | 35x |
num.idx <- which(ov$type == "numeric" & ov$exo == 0L) |
| 834 | 35x |
COR <- try(cor(data[,ov$idx[num.idx]], use = "pairwise.complete.obs"), |
| 835 | 35x |
silent = TRUE) |
| 836 |
# replace any NAs by 0 (as we only wish to detect perfect correlations) |
|
| 837 | 35x |
COR[is.na(COR)] <- 0 |
| 838 | 35x |
if (!inherits(COR, "try-error") && |
| 839 | 35x |
any(lav_matrix_vech(COR, diagonal = FALSE) == 1)) {
|
| 840 | ! |
COR[upper.tri(COR, diag = TRUE)] <- 0 |
| 841 | ! |
idx <- which(COR == 1) |
| 842 | ! |
this.names <- ov$name[num.idx] |
| 843 | ! |
bad.names <- this.names[ sort(unique(c(row(COR)[idx], col(COR)[idx]))) ] |
| 844 |
# should we make this a hard stop? things will most likely fail later... |
|
| 845 | ! |
lav_msg_warn(gettextf( |
| 846 | ! |
"some observed variables are perfectly correlated; |
| 847 | ! |
please check your data; variables involved are: %s", |
| 848 | ! |
paste(bad.names, collapse = " "))) |
| 849 |
} |
|
| 850 |
} |
|
| 851 | ||
| 852 |
# prepare empty lists |
|
| 853 | ||
| 854 |
# group-based |
|
| 855 | 35x |
case.idx <- vector("list", length = ngroups)
|
| 856 | 35x |
Mp <- vector("list", length = ngroups)
|
| 857 | 35x |
Rp <- vector("list", length = ngroups)
|
| 858 | 35x |
norig <- vector("list", length = ngroups)
|
| 859 | 35x |
nobs <- vector("list", length = ngroups)
|
| 860 | 35x |
X <- vector("list", length = ngroups)
|
| 861 | 35x |
eXo <- vector("list", length = ngroups)
|
| 862 | 35x |
Lp <- vector("list", length = ngroups)
|
| 863 | 35x |
weights <- vector("list", length = ngroups)
|
| 864 | ||
| 865 |
# collect information per upper-level group |
|
| 866 |
# datam <- data.matrix(data) # YR: not yet, this breaks the stuart package! |
|
| 867 | 35x |
for (g in 1:ngroups) {
|
| 868 |
# extract variables in correct order |
|
| 869 | 37x |
if (nlevels > 1L) {
|
| 870 |
# keep 'joint' (Y,X) matrix in @X if multilevel (or always?) |
|
| 871 |
# yes for multilevel (for now); no for clustered only |
|
| 872 | 4x |
OV.NAMES <- unique(c(ov.names[[g]], ov.names.x[[g]])) |
| 873 | 4x |
ov.idx <- ov$idx[match(OV.NAMES, ov$name)] |
| 874 |
} else {
|
|
| 875 | 33x |
ov.idx <- ov$idx[match(ov.names[[g]], ov$name)] |
| 876 |
} |
|
| 877 | 37x |
exo.idx <- ov$idx[match(ov.names.x[[g]], ov$name)] |
| 878 | 37x |
all.idx <- unique(c(ov.idx, exo.idx)) |
| 879 | ||
| 880 |
# extract cases per group |
|
| 881 | 37x |
if (ngroups > 1L || length(group.label) > 0L) {
|
| 882 | 4x |
if (missing == "listwise") {
|
| 883 | 4x |
case.idx[[g]] <- which(data[[group]] == group.label[g] & |
| 884 | 4x |
complete.cases(data[all.idx])) |
| 885 | 4x |
nobs[[g]] <- length(case.idx[[g]]) |
| 886 | 4x |
norig[[g]] <- length(which(data[[group]] == group.label[g])) |
| 887 |
# check for empty data |
|
| 888 | 4x |
if (nobs[[g]] == 0L) {
|
| 889 | ! |
lav_msg_stop(gettextf("all observations were deleted due to missing
|
| 890 | ! |
data after listwise deletion in group [%s]; |
| 891 | ! |
check your data |
| 892 | ! |
or consider a different option for the missing= argument.", group.label[g])) |
| 893 |
} |
|
| 894 |
# } else if(missing == "pairwise" && length(exo.idx) > 0L) {
|
|
| 895 |
# case.idx[[g]] <- which(data[[group]] == group.label[g] & |
|
| 896 |
# complete.cases(data[exo.idx])) |
|
| 897 |
# nobs[[g]] <- length(case.idx[[g]]) |
|
| 898 |
# norig[[g]] <- length(which(data[[group]] == group.label[g])) |
|
| 899 | ! |
} else if (length(exo.idx) > 0L && missing != "ml.x") {
|
| 900 | ! |
case.idx[[g]] <- which(data[[group]] == group.label[g] & |
| 901 | ! |
complete.cases(data[exo.idx])) |
| 902 | ! |
nobs[[g]] <- length(case.idx[[g]]) |
| 903 | ! |
norig[[g]] <- length(which(data[[group]] == group.label[g])) |
| 904 | ! |
if ((nobs[[g]] < norig[[g]])) {
|
| 905 | ! |
lav_msg_warn(gettextf( |
| 906 | ! |
"%1$s cases were deleted in group %2$s due to missing values |
| 907 | ! |
in exogenous variable(s), while fixed.x = TRUE.", |
| 908 | ! |
(norig[[g]] - nobs[[g]]), group.label[g])) |
| 909 |
} |
|
| 910 |
} else {
|
|
| 911 | ! |
case.idx[[g]] <- which(data[[group]] == group.label[g]) |
| 912 | ! |
nobs[[g]] <- norig[[g]] <- length(case.idx[[g]]) |
| 913 |
} |
|
| 914 |
} else {
|
|
| 915 | 33x |
if (missing == "listwise") {
|
| 916 | 23x |
case.idx[[g]] <- which(complete.cases(data[all.idx])) |
| 917 | 23x |
nobs[[g]] <- length(case.idx[[g]]) |
| 918 | 23x |
norig[[g]] <- nrow(data) |
| 919 | 23x |
if (nobs[[g]] == 0L) {
|
| 920 | ! |
lav_msg_stop(gettext("all observations were deleted due to missing
|
| 921 | ! |
data after listwise deletion; |
| 922 | ! |
check your data |
| 923 | ! |
or consider a different option for the missing= argument.")) |
| 924 |
} |
|
| 925 |
# } else if(missing == "pairwise" && length(exo.idx) > 0L) {
|
|
| 926 |
# case.idx[[g]] <- which(complete.cases(data[exo.idx])) |
|
| 927 |
# nobs[[g]] <- length(case.idx[[g]]) |
|
| 928 |
# norig[[g]] <- nrow(data) |
|
| 929 | 10x |
} else if (length(exo.idx) > 0L && missing != "ml.x") {
|
| 930 | 8x |
case.idx[[g]] <- which(complete.cases(data[exo.idx])) |
| 931 | 8x |
nobs[[g]] <- length(case.idx[[g]]) |
| 932 | 8x |
norig[[g]] <- nrow(data) |
| 933 | 8x |
if ((nobs[[g]] < norig[[g]])) {
|
| 934 | 8x |
lav_msg_warn( |
| 935 | 8x |
gettextf("%s cases were deleted due to missing values in
|
| 936 | 8x |
exogenous variable(s), while fixed.x = TRUE.", |
| 937 | 8x |
(norig[[g]] - nobs[[g]]))) |
| 938 |
} |
|
| 939 |
} else {
|
|
| 940 | 2x |
case.idx[[g]] <- 1:nrow(data) |
| 941 | 2x |
nobs[[g]] <- norig[[g]] <- length(case.idx[[g]]) |
| 942 |
} |
|
| 943 |
} |
|
| 944 | ||
| 945 |
# extract data |
|
| 946 |
#X[[g]] <- datam[case.idx[[g]], ov.idx, drop = FALSE] |
|
| 947 | 37x |
X[[g]] <- data.matrix(data[case.idx[[g]], ov.idx, drop = FALSE]) |
| 948 | 37x |
dimnames(X[[g]]) <- NULL ### copy? |
| 949 | ||
| 950 |
# sampling weights (but no normalization yet) |
|
| 951 | 37x |
if (!is.null(sampling.weights)) {
|
| 952 | ! |
WT <- data[[sampling.weights]][case.idx[[g]]] |
| 953 | ! |
if (any(WT < 0)) {
|
| 954 | ! |
lav_msg_stop(gettext("some sampling weights are negative"))
|
| 955 |
} |
|
| 956 | ||
| 957 |
# check for missing values in sampling weight variable |
|
| 958 | ! |
if (any(is.na(WT))) {
|
| 959 | ! |
lav_msg_stop(gettextf( |
| 960 | ! |
"sampling.weights variable %s contains missing values", |
| 961 | ! |
sQuote(sampling.weights))) |
| 962 |
} |
|
| 963 | ||
| 964 | ! |
weights[[g]] <- WT |
| 965 |
} |
|
| 966 | ||
| 967 |
# construct integers for user-declared 'ordered' factors |
|
| 968 |
# FIXME: is this really (always) needed??? |
|
| 969 |
# (but still better than doing lapply(data[,idx], ordered) which |
|
| 970 |
# generated even more copies) |
|
| 971 | 37x |
user.ordered.names <- ov$name[ov$type == "ordered" & ov$user == 1L] |
| 972 | 37x |
user.ordered.idx <- which(ov.names[[g]] %in% user.ordered.names) |
| 973 | 37x |
if (length(user.ordered.idx) > 0L) {
|
| 974 | 2x |
for (i in user.ordered.idx) {
|
| 975 | 8x |
X[[g]][, i][is.na(X[[g]][, i])] <- NA # change NaN to NA |
| 976 | 8x |
if (!allow.empty.cell) X[[g]][, i] <- as.numeric(as.factor(X[[g]][, i])) |
| 977 |
# possible alternative to the previous two lines: |
|
| 978 |
# X[[g]][,i] <- as.numeric(factor(X[[g]][,i], exclude = c(NA, NaN))) |
|
| 979 |
} |
|
| 980 |
} |
|
| 981 | ||
| 982 |
## FIXME: |
|
| 983 |
## - why also in X? (for samplestats, for now) |
|
| 984 | 37x |
if (length(exo.idx) > 0L) {
|
| 985 | 12x |
eXo[[g]] <- data.matrix(data[case.idx[[g]], exo.idx, drop = FALSE]) |
| 986 | 12x |
dimnames(eXo[[g]]) <- NULL |
| 987 |
} else {
|
|
| 988 | 25x |
eXo[g] <- list(NULL) |
| 989 |
} |
|
| 990 | ||
| 991 |
# standardize observed variables? numeric only! |
|
| 992 | 37x |
if (std.ov) {
|
| 993 | ! |
num.idx <- which(ov$name %in% ov.names[[g]] & |
| 994 | ! |
ov$type == "numeric" & ov$exo == 0L) |
| 995 | ! |
if (length(num.idx) > 0L) {
|
| 996 | ! |
X[[g]][, num.idx] <- |
| 997 | ! |
scale(X[[g]][, num.idx, drop = FALSE])[, , drop = FALSE] |
| 998 |
# three copies are made!!!!! |
|
| 999 |
} |
|
| 1000 | ! |
if (length(exo.idx) > 0L) {
|
| 1001 | ! |
eXo[[g]] <- scale(eXo[[g]])[, , drop = FALSE] |
| 1002 |
} |
|
| 1003 |
} |
|
| 1004 | ||
| 1005 |
# response patterns (ordered variables only) |
|
| 1006 | 37x |
ord.idx <- which(ov.names[[g]] %in% ov$name[ov$type == "ordered"]) |
| 1007 | 37x |
if (length(ord.idx) > 0L) {
|
| 1008 | 2x |
Rp[[g]] <- lav_data_resp_patterns(X[[g]][, ord.idx, drop = FALSE]) |
| 1009 |
} |
|
| 1010 | ||
| 1011 |
# warn if we have a small number of observations (but NO error!) |
|
| 1012 | 37x |
if (!allow.single.case && |
| 1013 | 37x |
nobs[[g]] < (nvar <- length(ov.idx))) {
|
| 1014 | ! |
txt <- "" |
| 1015 | ! |
if (ngroups > 1L) txt <- gettextf("in group %s", g)
|
| 1016 | ! |
lav_msg_warn( |
| 1017 | ! |
gettextf("small number of observations (nobs < nvar) %1$s:
|
| 1018 | ! |
nobs = %2$s nvar = %3$s", txt, nobs[[g]], nvar)) |
| 1019 |
} |
|
| 1020 |
# check variances per group (if we have multiple groups) |
|
| 1021 |
# to catch zero-variance variables within a group (new in 0.6-8) |
|
| 1022 | 37x |
if (ngroups > 1L && !allow.empty.cell) {
|
| 1023 |
# X |
|
| 1024 | 4x |
group.var <- apply(X[[g]], 2, var, na.rm = TRUE) |
| 1025 | 4x |
zero.var <- which(group.var < .Machine$double.eps) |
| 1026 | 4x |
if (length(zero.var) == 0L) {
|
| 1027 |
# all is good |
|
| 1028 |
} else {
|
|
| 1029 |
# some zero variances! |
|
| 1030 | ! |
gtxt <- if (ngroups > 1L) {
|
| 1031 | ! |
gettextf("in group %s", g)
|
| 1032 |
} else {
|
|
| 1033 |
"" |
|
| 1034 |
} |
|
| 1035 | ! |
lav_msg_stop( |
| 1036 | ! |
gettext("some variables have no variance"), gtxt,
|
| 1037 | ! |
":", paste(ov.names[[g]][zero.var], collapse = " ")) |
| 1038 |
} |
|
| 1039 | ||
| 1040 |
# eXo (if conditional.x = TRUE)... |
|
| 1041 | 4x |
if (length(exo.idx) > 0L) {
|
| 1042 | ! |
group.var <- apply(eXo[[g]], 2, var, na.rm = TRUE) |
| 1043 | ! |
zero.var <- which(group.var < .Machine$double.eps) |
| 1044 | ! |
if (length(zero.var) == 0L) {
|
| 1045 |
# all is good |
|
| 1046 |
} else {
|
|
| 1047 |
# some zero variances! |
|
| 1048 | ! |
gtxt <- if (ngroups > 1L) {
|
| 1049 | ! |
gettextf("in group %s", g)
|
| 1050 |
} else {
|
|
| 1051 |
"" |
|
| 1052 |
} |
|
| 1053 | ! |
lav_msg_stop( |
| 1054 | ! |
gettext("some exogenous variables have no variance"), gtxt,
|
| 1055 | ! |
":", paste(ov.names.x[[g]][zero.var], collapse = " ") |
| 1056 |
) |
|
| 1057 |
} |
|
| 1058 |
} |
|
| 1059 |
} |
|
| 1060 | ||
| 1061 |
# cluster information |
|
| 1062 | 37x |
if (length(cluster) > 0L) {
|
| 1063 |
# extract cluster variable(s), for this group |
|
| 1064 | 4x |
clus <- data.matrix(data[case.idx[[g]], cluster]) |
| 1065 | 4x |
if (nlevels > 1L) {
|
| 1066 | 4x |
multilevel <- TRUE |
| 1067 |
} else {
|
|
| 1068 | ! |
multilevel <- FALSE |
| 1069 |
} |
|
| 1070 |
# ALWAYS add ov.names.x at the end, even if conditional.x (0.6-7) |
|
| 1071 | 4x |
OV.NAMES <- unique(c(ov.names[[g]], ov.names.x[[g]])) |
| 1072 | 4x |
Lp[[g]] <- lav_data_cluster_patterns( |
| 1073 | 4x |
Y = X[[g]], clus = clus, |
| 1074 | 4x |
cluster = cluster, |
| 1075 | 4x |
multilevel = multilevel, |
| 1076 | 4x |
ov.names = OV.NAMES, |
| 1077 | 4x |
ov.names.x = ov.names.x[[g]], |
| 1078 | 4x |
ov.names.l = ov.names.l[[g]] |
| 1079 |
) |
|
| 1080 | ||
| 1081 |
# new in 0.6-4 |
|
| 1082 |
# check for 'level-1' variables with zero within variance |
|
| 1083 | 4x |
l1.idx <- c( |
| 1084 | 4x |
Lp[[g]]$within.idx[[2]], # within only |
| 1085 | 4x |
Lp[[g]]$both.idx[[2]] |
| 1086 |
) |
|
| 1087 | 4x |
for (v in l1.idx) {
|
| 1088 | 12x |
within.var <- tapply(X[[g]][, v], Lp[[g]]$cluster.idx[[2]], |
| 1089 | 12x |
FUN = var, na.rm = TRUE |
| 1090 |
) |
|
| 1091 |
# ignore singletons |
|
| 1092 | 12x |
singleton.idx <- which(Lp[[g]]$cluster.size[[2]] == 1L) |
| 1093 | 12x |
if (length(singleton.idx) > 0L) {
|
| 1094 | ! |
within.var[singleton.idx] <- 10 # non-zero variance |
| 1095 |
} |
|
| 1096 | 12x |
zero.var <- which(within.var < .Machine$double.eps) |
| 1097 | 12x |
if (length(zero.var) == 0L) {
|
| 1098 |
# all is good |
|
| 1099 | ! |
} else if (length(zero.var) == length(within.var)) {
|
| 1100 |
# all zero! possibly a between-level variable |
|
| 1101 | ! |
gtxt <- if (ngroups > 1L) {
|
| 1102 | ! |
gettextf("in group %s", g)
|
| 1103 |
} else {
|
|
| 1104 |
"" |
|
| 1105 |
} |
|
| 1106 | ! |
lav_msg_warn( |
| 1107 | ! |
gettextf("Level-1 variable %1$s has no variance at the within
|
| 1108 | ! |
level %2$s. The variable appears to be a between-level |
| 1109 | ! |
variable. Please remove this variable from the level 1 |
| 1110 | ! |
section in the model syntax.", |
| 1111 | ! |
dQuote(ov.names[[g]][v]), gtxt)) |
| 1112 |
} else {
|
|
| 1113 |
# some zero variances! |
|
| 1114 | ! |
gtxt <- if (ngroups > 1L) {
|
| 1115 | ! |
gettextf("in group %s", g)
|
| 1116 |
} else {
|
|
| 1117 |
"" |
|
| 1118 |
} |
|
| 1119 | ! |
lav_msg_warn(gettextf( |
| 1120 | ! |
"Level-1 variable %1$s has no variance within some clusters %2$s. |
| 1121 | ! |
The cluster ids with zero within variance are: %3$s.", |
| 1122 | ! |
dQuote(ov.names[[g]][v]), gtxt, |
| 1123 | ! |
lav_msg_view(Lp[[g]]$cluster.id[[2]][zero.var], "none"))) |
| 1124 |
} |
|
| 1125 |
} |
|
| 1126 | ||
| 1127 |
# new in 0.6-4 |
|
| 1128 |
# check for 'level-2' only variables with non-zero within variance |
|
| 1129 | 4x |
l2.idx <- Lp[[g]]$between.idx[[2]] # between only |
| 1130 | 4x |
error.flag <- FALSE |
| 1131 | 4x |
for (v in l2.idx) {
|
| 1132 | ! |
within.var <- tapply(X[[g]][, v], Lp[[g]]$cluster.idx[[2]], |
| 1133 | ! |
FUN = var, na.rm = TRUE |
| 1134 |
) |
|
| 1135 | ! |
non.zero.var <- which(unname(within.var) > .Machine$double.eps) |
| 1136 | ! |
if (length(non.zero.var) == 0L) {
|
| 1137 |
# all is good |
|
| 1138 | ! |
} else if (length(non.zero.var) == 1L) {
|
| 1139 |
# just one |
|
| 1140 | ! |
gtxt <- if (ngroups > 1L) {
|
| 1141 | ! |
gettextf("in group %s.", g)
|
| 1142 |
} else {
|
|
| 1143 |
"." |
|
| 1144 |
} |
|
| 1145 | ! |
lav_msg_warn(gettextf( |
| 1146 | ! |
"Level-2 variable %1$ss has non-zero variance at the within |
| 1147 | ! |
level %2$s in one cluster with id: %3$ss. Please double-check |
| 1148 | ! |
if this is a between only variable.", |
| 1149 | ! |
dQuote(ov.names[[g]][v]), gtxt, |
| 1150 | ! |
Lp[[g]]$cluster.id[[2]][non.zero.var])) |
| 1151 |
} else {
|
|
| 1152 | ! |
error.flag <- TRUE |
| 1153 |
# several |
|
| 1154 | ! |
gtxt <- if (ngroups > 1L) {
|
| 1155 | ! |
gettextf("in group %s", g)
|
| 1156 |
} else {
|
|
| 1157 |
"" |
|
| 1158 |
} |
|
| 1159 | ! |
lav_msg_warn(gettextf( |
| 1160 | ! |
"Level-2 variable %1$s has non-zero variance at the within level |
| 1161 | ! |
%2$s. The cluster ids with non-zero within variance are: %3$s", |
| 1162 | ! |
dQuote(ov.names[[g]][v]), gtxt, |
| 1163 | ! |
lav_msg_view(Lp[[g]]$cluster.id[[2]][non.zero.var], "none"))) |
| 1164 |
} |
|
| 1165 |
} |
|
| 1166 | 4x |
if (error.flag) {
|
| 1167 | ! |
lav_msg_stop( |
| 1168 | ! |
gettext("Some between-level (only) variables have
|
| 1169 | ! |
non-zero variance at the within-level. |
| 1170 | ! |
Please double-check your data.") |
| 1171 |
) |
|
| 1172 |
} |
|
| 1173 |
} # clustered data |
|
| 1174 | ||
| 1175 |
# missing data |
|
| 1176 | 37x |
if (missing != "listwise") {
|
| 1177 | 10x |
if (length(cluster) > 0L) {
|
| 1178 |
# get missing patterns |
|
| 1179 | ! |
Mp[[g]] <- lav_data_missing_patterns(X[[g]], |
| 1180 | ! |
sort.freq = TRUE, coverage = TRUE, |
| 1181 | ! |
Lp = Lp[[g]] |
| 1182 |
) |
|
| 1183 |
} else {
|
|
| 1184 |
# get missing patterns |
|
| 1185 | 10x |
Mp[[g]] <- lav_data_missing_patterns(X[[g]], |
| 1186 | 10x |
sort.freq = TRUE, coverage = TRUE, |
| 1187 | 10x |
Lp = NULL |
| 1188 |
) |
|
| 1189 |
} |
|
| 1190 | ||
| 1191 |
# checking! |
|
| 1192 | 10x |
if (length(Mp[[g]]$empty.idx) > 0L) {
|
| 1193 |
# new in 0.6-4: return 'original' index in full data.frame |
|
| 1194 | ! |
empty.case.idx <- case.idx[[g]][Mp[[g]]$empty.idx] |
| 1195 | ! |
lav_msg_warn(gettextf( |
| 1196 | ! |
"some cases are empty and will be ignored: %s.", |
| 1197 | ! |
paste(empty.case.idx, collapse = " "))) |
| 1198 |
} |
|
| 1199 | 10x |
if (any(Mp[[g]]$coverage < 0.1)) {
|
| 1200 | ! |
coverage.vech <- lav_matrix_vech(Mp[[g]]$coverage, diagonal = FALSE) |
| 1201 | ! |
small.idx <- which(coverage.vech < 0.1) |
| 1202 | ! |
if (all(coverage.vech[small.idx] == 0)) {
|
| 1203 |
# 0.6-18: no warning --> this could be due to missing by design |
|
| 1204 |
# 0.6-20: give warning anyway (as EM is ignoring this) |
|
| 1205 | ! |
lav_msg_warn(gettext( |
| 1206 | ! |
"due to missing values, some pairwise combinations have zero |
| 1207 | ! |
coverage; the corresponding covariances are not identified; |
| 1208 | ! |
use lavInspect(fit, \"coverage\") to investigate.")) |
| 1209 |
} else {
|
|
| 1210 | ! |
lav_msg_warn(gettext( |
| 1211 | ! |
"due to missing values, some pairwise combinations have less than |
| 1212 | ! |
10% coverage; use lavInspect(fit, \"coverage\") to investigate.")) |
| 1213 |
} |
|
| 1214 |
} |
|
| 1215 |
# in case we had observations with only missings |
|
| 1216 | 10x |
nobs[[g]] <- NROW(X[[g]]) - length(Mp[[g]]$empty.idx) |
| 1217 |
} # missing |
|
| 1218 |
} # groups, at first level |
|
| 1219 | ||
| 1220 |
# sampling weigths, again |
|
| 1221 | 35x |
if (is.null(sampling.weights)) {
|
| 1222 | 35x |
sampling.weights <- character(0L) |
| 1223 |
} else {
|
|
| 1224 |
# check if we need normalization |
|
| 1225 | ! |
if (sampling.weights.normalization == "none") {
|
| 1226 |
# nothing to do |
|
| 1227 | ! |
} else if (sampling.weights.normalization == "total") {
|
| 1228 | ! |
sum.weights <- sum(unlist(weights)) |
| 1229 | ! |
ntotal <- sum(unlist(nobs)) |
| 1230 | ! |
for (g in 1:ngroups) {
|
| 1231 | ! |
WT <- weights[[g]] |
| 1232 | ! |
WT2 <- WT / sum.weights * ntotal |
| 1233 | ! |
weights[[g]] <- WT2 |
| 1234 |
} |
|
| 1235 | ! |
} else if (sampling.weights.normalization == "group") {
|
| 1236 | ! |
for (g in 1:ngroups) {
|
| 1237 | ! |
WT <- weights[[g]] |
| 1238 | ! |
WT2 <- WT / sum(WT) * nobs[[g]] |
| 1239 | ! |
weights[[g]] <- WT2 |
| 1240 |
} |
|
| 1241 |
} else {
|
|
| 1242 | ! |
lav_msg_stop(gettext( |
| 1243 | ! |
"sampling.weights.normalization should be total, group or none.")) |
| 1244 |
} |
|
| 1245 |
} |
|
| 1246 | ||
| 1247 |
# block.labels |
|
| 1248 | 35x |
block.label <- character(0L) |
| 1249 | 35x |
if (length(group.label) > 0L && length(level.label) == 0L) {
|
| 1250 | ! |
block.label <- group.label |
| 1251 | 35x |
} else if (length(level.label) > 0L && length(group.label) == 0L) {
|
| 1252 | ! |
block.label <- level.label |
| 1253 | 35x |
} else if (length(group.label) > 0L && |
| 1254 | 35x |
length(level.label) > 0L) {
|
| 1255 | 2x |
block.label <- paste(rep(group.label, each = length(level.label)), |
| 1256 | 2x |
rep(level.label, times = length(group.label)), |
| 1257 | 2x |
sep = "." |
| 1258 |
) |
|
| 1259 |
} |
|
| 1260 | ||
| 1261 | ||
| 1262 | 35x |
lavData <- new("lavData",
|
| 1263 | 35x |
data.type = "full", |
| 1264 | 35x |
ngroups = ngroups, |
| 1265 | 35x |
group = group, |
| 1266 | 35x |
nlevels = nlevels, |
| 1267 | 35x |
cluster = cluster, |
| 1268 | 35x |
group.label = group.label, |
| 1269 | 35x |
level.label = level.label, |
| 1270 | 35x |
block.label = block.label, |
| 1271 | 35x |
std.ov = std.ov, |
| 1272 | 35x |
nobs = nobs, |
| 1273 | 35x |
norig = norig, |
| 1274 | 35x |
ov.names = ov.names, |
| 1275 | 35x |
ov.names.x = ov.names.x, |
| 1276 | 35x |
ov.names.l = ov.names.l, |
| 1277 |
# ov.types = ov.types, |
|
| 1278 |
# ov.idx = ov.idx, |
|
| 1279 | 35x |
ordered = as.character(ordered), |
| 1280 | 35x |
weights = weights, |
| 1281 | 35x |
sampling.weights = sampling.weights, |
| 1282 | 35x |
ov = ov, |
| 1283 | 35x |
case.idx = case.idx, |
| 1284 | 35x |
missing = missing, |
| 1285 | 35x |
X = X, |
| 1286 | 35x |
eXo = eXo, |
| 1287 | 35x |
Mp = Mp, |
| 1288 | 35x |
Rp = Rp, |
| 1289 | 35x |
Lp = Lp |
| 1290 |
) |
|
| 1291 | 35x |
lavData |
| 1292 |
} |
| 1 |
# constrained optimization |
|
| 2 |
# - references: * Nocedal & Wright (2006) Chapter 17 |
|
| 3 |
# * Optimization with constraints by Madsen, Nielsen & Tingleff |
|
| 4 |
# * original papers: Powell, 1969 and Rockafeller, 1974 |
|
| 5 |
# - using 'nlminb' for the unconstrained subproblem |
|
| 6 |
# - convergence scheme is based on the auglag function in the alabama package |
|
| 7 |
nlminb.constr <- function(start, objective, gradient = NULL, hessian = NULL, |
|
| 8 |
..., scale = 1, control = list(), |
|
| 9 |
lower = -Inf, upper = Inf, |
|
| 10 |
ceq = NULL, ceq.jac = NULL, |
|
| 11 |
cin = NULL, cin.jac = NULL, |
|
| 12 |
control.outer = list()) {
|
|
| 13 |
# we need a gradient |
|
| 14 | 2x |
stopifnot(!is.null(gradient)) |
| 15 | ||
| 16 |
# if no 'ceq' or 'cin' function, we create a dummy one |
|
| 17 | 2x |
if (is.null(ceq)) {
|
| 18 | 2x |
ceq <- function(x, ...) {
|
| 19 | 3950x |
return(numeric(0)) |
| 20 |
} |
|
| 21 |
} |
|
| 22 | 2x |
if (is.null(cin)) {
|
| 23 | ! |
cin <- function(x, ...) {
|
| 24 | ! |
return(numeric(0)) |
| 25 |
} |
|
| 26 |
} |
|
| 27 | ||
| 28 |
# if no user-supplied jacobian functions, create them |
|
| 29 | 2x |
if (is.null(ceq.jac)) {
|
| 30 | 2x |
if (is.null(ceq)) {
|
| 31 | ! |
ceq.jac <- function(x, ...) {
|
| 32 | ! |
matrix(0, nrow = 0L, ncol = length(x)) |
| 33 |
} |
|
| 34 |
} else {
|
|
| 35 | 2x |
ceq.jac <- function(x, ...) {
|
| 36 | 110x |
numDeriv::jacobian(func = ceq, x = x, ...) |
| 37 |
} |
|
| 38 |
} |
|
| 39 |
} |
|
| 40 | 2x |
if (is.null(cin.jac)) {
|
| 41 | 2x |
if (is.null(cin)) {
|
| 42 | ! |
cin.jac <- function(x, ...) {
|
| 43 | ! |
matrix(0, nrow = 0L, ncol = length(x)) |
| 44 |
} |
|
| 45 |
} else {
|
|
| 46 | 2x |
cin.jac <- function(x, ...) {
|
| 47 | 110x |
numDeriv::jacobian(func = cin, x = x, ...) |
| 48 |
} |
|
| 49 |
} |
|
| 50 |
} |
|
| 51 | ||
| 52 |
# how many ceq and cin constraints? |
|
| 53 | 2x |
nceq <- length(ceq(start)) |
| 54 | 2x |
ncin <- length(cin(start)) |
| 55 | 2x |
ncon <- nceq + ncin |
| 56 | 2x |
ceq.idx <- cin.idx <- integer(0) |
| 57 | ! |
if (nceq > 0L) ceq.idx <- 1:nceq |
| 58 | 2x |
if (ncin > 0L) cin.idx <- nceq + 1:ncin |
| 59 | 2x |
cin.flag <- rep(FALSE, length(ncon)) |
| 60 | 2x |
if (ncin > 0L) cin.flag[cin.idx] <- TRUE |
| 61 | ||
| 62 |
# control outer default values |
|
| 63 | 2x |
control.outer.default <- list( |
| 64 | 2x |
mu0 = 100, |
| 65 | 2x |
lambda0 = 10, |
| 66 | 2x |
tol = 1e-06, # changed this in 0.4-12 |
| 67 | 2x |
itmax = 100L, |
| 68 | 2x |
verbose = FALSE |
| 69 |
) |
|
| 70 | 2x |
control.outer <- modifyList(control.outer.default, control.outer) |
| 71 | ||
| 72 | ||
| 73 |
# construct augmented lagrangian function |
|
| 74 | 2x |
auglag <- function(x, ...) {
|
| 75 |
# apply constraints |
|
| 76 | 200x |
ceq0 <- ceq(x, ...) |
| 77 | 200x |
cin0 <- cin(x, ...) |
| 78 | 200x |
con0 <- c(ceq0, cin0) |
| 79 |
# 'release' inactive constraints |
|
| 80 | 200x |
if (ncin > 0L) {
|
| 81 | 200x |
slack <- lambda / mu |
| 82 | 200x |
inactive.idx <- which(cin.flag & con0 > slack) |
| 83 | 200x |
con0[inactive.idx] <- slack[inactive.idx] |
| 84 |
} |
|
| 85 | 200x |
objective(x, ...) - sum(lambda * con0) + (mu / 2) * sum(con0 * con0) |
| 86 |
} |
|
| 87 | ||
| 88 | 2x |
fgrad <- function(x, ...) {
|
| 89 |
# apply constraints |
|
| 90 | 108x |
ceq0 <- ceq(x, ...) |
| 91 | 108x |
cin0 <- cin(x, ...) |
| 92 | 108x |
con0 <- c(ceq0, cin0) |
| 93 |
# jacobian |
|
| 94 | 108x |
JAC <- rbind(ceq.jac(x, ...), cin.jac(x, ...)) |
| 95 | 108x |
lambda.JAC <- lambda * JAC |
| 96 | ||
| 97 |
# handle inactive constraints |
|
| 98 | 108x |
if (ncin > 0L) {
|
| 99 | 108x |
slack <- lambda / mu |
| 100 | 108x |
inactive.idx <- which(cin.flag & con0 > slack) |
| 101 | 108x |
if (length(inactive.idx) > 0L) {
|
| 102 | 108x |
JAC <- JAC[-inactive.idx, , drop = FALSE] |
| 103 | 108x |
lambda.JAC <- lambda.JAC[-inactive.idx, , drop = FALSE] |
| 104 | 108x |
con0 <- con0[-inactive.idx] |
| 105 |
} |
|
| 106 |
} |
|
| 107 | ||
| 108 | 108x |
if (nrow(JAC) > 0L) {
|
| 109 | 48x |
(gradient(x, ...) - colSums(lambda.JAC) + |
| 110 | 48x |
mu * as.numeric(t(JAC) %*% con0)) |
| 111 |
} else {
|
|
| 112 | 60x |
gradient(x, ...) |
| 113 |
} |
|
| 114 |
} |
|
| 115 | ||
| 116 | ||
| 117 |
# initialization |
|
| 118 | 2x |
ceq0 <- ceq(start, ...) |
| 119 | 2x |
cin0 <- cin(start, ...) |
| 120 | 2x |
con0 <- c(ceq0, cin0) |
| 121 | 2x |
lambda <- rep(control.outer$lambda0, length(con0)) |
| 122 | 2x |
mu <- control.outer$mu0 |
| 123 | 2x |
inactive.idx <- integer(0) |
| 124 | 2x |
if (ncin > 0L) {
|
| 125 | 2x |
slack <- lambda / mu |
| 126 | 2x |
inactive.idx <- which(cin.flag & con0 > slack) |
| 127 | 2x |
con0[inactive.idx] <- slack[inactive.idx] |
| 128 |
} |
|
| 129 | 2x |
K <- max(abs(con0)) |
| 130 | 2x |
if (control.outer$verbose) {
|
| 131 | ! |
cat("init cin0 values: ", cin0, "\n")
|
| 132 | ! |
cat("init ceq0 values: ", ceq0, "\n")
|
| 133 | ! |
cat("init slack values: ", lambda / mu, "\n")
|
| 134 | ! |
cat("init inactive idx: ", inactive.idx, "\n")
|
| 135 | ! |
cat("init con0 values: ", con0, "\n")
|
| 136 | ! |
cat("K = max con0: ", K, "\n")
|
| 137 |
} |
|
| 138 | ||
| 139 | 2x |
r <- obj <- objective(start, ...) |
| 140 | 2x |
feval <- 0L |
| 141 | 2x |
geval <- 0L |
| 142 | 2x |
niter <- 0L |
| 143 | 2x |
ilack <- 0L |
| 144 | 2x |
Kprev <- K |
| 145 | 2x |
mu0 <- control.outer$mu0 / Kprev |
| 146 | ! |
if (is.infinite(mu0)) mu0 <- 1.0 |
| 147 | 2x |
mu <- mu0 |
| 148 | ||
| 149 | 2x |
K <- Inf |
| 150 | 2x |
x.par <- start |
| 151 | 2x |
for (i in 1:control.outer$itmax) {
|
| 152 | 6x |
x.old <- x.par |
| 153 | 6x |
r.old <- r |
| 154 |
############################################################ |
|
| 155 | 6x |
if (control.outer$verbose) {
|
| 156 | ! |
cat("\nStarting inner optimization [", i, "]:\n")
|
| 157 | ! |
cat("lambda: ", lambda, "\n")
|
| 158 | ! |
cat("mu: ", mu, "\n")
|
| 159 |
} |
|
| 160 | 6x |
optim.out <- nlminb( |
| 161 | 6x |
start = x.par, objective = auglag, |
| 162 | 6x |
gradient = fgrad, control = control, |
| 163 | 6x |
lower = lower, upper = upper, |
| 164 | 6x |
scale = scale, ... |
| 165 |
) |
|
| 166 |
############################################################ |
|
| 167 | 6x |
x.par <- optim.out$par |
| 168 | 6x |
r <- optim.out$objective |
| 169 | 6x |
feval <- feval + optim.out$evaluations[1] |
| 170 | 6x |
geval <- geval + optim.out$evaluations[2] |
| 171 | 6x |
niter <- niter + optim.out$iterations |
| 172 | ||
| 173 |
# check constraints |
|
| 174 | 6x |
ceq0 <- ceq(x.par, ...) |
| 175 | 6x |
cin0 <- cin(x.par, ...) |
| 176 | 6x |
con0 <- c(ceq0, cin0) |
| 177 | 6x |
if (ncin > 0L) {
|
| 178 | 6x |
slack <- lambda / mu |
| 179 | 6x |
inactive.idx <- which(cin.flag & con0 > slack) |
| 180 | 6x |
con0[inactive.idx] <- slack[inactive.idx] |
| 181 |
} |
|
| 182 | 6x |
K <- max(abs(con0)) |
| 183 | 6x |
if (control.outer$verbose) {
|
| 184 | ! |
cat("cin0 values: ", cin0, "\n")
|
| 185 | ! |
cat("ceq0 values: ", ceq0, "\n")
|
| 186 | ! |
cat("active threshold: ", lambda / mu, "\n")
|
| 187 | ! |
cat("inactive idx: ", inactive.idx, "\n")
|
| 188 | ! |
cat("con0 values: ", con0, "\n")
|
| 189 | ! |
cat("K = max con0: ", K, " Kprev = ", Kprev, "\n")
|
| 190 |
} |
|
| 191 | ||
| 192 |
# update K or mu (see Powell, 1969) |
|
| 193 | 6x |
if (K <= Kprev / 4) {
|
| 194 | 6x |
lambda <- lambda - (mu * con0) |
| 195 | 6x |
Kprev <- K |
| 196 |
} else {
|
|
| 197 | ! |
mu <- 10 * mu |
| 198 |
} |
|
| 199 | ||
| 200 |
# check convergence |
|
| 201 | 6x |
pconv <- max(abs(x.par - x.old)) |
| 202 | 6x |
if (pconv < control.outer$tol) {
|
| 203 | ! |
ilack <- ilack + 1L |
| 204 |
} else {
|
|
| 205 | 6x |
ilack <- 0L |
| 206 |
} |
|
| 207 | ||
| 208 | 6x |
if ((is.finite(r) && is.finite(r.old) && |
| 209 | 6x |
abs(r - r.old) < control.outer$tol && K < control.outer$tol) | |
| 210 | 6x |
ilack >= 3) {
|
| 211 | 2x |
break |
| 212 |
} |
|
| 213 |
} |
|
| 214 | ||
| 215 |
# output |
|
| 216 | 2x |
a <- list() |
| 217 | ||
| 218 | 2x |
if (i == control.outer$itmax) {
|
| 219 | ! |
a$convergence <- 10L |
| 220 | ! |
a$message <- "nlminb.constr ran out of iterations and did not converge" |
| 221 | 2x |
} else if (K > control.outer$tol) {
|
| 222 | ! |
a$convergence <- 11L |
| 223 | ! |
a$message <- "Convergence due to lack of progress in parameter updates" |
| 224 |
} else {
|
|
| 225 | 2x |
a$convergence <- 0L |
| 226 | 2x |
a$message <- "converged" |
| 227 |
} |
|
| 228 | 2x |
a$par <- optim.out$par |
| 229 | 2x |
a$outer.iterations <- i |
| 230 | 2x |
a$lambda <- lambda |
| 231 | 2x |
a$mu <- mu |
| 232 |
# a$value <- objective(a$start, ...) |
|
| 233 |
# a$cin <- cin(a$start, ...) |
|
| 234 |
# a$ceq <- ceq(a$start, ...) |
|
| 235 | 2x |
a$evaluations <- c(feval, geval) |
| 236 | 2x |
a$iterations <- niter |
| 237 |
# a$kkt1 <- max(abs(a$fgrad)) <= 0.01 * (1 + abs(a$value)) |
|
| 238 |
# a$kkt2 <- any(eigen(a$hessian)$value * control.optim$objectivescale> 0) |
|
| 239 | ||
| 240 |
# jacobian of ceq and 'active' cin |
|
| 241 | 2x |
ceq0 <- ceq(a$par, ...) |
| 242 | 2x |
cin0 <- cin(a$par, ...) |
| 243 | 2x |
con0 <- c(ceq0, cin0) |
| 244 | 2x |
JAC <- rbind(ceq.jac(a$par, ...), cin.jac(a$par, ...)) |
| 245 | 2x |
inactive.idx <- integer(0L) |
| 246 | 2x |
cin.idx <- which(cin.flag) |
| 247 |
# ceq.idx <- which(!cin.flag) |
|
| 248 | 2x |
if (ncin > 0L) {
|
| 249 |
# FIXME: slack value not too strict?? |
|
| 250 | 2x |
slack <- 1e-05 |
| 251 |
# cat("DEBUG:\n"); print(con0)
|
|
| 252 | 2x |
inactive.idx <- which(cin.flag & abs(con0) > slack) |
| 253 |
# if(length(inactive.idx) > 0L) {
|
|
| 254 |
# JAC <- JAC[-inactive.idx,,drop=FALSE] |
|
| 255 |
# } |
|
| 256 |
} |
|
| 257 | 2x |
attr(JAC, "inactive.idx") <- inactive.idx |
| 258 | 2x |
attr(JAC, "cin.idx") <- cin.idx |
| 259 | 2x |
attr(JAC, "ceq.idx") <- ceq.idx |
| 260 | 2x |
a$con.jac <- JAC |
| 261 | ||
| 262 | 2x |
a |
| 263 |
} |
| 1 |
lav_lavaan_step02_options <- function(slotOptions = NULL, # nolint |
|
| 2 |
slotData = NULL, # nolint |
|
| 3 |
flat.model = NULL, |
|
| 4 |
ordered = NULL, |
|
| 5 |
sample.cov = NULL, |
|
| 6 |
sample.mean = NULL, |
|
| 7 |
sample.th = NULL, |
|
| 8 |
sample.nobs = NULL, |
|
| 9 |
ov.names.l = NULL, |
|
| 10 |
sampling.weights = NULL, |
|
| 11 |
constraints = NULL, |
|
| 12 |
group = NULL, |
|
| 13 |
ov.names.x = NULL, |
|
| 14 |
ov.names.y = NULL, |
|
| 15 |
dotdotdot = NULL, |
|
| 16 |
cluster = NULL, |
|
| 17 |
data = NULL) {
|
|
| 18 |
# # # # # # # # # # # # |
|
| 19 |
# # 2. lavoptions # # |
|
| 20 |
# # # # # # # # # # # # |
|
| 21 | ||
| 22 |
# if slotOptions not NULL |
|
| 23 |
# copy to lavoptions and modify categorical/clustered/multilevel |
|
| 24 |
# inserting a "." in the first position |
|
| 25 |
# if necessary, overwrite with values in dotdotdot and issue a warning |
|
| 26 |
# check if all names in dotdotdot are possible options, if not *** error *** |
|
| 27 |
# create complete option list (lav_options_default) and substitute values |
|
| 28 |
# given in dotdotdot |
|
| 29 |
# if data, slotData and sample.cov NULL: opt$bounds = FALSE |
|
| 30 |
# if slotData$data.type != "full" or (slotData and data = NULL): |
|
| 31 |
# opt$missing = "listwise" |
|
| 32 |
# set categorical mode ON if |
|
| 33 |
# - an operator "|" (threshold) was used |
|
| 34 |
# - data not NULL and one or more elements in ordered parameter |
|
| 35 |
# - sample.th provided |
|
| 36 |
# - at least one of the non-exogenous observed variables is "ordered" |
|
| 37 |
# (ordered factor in R) |
|
| 38 |
# if opt$estimator == "catml": set categorical mode OFF |
|
| 39 |
# TODO: estimator = "CATML" isn't mentioned in lavOptions / estimator |
|
| 40 |
# help text !? |
|
| 41 |
# if cluster not NULL, set opt$.clustered TRUE and *** error *** if |
|
| 42 |
# categorical mode is ON |
|
| 43 |
# opt$.multilevel = (length(ov.names.l) > 0L && |
|
| 44 |
# length(ov.names.l[[1]]) > 1L) |
|
| 45 |
# if sampling.weights not NULL en categorical mode OFF and opt$estimator |
|
| 46 |
# in ("default", "ML", "PML")
|
|
| 47 |
# set opt$estimator to "MLR" |
|
| 48 |
# if constraints present and estimator == "ML", set opt$information to |
|
| 49 |
# c("observed", "observed")
|
|
| 50 |
# if there is an operator "~1" in flat.model and sample.mean not NULL, |
|
| 51 |
# set opt$meanstructure TRUE |
|
| 52 |
# if there are no exogenous variables but conditional.x explicitly |
|
| 53 |
# requested: ** warning ** |
|
| 54 |
# if there are no exogenous variables set opt$conditional.x FALSE |
|
| 55 |
# if there are no exogenous variables and fixed.x not explicitly requested, |
|
| 56 |
# set opt$fixed.x to FALSE |
|
| 57 |
# if allow.empty.cell and estimator not Bayes, issue a warning |
|
| 58 | ||
| 59 | 140x |
if (!is.null(slotOptions)) {
|
| 60 | 61x |
lavoptions <- slotOptions |
| 61 | ||
| 62 |
# backwards compatibility |
|
| 63 | 61x |
if (!is.null(lavoptions$categorical)) {
|
| 64 | 61x |
lavoptions$.categorical <- lavoptions$categorical |
| 65 | 61x |
lavoptions$categorical <- NULL |
| 66 |
} |
|
| 67 | 61x |
if (!is.null(lavoptions$clustered)) {
|
| 68 | ! |
lavoptions$.clustered <- lavoptions$clustered |
| 69 | ! |
lavoptions$clustered <- NULL |
| 70 |
} |
|
| 71 | 61x |
if (!is.null(lavoptions$multilevel)) {
|
| 72 | ! |
lavoptions$.multilevel <- lavoptions$multilevel |
| 73 | ! |
lavoptions$multilevel <- NULL |
| 74 |
} |
|
| 75 | ||
| 76 |
# but what if other 'options' are given anyway (eg 'start = ')? |
|
| 77 |
# give a warning! |
|
| 78 | 61x |
if (length(dotdotdot) > 0L) {
|
| 79 | ! |
dot.names <- names(dotdotdot) |
| 80 | ! |
op.idx <- which(dot.names %in% names(slotOptions)) |
| 81 | ! |
lav_msg_warn(gettext( |
| 82 | ! |
"the following argument(s) override(s) the options in slotOptions:"), |
| 83 | ! |
paste(dot.names[op.idx], collapse = " ") |
| 84 |
) |
|
| 85 | ! |
lavoptions[dot.names[op.idx]] <- dotdotdot[op.idx] |
| 86 |
} |
|
| 87 |
} else {
|
|
| 88 | 79x |
if (lav_verbose()) {
|
| 89 | ! |
cat("lavoptions ...")
|
| 90 |
} |
|
| 91 | ||
| 92 |
# load default options |
|
| 93 | 79x |
opt <- lav_options_default() |
| 94 | ||
| 95 |
# catch unknown options |
|
| 96 | 79x |
ok.names <- names(opt) |
| 97 | 79x |
dot.names <- names(dotdotdot) |
| 98 | 79x |
wrong.idx <- which(!dot.names %in% ok.names) |
| 99 | 79x |
if (length(wrong.idx) > 0L) {
|
| 100 |
# stop or warning?? stop for now (there could be more) |
|
| 101 | ! |
lav_msg_stop(ngettext(length(wrong.idx), |
| 102 | ! |
"unknown argument:", "unknown arguments:"), |
| 103 | ! |
lav_msg_view(dot.names[wrong.idx], "none", FALSE) |
| 104 |
) |
|
| 105 |
} |
|
| 106 | ||
| 107 |
# modifyList |
|
| 108 | 79x |
opt <- modifyList(opt, dotdotdot) |
| 109 | ||
| 110 |
# extract estimator |
|
| 111 | 79x |
if (is.list(opt$estimator)) {
|
| 112 | ! |
estimator <- opt$estimator$estimator |
| 113 |
} else {
|
|
| 114 | 79x |
estimator <- opt$estimator |
| 115 |
} |
|
| 116 | ||
| 117 |
# no data? |
|
| 118 | 79x |
if (is.null(slotData) && is.null(data) && is.null(sample.cov)) {
|
| 119 | 2x |
opt$bounds <- FALSE |
| 120 |
} |
|
| 121 | ||
| 122 |
# only sample moments? |
|
| 123 | 79x |
if (!is.null(slotData) && !slotData@data.type == "full") {
|
| 124 | ! |
opt$missing <- "listwise" |
| 125 | 79x |
} else if (is.null(slotData) && is.null(data)) {
|
| 126 | 44x |
opt$missing <- "listwise" |
| 127 |
} |
|
| 128 | ||
| 129 |
# categorical mode? |
|
| 130 | 79x |
opt$.categorical <- FALSE |
| 131 | 79x |
if (any(flat.model$op == "|")) {
|
| 132 | ! |
opt$.categorical <- TRUE |
| 133 | 79x |
} else if (!is.null(data) && length(ordered) > 0L) {
|
| 134 | 2x |
opt$.categorical <- TRUE |
| 135 | 77x |
} else if (!is.null(sample.th)) {
|
| 136 | ! |
opt$.categorical <- TRUE |
| 137 | 77x |
} else if (is.data.frame(data)) {
|
| 138 |
# first check if we can find ov.names.y in Data |
|
| 139 | 33x |
tmp.ov.names.y <- unique(unlist(ov.names.y)) |
| 140 |
# remove possible interaction terms involving an y term |
|
| 141 | 33x |
int.idx <- which(grepl(":", tmp.ov.names.y))
|
| 142 | 33x |
if (length(int.idx) > 0L) {
|
| 143 | ! |
tmp.ov.names.y <- tmp.ov.names.y[-int.idx] |
| 144 |
} |
|
| 145 | 33x |
idx.missing <- which(!(tmp.ov.names.y %in% names(data))) |
| 146 | 33x |
if (length(idx.missing)) {
|
| 147 | ! |
lav_msg_stop( |
| 148 | ! |
gettext("missing observed variables in dataset:"),
|
| 149 | ! |
paste(tmp.ov.names.y[idx.missing], collapse = " ") |
| 150 |
) |
|
| 151 |
} |
|
| 152 | 33x |
if (any(sapply(data[, tmp.ov.names.y], inherits, "ordered"))) {
|
| 153 | ! |
opt$.categorical <- TRUE |
| 154 |
} |
|
| 155 |
} |
|
| 156 | 79x |
if (tolower(estimator) == "catml") {
|
| 157 | ! |
opt$.categorical <- FALSE |
| 158 |
} |
|
| 159 | ||
| 160 |
# clustered? |
|
| 161 | 79x |
if (length(cluster) > 0L) {
|
| 162 | 2x |
opt$.clustered <- TRUE |
| 163 | 2x |
if (opt$.categorical && toupper(estimator) != "PML") {
|
| 164 | ! |
lav_msg_stop(gettext("categorical + clustered is not supported yet."))
|
| 165 |
} |
|
| 166 |
} else {
|
|
| 167 | 77x |
opt$.clustered <- FALSE |
| 168 |
} |
|
| 169 | ||
| 170 |
# multilevel? |
|
| 171 | 79x |
if (length(ov.names.l) > 0L && length(ov.names.l[[1]]) > 1L) {
|
| 172 | 2x |
opt$.multilevel <- TRUE |
| 173 |
} else {
|
|
| 174 | 77x |
opt$.multilevel <- FALSE |
| 175 |
} |
|
| 176 | ||
| 177 |
# sampling weights? force MLR |
|
| 178 |
# HJ 18/10/23: Except for PML |
|
| 179 | 79x |
if (!is.null(sampling.weights) && !opt$.categorical && |
| 180 | 79x |
toupper(estimator) %in% c("DEFAULT", "ML", "PML")) {
|
| 181 | ! |
if (opt$se != "none") {
|
| 182 | ! |
opt$se <- "robust.huber.white" |
| 183 |
} |
|
| 184 | ! |
if (opt$se != "none") {
|
| 185 | ! |
opt$test <- "yuan.bentler.mplus" |
| 186 |
} |
|
| 187 |
} |
|
| 188 | ||
| 189 |
# constraints |
|
| 190 | 79x |
if (any(nchar(constraints) > 0L) && toupper(estimator) %in% c("ML")) {
|
| 191 | ! |
opt$information <- c("observed", "observed")
|
| 192 |
} |
|
| 193 | ||
| 194 |
# meanstructure |
|
| 195 | 79x |
if (any(flat.model$op == "~1") || !is.null(sample.mean)) {
|
| 196 | 40x |
opt$meanstructure <- TRUE |
| 197 |
} |
|
| 198 | 79x |
if (!is.null(group) && is.null(dotdotdot$meanstructure)) {
|
| 199 | 2x |
opt$meanstructure <- TRUE |
| 200 |
} |
|
| 201 | ||
| 202 |
# conditional.x |
|
| 203 | 79x |
if ((is.list(ov.names.x) && |
| 204 | 79x |
sum(sapply(ov.names.x, FUN = length)) == 0L) || |
| 205 | 79x |
(is.character(ov.names.x) && length(ov.names.x) == 0L)) {
|
| 206 |
# if explicitly set to TRUE, give warning |
|
| 207 | 39x |
if (is.logical(dotdotdot$conditional.x) && dotdotdot$conditional.x) {
|
| 208 | ! |
lav_msg_warn( |
| 209 | ! |
gettext("no exogenous covariates; conditional.x will be set to FALSE"))
|
| 210 |
} |
|
| 211 | 39x |
opt$conditional.x <- FALSE |
| 212 |
} |
|
| 213 | ||
| 214 |
# fixed.x |
|
| 215 | 79x |
if ((is.list(ov.names.x) && |
| 216 | 79x |
sum(sapply(ov.names.x, FUN = length)) == 0L) || |
| 217 | 79x |
(is.character(ov.names.x) && length(ov.names.x) == 0L)) {
|
| 218 |
# if explicitly set to TRUE, give warning |
|
| 219 | 39x |
if (is.logical(dotdotdot$fixed.x) && dotdotdot$fixed.x) {
|
| 220 |
# ok, we respect this: keep fixed.x = TRUE |
|
| 221 |
} else {
|
|
| 222 | 39x |
opt$fixed.x <- FALSE |
| 223 |
} |
|
| 224 |
} |
|
| 225 | ||
| 226 |
# allow.empty.cell |
|
| 227 | 79x |
if (opt$allow.empty.cell && opt$do.fit && toupper(estimator) != "BAYES") {
|
| 228 | ! |
lav_msg_warn( |
| 229 | ! |
gettext("allow.empty.cell is not intended to salvage estimation of this model, see ?lavOptions"))
|
| 230 |
} |
|
| 231 | ||
| 232 |
# fill in remaining "default" values |
|
| 233 | 79x |
lavoptions <- lav_options_set(opt) |
| 234 | ||
| 235 |
# store check.sigma.pd in lavaan_cache_env |
|
| 236 | 79x |
assign("opt.check.sigma.pd", opt$check.sigma.pd, lavaan_cache_env)
|
| 237 | ||
| 238 | 79x |
if (lav_verbose()) {
|
| 239 | ! |
cat(" done.\n")
|
| 240 |
} |
|
| 241 |
} |
|
| 242 | ||
| 243 | 140x |
lavoptions |
| 244 |
} |
| 1 |
# model gradient |
|
| 2 | ||
| 3 |
lav_model_gradient <- function(lavmodel = NULL, |
|
| 4 |
GLIST = NULL, |
|
| 5 |
lavsamplestats = NULL, |
|
| 6 |
lavdata = NULL, |
|
| 7 |
lavcache = NULL, |
|
| 8 |
type = "free", |
|
| 9 |
group.weight = TRUE, |
|
| 10 |
Delta = NULL, |
|
| 11 |
m.el.idx = NULL, |
|
| 12 |
x.el.idx = NULL, |
|
| 13 |
ceq.simple = FALSE) {
|
|
| 14 | 8376x |
nmat <- lavmodel@nmat |
| 15 | 8376x |
estimator <- lavmodel@estimator |
| 16 | 8376x |
representation <- lavmodel@representation |
| 17 | 8376x |
meanstructure <- lavmodel@meanstructure |
| 18 | 8376x |
categorical <- lavmodel@categorical |
| 19 | 8376x |
group.w.free <- lavmodel@group.w.free |
| 20 | 8376x |
fixed.x <- lavmodel@fixed.x |
| 21 | 8376x |
conditional.x <- lavmodel@conditional.x |
| 22 | 8376x |
num.idx <- lavmodel@num.idx |
| 23 | 8376x |
th.idx <- lavmodel@th.idx |
| 24 | 8376x |
nx.free <- lavmodel@nx.free |
| 25 | 8376x |
estimator.args <- lavmodel@estimator.args |
| 26 | ||
| 27 |
# state or final? |
|
| 28 | 20x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 29 | ||
| 30 | ! |
if (estimator == "REML") lav_msg_warn(gettext( |
| 31 | ! |
"analytical gradient not implement; use numerical approximation")) |
| 32 | ||
| 33 |
# group.weight |
|
| 34 |
# FIXME --> block.weight |
|
| 35 | 8376x |
if (group.weight) {
|
| 36 | 6716x |
if (estimator %in% c("ML", "PML", "FML", "MML", "REML", "NTRLS", "catML")) {
|
| 37 | 2893x |
group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal) |
| 38 | 3823x |
} else if (estimator == "DLS") {
|
| 39 | ! |
if (estimator.args$dls.FtimesNminus1) {
|
| 40 | ! |
group.w <- ((unlist(lavsamplestats@nobs) - 1) / lavsamplestats@ntotal) |
| 41 |
} else {
|
|
| 42 | ! |
group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal) |
| 43 |
} |
|
| 44 |
} else {
|
|
| 45 |
# FIXME: double check! |
|
| 46 | 3823x |
group.w <- ((unlist(lavsamplestats@nobs) - 1) / lavsamplestats@ntotal) |
| 47 |
} |
|
| 48 |
} else {
|
|
| 49 | 1660x |
group.w <- rep(1.0, lavmodel@nblocks) |
| 50 |
} |
|
| 51 | ||
| 52 |
# do we need WLS.est? |
|
| 53 | 8376x |
if (estimator %in% c("WLS", "DWLS", "ULS", "GLS", "NTRLS", "DLS")) {
|
| 54 |
# always compute WLS.est |
|
| 55 | 3823x |
WLS.est <- lav_model_wls_est(lavmodel = lavmodel, GLIST = GLIST) # , |
| 56 |
# cov.x = lavsamplestats@cov.x) |
|
| 57 |
} |
|
| 58 | ||
| 59 | 8376x |
if (estimator %in% c("ML", "PML", "FML", "REML", "NTRLS", "catML")) {
|
| 60 |
# compute moments for all groups |
|
| 61 |
# if(conditional.x) {
|
|
| 62 |
# Sigma.hat <- lav_model_cond2joint_sigma(lavmodel = lavmodel, |
|
| 63 |
# GLIST = GLIST, |
|
| 64 |
# extra = (estimator %in% c("ML", "REML","NTRLS")))
|
|
| 65 |
# } else {
|
|
| 66 | 4553x |
Sigma.hat <- lav_model_sigma( |
| 67 | 4553x |
lavmodel = lavmodel, GLIST = GLIST, |
| 68 | 4553x |
extra = (estimator %in% c( |
| 69 | 4553x |
"ML", "REML", |
| 70 | 4553x |
"NTRLS", "catML" |
| 71 |
)) |
|
| 72 |
) |
|
| 73 |
# } |
|
| 74 | ||
| 75 | 4553x |
if (meanstructure) {
|
| 76 |
# if(conditional.x) {
|
|
| 77 |
# Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST) |
|
| 78 |
# } else {
|
|
| 79 | 3660x |
Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST) |
| 80 |
# } |
|
| 81 |
} |
|
| 82 | ||
| 83 | 4553x |
if (categorical) {
|
| 84 | ! |
TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST) |
| 85 |
} |
|
| 86 | ||
| 87 | 4553x |
if (conditional.x) {
|
| 88 | ! |
PI <- lav_model_pi(lavmodel = lavmodel, GLIST = GLIST) |
| 89 | 4553x |
} else if (estimator == "PML") {
|
| 90 | ! |
PI <- vector("list", length = lavmodel@nblocks)
|
| 91 |
} |
|
| 92 | ||
| 93 | 4553x |
if (group.w.free) {
|
| 94 | ! |
GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST) |
| 95 |
} |
|
| 96 | 3823x |
} else if (estimator == "DLS" && estimator.args$dls.GammaNT == "model") {
|
| 97 | ! |
Sigma.hat <- lav_model_sigma( |
| 98 | ! |
lavmodel = lavmodel, GLIST = GLIST, |
| 99 | ! |
extra = FALSE |
| 100 |
) |
|
| 101 | ! |
Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST) |
| 102 | 3823x |
} else if (estimator == "MML") {
|
| 103 | ! |
TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST) |
| 104 | ! |
THETA <- lav_model_theta(lavmodel = lavmodel, GLIST = GLIST) |
| 105 | ! |
GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST) |
| 106 |
} |
|
| 107 | ||
| 108 |
# four approaches (FIXME!!!! merge this!) |
|
| 109 |
# - ML approach: using Omega (and Omega.mu) |
|
| 110 |
# Omega = 'POST' = Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv) |
|
| 111 |
# (still 2x faster than Delta method) |
|
| 112 |
# - WLS/DWLS/GLS: using Delta + WLS.V; support for fixed.x, conditional.x |
|
| 113 |
# - (ML)/NTRLS: using Delta, no support for fixed.x, conditional.x |
|
| 114 |
# - PML/FML/MML: custom |
|
| 115 | ||
| 116 |
# composites? |
|
| 117 | 8376x |
composites.flag <- lavmodel@composites |
| 118 | ||
| 119 |
# 1. ML approach |
|
| 120 | 8376x |
if ((estimator == "ML" || estimator == "REML" || estimator == "catML") && |
| 121 | 8376x |
lavdata@nlevels == 1L && !composites.flag && |
| 122 | 8376x |
!lavmodel@conditional.x) {
|
| 123 | 3898x |
correlation <- lavmodel@correlation |
| 124 | 3898x |
if (meanstructure) {
|
| 125 | 3005x |
Omega <- lav_model_omega( |
| 126 | 3005x |
Sigma.hat = Sigma.hat, Mu.hat = Mu.hat, |
| 127 | 3005x |
lavsamplestats = lavsamplestats, |
| 128 | 3005x |
estimator = estimator, |
| 129 | 3005x |
meanstructure = TRUE, |
| 130 | 3005x |
conditional.x = conditional.x, |
| 131 | 3005x |
correlation = correlation |
| 132 |
) |
|
| 133 | 3005x |
Omega.mu <- attr(Omega, "mu") |
| 134 |
} else {
|
|
| 135 | 893x |
Omega <- lav_model_omega( |
| 136 | 893x |
Sigma.hat = Sigma.hat, Mu.hat = NULL, |
| 137 | 893x |
lavsamplestats = lavsamplestats, |
| 138 | 893x |
estimator = estimator, |
| 139 | 893x |
meanstructure = FALSE, |
| 140 | 893x |
conditional.x = conditional.x, |
| 141 | 893x |
correlation = correlation |
| 142 |
) |
|
| 143 | 893x |
Omega.mu <- vector("list", length = lavmodel@nblocks)
|
| 144 |
} |
|
| 145 | ||
| 146 |
# compute DX (for all elements in every model matrix) |
|
| 147 | 3898x |
DX <- vector("list", length = length(GLIST))
|
| 148 | ||
| 149 | 3898x |
for (g in 1:lavmodel@nblocks) {
|
| 150 |
# which mm belong to group g? |
|
| 151 | 4264x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 152 | 4264x |
mm.names <- names(GLIST[mm.in.group]) |
| 153 | ||
| 154 | 4264x |
if (representation == "LISREL") {
|
| 155 | 4264x |
DX.group <- lav_lisrel_df_dmlist( |
| 156 | 4264x |
GLIST[mm.in.group], |
| 157 | 4264x |
Omega[[g]], |
| 158 | 4264x |
Omega.mu[[g]] |
| 159 |
) |
|
| 160 | ||
| 161 |
# FIXME!!! |
|
| 162 |
# add empty gamma |
|
| 163 | 4264x |
if (lavmodel@conditional.x) {
|
| 164 | ! |
DX.group$gamma <- lavmodel@GLIST$gamma |
| 165 |
} |
|
| 166 | ||
| 167 |
# only save what we need |
|
| 168 | 4264x |
DX[mm.in.group] <- DX.group[mm.names] |
| 169 | ! |
} else if (representation == "RAM") {
|
| 170 | ! |
DX.group <- lav_ram_df( |
| 171 | ! |
GLIST[mm.in.group], |
| 172 | ! |
Omega[[g]], |
| 173 | ! |
Omega.mu[[g]] |
| 174 |
) |
|
| 175 |
# only save what we need |
|
| 176 | ! |
DX[mm.in.group] <- DX.group[mm.names] |
| 177 |
} else {
|
|
| 178 | ! |
lav_msg_stop(gettext( |
| 179 | ! |
"only LISREL and RAM representation has been implemented for now")) |
| 180 |
} |
|
| 181 | ||
| 182 |
# weight by group |
|
| 183 | 4264x |
if (lavmodel@nblocks > 1L) {
|
| 184 | 732x |
for (mm in mm.in.group) {
|
| 185 | 3660x |
DX[[mm]] <- group.w[g] * DX[[mm]] |
| 186 |
} |
|
| 187 |
} |
|
| 188 |
} |
|
| 189 | ||
| 190 |
# extract free parameters |
|
| 191 | ||
| 192 | 3898x |
if (type == "free") {
|
| 193 | 3898x |
if (lavmodel@ceq.simple.only) { # new in 0.6-11
|
| 194 | ! |
dx <- numeric(lavmodel@nx.unco) |
| 195 | ! |
for (g in 1:lavmodel@nblocks) {
|
| 196 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 197 | ! |
for (mm in mm.in.group) {
|
| 198 | ! |
m.free.idx <- lavmodel@m.free.idx[[mm]] |
| 199 | ! |
x.unco.idx <- lavmodel@x.unco.idx[[mm]] |
| 200 | ! |
dx[x.unco.idx] <- DX[[mm]][m.free.idx] |
| 201 |
} |
|
| 202 |
} |
|
| 203 | ! |
if (ceq.simple) {
|
| 204 | ! |
dx <- drop(crossprod(lavmodel@ceq.simple.K, dx)) |
| 205 |
} |
|
| 206 |
} else {
|
|
| 207 | 3898x |
dx <- numeric(nx.free) |
| 208 | 3898x |
for (g in 1:lavmodel@nblocks) {
|
| 209 | 4264x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 210 | 4264x |
for (mm in mm.in.group) {
|
| 211 | 22302x |
m.free.idx <- lavmodel@m.free.idx[[mm]] |
| 212 | 22302x |
x.free.idx <- lavmodel@x.free.idx[[mm]] |
| 213 | 22302x |
dx[x.free.idx] <- DX[[mm]][m.free.idx] |
| 214 |
} |
|
| 215 |
} |
|
| 216 |
} |
|
| 217 |
} else {
|
|
| 218 | ! |
dx <- DX |
| 219 |
# handle equality constraints |
|
| 220 |
### FIXME!!!! TODO!!!! |
|
| 221 |
} |
|
| 222 |
} else # ML |
|
| 223 | ||
| 224 |
# 2. using Delta - *LS family |
|
| 225 | 4478x |
if (estimator %in% c("WLS", "DWLS", "ULS", "GLS", "NTGLS", "DLS")) {
|
| 226 | 3823x |
if (type != "free") {
|
| 227 | ! |
if (is.null(Delta)) {
|
| 228 | ! |
lav_msg_fixme("Delta should be given if type != free")
|
| 229 |
} |
|
| 230 |
# stop("FIXME: WLS gradient with type != free needs fixing!")
|
|
| 231 |
} else {
|
|
| 232 | 3823x |
Delta <- lav_model_delta( |
| 233 | 3823x |
lavmodel = lavmodel, GLIST. = GLIST, |
| 234 | 3823x |
ceq.simple = ceq.simple |
| 235 |
) |
|
| 236 |
} |
|
| 237 | ||
| 238 | 3823x |
for (g in 1:lavmodel@nblocks) {
|
| 239 |
# diff <- as.matrix(lavsamplestats@WLS.obs[[g]] - WLS.est[[g]]) |
|
| 240 |
# group.dx <- -1 * ( t(Delta[[g]]) %*% lavsamplestats@WLS.V[[g]] %*% diff) |
|
| 241 |
# 0.5-17: use crossprod twice; treat DWLS/ULS special |
|
| 242 | 3823x |
if (estimator == "WLS" || |
| 243 | 3823x |
estimator == "GLS" || |
| 244 | 3823x |
estimator == "DLS" || |
| 245 | 3823x |
estimator == "NTRLS") {
|
| 246 |
# full weight matrix |
|
| 247 | 1108x |
diff <- lavsamplestats@WLS.obs[[g]] - WLS.est[[g]] |
| 248 | ||
| 249 |
# full weight matrix |
|
| 250 | 1108x |
if (estimator == "GLS" || estimator == "WLS") {
|
| 251 | 1108x |
WLS.V <- lavsamplestats@WLS.V[[g]] |
| 252 | 1108x |
group.dx <- -1 * crossprod( |
| 253 | 1108x |
Delta[[g]], |
| 254 | 1108x |
crossprod(WLS.V, diff) |
| 255 |
) |
|
| 256 | ! |
} else if (estimator == "DLS") {
|
| 257 | ! |
if (estimator.args$dls.GammaNT == "sample") {
|
| 258 | ! |
WLS.V <- lavsamplestats@WLS.V[[g]] # for now |
| 259 |
} else {
|
|
| 260 | ! |
dls.a <- estimator.args$dls.a |
| 261 | ! |
GammaNT <- lav_samplestats_Gamma_NT( |
| 262 | ! |
COV = Sigma.hat[[g]], |
| 263 | ! |
MEAN = Mu.hat[[g]], |
| 264 | ! |
rescale = FALSE, |
| 265 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 266 | ! |
fixed.x = lavmodel@fixed.x, |
| 267 | ! |
conditional.x = lavmodel@conditional.x, |
| 268 | ! |
meanstructure = lavmodel@meanstructure, |
| 269 | ! |
slopestructure = lavmodel@conditional.x |
| 270 |
) |
|
| 271 | ! |
W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT |
| 272 | ! |
WLS.V <- lav_matrix_symmetric_inverse(W.DLS) |
| 273 |
} |
|
| 274 | ! |
group.dx <- -1 * crossprod( |
| 275 | ! |
Delta[[g]], |
| 276 | ! |
crossprod(WLS.V, diff) |
| 277 |
) |
|
| 278 | ! |
} else if (estimator == "NTRLS") {
|
| 279 | ! |
stopifnot(!conditional.x) |
| 280 |
# WLS.V <- lav_samplestats_Gamma_inverse_NT( |
|
| 281 |
# ICOV = attr(Sigma.hat[[g]],"inv")[,,drop=FALSE], |
|
| 282 |
# COV = Sigma.hat[[g]][,,drop=FALSE], |
|
| 283 |
# MEAN = Mu.hat[[g]], |
|
| 284 |
# x.idx = lavsamplestats@x.idx[[g]], |
|
| 285 |
# fixed.x = fixed.x, |
|
| 286 |
# conditional.x = conditional.x, |
|
| 287 |
# meanstructure = meanstructure, |
|
| 288 |
# slopestructure = conditional.x) |
|
| 289 | ||
| 290 | ! |
S <- lavsamplestats@cov[[g]] |
| 291 | ! |
Sigma <- Sigma.hat[[g]] |
| 292 | ! |
Sigma.inv <- attr(Sigma, "inv") |
| 293 | ! |
nvar <- NROW(Sigma) |
| 294 | ||
| 295 | ! |
if (meanstructure) {
|
| 296 | ! |
MEAN <- lavsamplestats@mean[[g]] |
| 297 | ! |
Mu <- Mu.hat[[g]] |
| 298 | ! |
POST.Sigma <- lav_matrix_duplication_pre( |
| 299 | ! |
matrix( |
| 300 | ! |
(Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)) %*% |
| 301 | ! |
(diag(nvar) + (S - Sigma) %*% Sigma.inv) + |
| 302 | ! |
(Sigma.inv %*% tcrossprod(MEAN - Mu) %*% Sigma.inv), |
| 303 | ! |
ncol = 1 |
| 304 |
) |
|
| 305 |
) |
|
| 306 | ! |
POST.Mu <- as.numeric(2 * Sigma.inv %*% (MEAN - Mu)) |
| 307 | ! |
POST <- c(POST.Mu, POST.Sigma) |
| 308 |
} else {
|
|
| 309 | ! |
POST <- lav_matrix_duplication_pre( |
| 310 | ! |
matrix((Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)) %*% |
| 311 | ! |
(diag(nvar) + (S - Sigma) %*% Sigma.inv), ncol = 1) |
| 312 |
) |
|
| 313 |
} |
|
| 314 | ||
| 315 | ! |
group.dx <- as.numeric(-1 * crossprod(Delta[[g]], POST)) |
| 316 |
} |
|
| 317 | 2715x |
} else if (estimator == "DWLS" || estimator == "ULS") {
|
| 318 |
# diagonal weight matrix |
|
| 319 | 2715x |
diff <- lavsamplestats@WLS.obs[[g]] - WLS.est[[g]] |
| 320 | 2715x |
group.dx <- -1 * crossprod( |
| 321 | 2715x |
Delta[[g]], |
| 322 | 2715x |
lavsamplestats@WLS.VD[[g]] * diff |
| 323 |
) |
|
| 324 |
} |
|
| 325 | ||
| 326 | 3823x |
group.dx <- group.w[g] * group.dx |
| 327 | 3823x |
if (g == 1) {
|
| 328 | 3823x |
dx <- group.dx |
| 329 |
} else {
|
|
| 330 | ! |
dx <- dx + group.dx |
| 331 |
} |
|
| 332 |
} # g |
|
| 333 | ||
| 334 | 3823x |
if (type == "free") {
|
| 335 |
# nothing to do |
|
| 336 |
} else {
|
|
| 337 |
# make a GLIST |
|
| 338 | ! |
dx <- lav_model_x2glist( |
| 339 | ! |
lavmodel = lavmodel, x = dx, |
| 340 | ! |
type = "custom", setDelta = FALSE, |
| 341 | ! |
m.el.idx = m.el.idx, |
| 342 | ! |
x.el.idx = x.el.idx |
| 343 |
) |
|
| 344 |
} |
|
| 345 |
} # WLS |
|
| 346 | ||
| 347 |
# ML + conditional.x |
|
| 348 | 655x |
else if (estimator %in% c("ML", "catML") && lavmodel@conditional.x &&
|
| 349 | 655x |
lavdata@nlevels == 1L) {
|
| 350 | ! |
if (type != "free") {
|
| 351 | ! |
if (is.null(Delta)) {
|
| 352 | ! |
lav_msg_fixme("Delta should be given if type != free")
|
| 353 |
} |
|
| 354 |
# stop("FIXME: WLS gradient with type != free needs fixing!")
|
|
| 355 |
} else {
|
|
| 356 | ! |
Delta <- lav_model_delta( |
| 357 | ! |
lavmodel = lavmodel, GLIST. = GLIST, |
| 358 | ! |
ceq.simple = ceq.simple |
| 359 |
) |
|
| 360 |
} |
|
| 361 | ||
| 362 | ! |
for (g in 1:lavmodel@nblocks) {
|
| 363 |
# augmented mean.x + cov.x matrix |
|
| 364 | ! |
mean.x <- lavsamplestats@mean.x[[g]] |
| 365 | ! |
cov.x <- lavsamplestats@cov.x[[g]] |
| 366 | ! |
C3 <- rbind( |
| 367 | ! |
c(1, mean.x), |
| 368 | ! |
cbind(mean.x, cov.x + tcrossprod(mean.x)) |
| 369 |
) |
|
| 370 | ||
| 371 | ! |
Sigma <- Sigma.hat[[g]] |
| 372 | ! |
Mu.g <- Mu.hat[[g]] |
| 373 | ! |
PI.g <- PI[[g]] |
| 374 | ! |
Sigma.inv <- attr(Sigma, "inv") |
| 375 | ! |
nvar <- NROW(Sigma) |
| 376 | ! |
S <- lavsamplestats@res.cov[[g]] |
| 377 | ||
| 378 |
# beta |
|
| 379 | ! |
OBS <- t(cbind( |
| 380 | ! |
lavsamplestats@res.int[[g]], |
| 381 | ! |
lavsamplestats@res.slopes[[g]] |
| 382 |
)) |
|
| 383 | ! |
EST <- t(cbind(Mu.g, PI.g)) |
| 384 |
# obs.beta <- c(lavsamplestats@res.int[[g]], |
|
| 385 |
# lav_matrix_vec(lavsamplestats@res.slopes[[g]])) |
|
| 386 |
# est.beta <- c(Mu.g, lav_matrix_vec(PI.g)) |
|
| 387 |
# beta.COV <- C3 %x% Sigma.inv |
|
| 388 | ||
| 389 |
# a <- t(obs.beta - est.beta) |
|
| 390 |
# b <- as.matrix(obs.beta - est.beta) |
|
| 391 |
# K <- lav_matrix_commutation(m = nvar, n = nvar) |
|
| 392 |
# AB <- (K %x% diag(NROW(C3)*NROW(C3))) %*% |
|
| 393 |
# (diag(nvar) %x% lav_matrix_vec(C3) %x% diag(nvar)) |
|
| 394 |
# K <- lav_matrix_commutation(m = nvar, n = NROW(C3)) |
|
| 395 |
# AB <- ( diag(NROW(C3)) %x% K %x% diag(nvar) ) %*% |
|
| 396 |
# (lav_matrix_vec(C3) %x% diag( nvar * nvar) ) |
|
| 397 | ||
| 398 |
# POST.beta <- 2 * beta.COV %*% (obs.beta - est.beta) |
|
| 399 | ! |
d.BETA <- C3 %*% (OBS - EST) %*% Sigma.inv |
| 400 |
# NOTE: the vecr here, unlike lav_mvreg_dlogl_beta |
|
| 401 |
# this is because DELTA has used vec(t(BETA)), |
|
| 402 |
# instead of vec(BETA) |
|
| 403 |
# POST.beta <- 2 * lav_matrix_vecr(d.BETA) |
|
| 404 |
# NOT any longer, since 0.6-1!!! |
|
| 405 | ! |
POST.beta <- 2 * lav_matrix_vec(d.BETA) |
| 406 | ||
| 407 |
# POST.sigma1 <- lav_matrix_duplication_pre( |
|
| 408 |
# (Sigma.inv %x% Sigma.inv) %*% t(AB) %*% (t(a) %x% b) ) |
|
| 409 | ||
| 410 |
# Sigma |
|
| 411 |
# POST.sigma2 <- lav_matrix_duplication_pre( |
|
| 412 |
# matrix( lav_matrix_vec( |
|
| 413 |
# Sigma.inv %*% (S - Sigma) %*% t(Sigma.inv)), ncol = 1L)) |
|
| 414 | ! |
W.tilde <- S + t(OBS - EST) %*% C3 %*% (OBS - EST) |
| 415 | ! |
d.SIGMA <- (Sigma.inv - Sigma.inv %*% W.tilde %*% Sigma.inv) |
| 416 | ! |
d.vechSigma <- as.numeric(lav_matrix_duplication_pre( |
| 417 | ! |
as.matrix(lav_matrix_vec(d.SIGMA)) |
| 418 |
)) |
|
| 419 | ! |
POST.sigma <- -1 * d.vechSigma |
| 420 | ||
| 421 |
# POST <- c(POST.beta, POST.sigma1 + POST.sigma2) |
|
| 422 | ! |
POST <- c(POST.beta, POST.sigma) |
| 423 | ||
| 424 | ! |
group.dx <- as.numeric(-1 * crossprod(Delta[[g]], POST)) |
| 425 | ||
| 426 |
# because we still use obj/2, we need to divide by 2! |
|
| 427 | ! |
group.dx <- group.dx / 2 # fixed in 0.6-1 |
| 428 | ||
| 429 | ! |
group.dx <- group.w[g] * group.dx |
| 430 | ! |
if (g == 1) {
|
| 431 | ! |
dx <- group.dx |
| 432 |
} else {
|
|
| 433 | ! |
dx <- dx + group.dx |
| 434 |
} |
|
| 435 |
} # g |
|
| 436 | ||
| 437 | ! |
if (type == "free") {
|
| 438 |
# nothing to do |
|
| 439 |
} else {
|
|
| 440 |
# make a GLIST |
|
| 441 | ! |
dx <- lav_model_x2glist( |
| 442 | ! |
lavmodel = lavmodel, x = dx, |
| 443 | ! |
type = "custom", setDelta = FALSE, |
| 444 | ! |
m.el.idx = m.el.idx, |
| 445 | ! |
x.el.idx = x.el.idx |
| 446 |
) |
|
| 447 |
} |
|
| 448 |
} # ML + conditional.x |
|
| 449 | ||
| 450 | 655x |
else if (estimator == "ML" && lavdata@nlevels > 1L) {
|
| 451 | 655x |
if (type != "free") {
|
| 452 | ! |
lav_msg_fixme("type != free in lav_model_gradient for
|
| 453 | ! |
estimator ML for nlevels > 1") |
| 454 |
} else {
|
|
| 455 | 655x |
Delta <- lav_model_delta( |
| 456 | 655x |
lavmodel = lavmodel, GLIST. = GLIST, |
| 457 | 655x |
ceq.simple = ceq.simple |
| 458 |
) |
|
| 459 |
} |
|
| 460 | ||
| 461 |
# for each upper-level group.... |
|
| 462 | 655x |
for (g in 1:lavmodel@ngroups) {
|
| 463 | 1310x |
if (!lavsamplestats@missing.flag) { # complete data
|
| 464 | 1310x |
if (lavmodel@conditional.x) {
|
| 465 | ! |
DX <- lav_mvreg_cluster_dlogl_2l_samplestats( |
| 466 | ! |
YLp = lavsamplestats@YLp[[g]], |
| 467 | ! |
Lp = lavdata@Lp[[g]], |
| 468 | ! |
Res.Sigma.W = Sigma.hat[[(g - 1) * 2 + 1]], |
| 469 | ! |
Res.Int.W = Mu.hat[[(g - 1) * 2 + 1]], |
| 470 | ! |
Res.Pi.W = PI[[(g - 1) * 2 + 1]], |
| 471 | ! |
Res.Sigma.B = Sigma.hat[[(g - 1) * 2 + 2]], |
| 472 | ! |
Res.Int.B = Mu.hat[[(g - 1) * 2 + 2]], |
| 473 | ! |
Res.Pi.B = PI[[(g - 1) * 2 + 2]], |
| 474 | ! |
Sinv.method = "eigen" |
| 475 |
) |
|
| 476 |
} else {
|
|
| 477 | 1310x |
DX <- lav_mvnorm_cluster_dlogl_2l_samplestats( |
| 478 | 1310x |
YLp = lavsamplestats@YLp[[g]], |
| 479 | 1310x |
Lp = lavdata@Lp[[g]], |
| 480 | 1310x |
Mu.W = Mu.hat[[(g - 1) * 2 + 1]], |
| 481 | 1310x |
Sigma.W = Sigma.hat[[(g - 1) * 2 + 1]], |
| 482 | 1310x |
Mu.B = Mu.hat[[(g - 1) * 2 + 2]], |
| 483 | 1310x |
Sigma.B = Sigma.hat[[(g - 1) * 2 + 2]], |
| 484 | 1310x |
Sinv.method = "eigen" |
| 485 |
) |
|
| 486 |
} |
|
| 487 |
} else {
|
|
| 488 |
# missing data |
|
| 489 | ! |
if (lavmodel@conditional.x) {
|
| 490 | ! |
lav_msg_stop(gettext("gradient for twolevel + conditional.x + fiml
|
| 491 | ! |
is not ready; use optim.gradient = \"numerical\"")) |
| 492 |
} else {
|
|
| 493 | ! |
DX <- lav_mvnorm_cluster_missing_dlogl_2l_samplestats( |
| 494 | ! |
Y1 = lavdata@X[[g]], |
| 495 | ! |
Y2 = lavsamplestats@YLp[[g]][[2]]$Y2, |
| 496 | ! |
Lp = lavdata@Lp[[g]], |
| 497 | ! |
Mp = lavdata@Mp[[g]], |
| 498 | ! |
Mu.W = Mu.hat[[(g - 1) * 2 + 1]], |
| 499 | ! |
Sigma.W = Sigma.hat[[(g - 1) * 2 + 1]], |
| 500 | ! |
Mu.B = Mu.hat[[(g - 1) * 2 + 2]], |
| 501 | ! |
Sigma.B = Sigma.hat[[(g - 1) * 2 + 2]], |
| 502 | ! |
Sinv.method = "eigen" |
| 503 |
) |
|
| 504 |
} |
|
| 505 |
} |
|
| 506 | ||
| 507 | 1310x |
group.dx <- as.numeric(DX %*% Delta[[g]]) |
| 508 | ||
| 509 |
# group weights (if any) |
|
| 510 | 1310x |
group.dx <- group.w[g] * group.dx |
| 511 | 1310x |
if (g == 1) {
|
| 512 | 655x |
dx <- group.dx |
| 513 |
} else {
|
|
| 514 | 655x |
dx <- dx + group.dx |
| 515 |
} |
|
| 516 |
} # g |
|
| 517 | ||
| 518 |
# divide by 2 * N |
|
| 519 | 655x |
dx <- dx / (2 * lavsamplestats@ntotal) |
| 520 | ||
| 521 |
# cat("dx1 (numerical) = \n"); print( zapsmall(dx1) )
|
|
| 522 |
# cat("dx (analytic) = \n"); print( zapsmall(dx ) )
|
|
| 523 |
} # ML + two-level |
|
| 524 | ||
| 525 | ! |
else if (estimator == "PML" || estimator == "FML" || |
| 526 | ! |
estimator == "MML") {
|
| 527 | ! |
if (type != "free") {
|
| 528 | ! |
lav_msg_fixme("type != free in lav_model_gradient for estimator PML")
|
| 529 |
} else {
|
|
| 530 | ! |
Delta <- lav_model_delta( |
| 531 | ! |
lavmodel = lavmodel, GLIST. = GLIST, |
| 532 | ! |
ceq.simple = ceq.simple |
| 533 |
) |
|
| 534 |
} |
|
| 535 | ||
| 536 | ! |
for (g in 1:lavmodel@nblocks) {
|
| 537 |
# print(GLIST) |
|
| 538 |
# print(lav_model_get_parameters(lavmodel = lavmodel, GLIST = GLIST)) |
|
| 539 |
# print(Sigma.hat[[g]]) |
|
| 540 |
# print(TH[[g]]) |
|
| 541 |
# cat("*****\n")
|
|
| 542 | ||
| 543 |
# compute partial derivative of logLik with respect to |
|
| 544 |
# thresholds/means, slopes, variances, correlations |
|
| 545 | ! |
if (estimator == "PML") {
|
| 546 | ! |
if (lavdata@nlevels > 1L) {
|
| 547 | ! |
lav_msg_stop(gettext( |
| 548 | ! |
"PL gradient + multilevel not implemented; |
| 549 | ! |
try optim.gradient = \"numerical\"")) |
| 550 | ! |
} else if (conditional.x) {
|
| 551 | ! |
d1 <- lav_pml_dploglik_dimplied( |
| 552 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 553 | ! |
Mu.hat = Mu.hat[[g]], |
| 554 | ! |
TH = TH[[g]], |
| 555 | ! |
th.idx = th.idx[[g]], |
| 556 | ! |
num.idx = num.idx[[g]], |
| 557 | ! |
X = lavdata@X[[g]], |
| 558 | ! |
lavcache = lavcache[[g]], |
| 559 | ! |
eXo = lavdata@eXo[[g]], |
| 560 | ! |
wt = lavdata@weights[[g]], |
| 561 | ! |
PI = PI[[g]], |
| 562 | ! |
missing = lavdata@missing |
| 563 |
) |
|
| 564 |
} else {
|
|
| 565 | ! |
d1 <- lav_pml_dploglik_dimplied( |
| 566 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 567 | ! |
Mu.hat = Mu.hat[[g]], |
| 568 | ! |
TH = TH[[g]], |
| 569 | ! |
th.idx = th.idx[[g]], |
| 570 | ! |
num.idx = num.idx[[g]], |
| 571 | ! |
X = lavdata@X[[g]], |
| 572 | ! |
lavcache = lavcache[[g]], |
| 573 | ! |
eXo = NULL, |
| 574 | ! |
wt = lavdata@weights[[g]], |
| 575 | ! |
PI = NULL, |
| 576 | ! |
missing = lavdata@missing |
| 577 |
) |
|
| 578 |
} # not conditional.x |
|
| 579 | ||
| 580 |
# chain rule (fmin) |
|
| 581 | ! |
group.dx <- |
| 582 | ! |
as.numeric(t(d1) %*% Delta[[g]]) |
| 583 |
} # PML |
|
| 584 | ||
| 585 | ! |
else if (estimator == "FML") {
|
| 586 | ! |
d1 <- lav_pml_fml_dploglik_dimplied( |
| 587 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 588 | ! |
TH = TH[[g]], |
| 589 | ! |
th.idx = th.idx[[g]], |
| 590 | ! |
num.idx = num.idx[[g]], |
| 591 | ! |
X = lavdata@X[[g]], |
| 592 | ! |
lavcache = lavcache[[g]] |
| 593 |
) |
|
| 594 | ||
| 595 |
# chain rule (fmin) |
|
| 596 | ! |
group.dx <- |
| 597 | ! |
as.numeric(t(d1) %*% Delta[[g]]) / lavsamplestats@nobs[[g]] |
| 598 | ! |
} else if (estimator == "MML") {
|
| 599 | ! |
group.dx <- |
| 600 | ! |
lav_model_gradient_mml( |
| 601 | ! |
lavmodel = lavmodel, |
| 602 | ! |
GLIST = GLIST, |
| 603 | ! |
THETA = THETA[[g]], |
| 604 | ! |
TH = TH[[g]], |
| 605 | ! |
group = g, |
| 606 | ! |
lavdata = lavdata, |
| 607 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 608 | ! |
sample.mean.x = lavsamplestats@mean.x[[g]], |
| 609 | ! |
lavcache = lavcache |
| 610 |
) |
|
| 611 |
} |
|
| 612 | ||
| 613 |
# group weights (if any) |
|
| 614 | ! |
group.dx <- group.w[g] * group.dx |
| 615 | ! |
if (g == 1) {
|
| 616 | ! |
dx <- group.dx |
| 617 |
} else {
|
|
| 618 | ! |
dx <- dx + group.dx |
| 619 |
} |
|
| 620 |
} # g |
|
| 621 |
} else {
|
|
| 622 | ! |
lav_msg_stop(gettext( |
| 623 | ! |
"no analytical gradient available for estimator"), estimator) |
| 624 |
} |
|
| 625 | ||
| 626 | ||
| 627 |
# group.w.free for ML |
|
| 628 | 8376x |
if (lavmodel@group.w.free && |
| 629 | 8376x |
estimator %in% c("ML", "MML", "FML", "PML", "REML", "catML")) {
|
| 630 |
# est.prop <- unlist( lav_model_gw(lavmodel = lavmodel, GLIST = GLIST) ) |
|
| 631 |
# obs.prop <- unlist(lavsamplestats@group.w) |
|
| 632 |
# FIXME: G2 based -- ML and friends only!! |
|
| 633 |
# dx.GW <- - (obs.prop - est.prop) |
|
| 634 | ||
| 635 |
# poisson version |
|
| 636 | ! |
est.freq <- exp(unlist(lav_model_gw(lavmodel = lavmodel, GLIST = GLIST))) |
| 637 | ! |
obs.freq <- unlist(lavsamplestats@group.w) * lavsamplestats@ntotal |
| 638 | ! |
dx.GW <- -(obs.freq - est.freq) |
| 639 |
# divide by N (to be consistent with the rest of lavaan) |
|
| 640 | ! |
dx.GW <- dx.GW / lavsamplestats@ntotal |
| 641 | ||
| 642 |
# remove last element (fixed LAST group to zero) |
|
| 643 |
# dx.GW <- dx.GW[-length(dx.GW)] |
|
| 644 | ||
| 645 |
# fill in in dx |
|
| 646 | ! |
gw.mat.idx <- which(names(lavmodel@GLIST) == "gw") |
| 647 | ! |
gw.x.idx <- unlist(lavmodel@x.free.idx[gw.mat.idx]) |
| 648 | ! |
dx[gw.x.idx] <- dx.GW |
| 649 |
} |
|
| 650 | ||
| 651 |
# dx is 1xnpar matrix of LIST (type != "free") |
|
| 652 | 8376x |
if (is.matrix(dx)) {
|
| 653 | 3823x |
dx <- as.numeric(dx) |
| 654 |
} |
|
| 655 | ||
| 656 | 8376x |
dx |
| 657 |
} |
|
| 658 | ||
| 659 |
# for testing purposes only |
|
| 660 |
lav_model_delta_numerical <- function(lavmodel = NULL, GLIST = NULL, g = 1L) {
|
|
| 661 | ||
| 662 |
# state or final? |
|
| 663 | ! |
if(is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 664 | ||
| 665 | ! |
compute.moments <- function(x) {
|
| 666 | ! |
GLIST <- lav_model_x2glist(lavmodel = lavmodel, x = x, type = "free") |
| 667 | ! |
Sigma.hat <- lav_model_sigma(lavmodel = lavmodel, GLIST = GLIST) |
| 668 | ! |
S.vec <- lav_matrix_vech(Sigma.hat[[g]]) |
| 669 | ! |
if(lavmodel@meanstructure) {
|
| 670 | ! |
Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST=GLIST) |
| 671 | ! |
out <- c(Mu.hat[[g]], S.vec) |
| 672 |
} else {
|
|
| 673 | ! |
out <- S.vec |
| 674 |
} |
|
| 675 | ! |
out |
| 676 |
} |
|
| 677 | ||
| 678 | ! |
x <- lav_model_get_parameters(lavmodel = lavmodel, |
| 679 | ! |
GLIST = GLIST, type = "free") |
| 680 | ! |
Delta <- lav_func_jacobian_complex(func = compute.moments, x = x) |
| 681 | ||
| 682 | ! |
Delta |
| 683 |
} |
|
| 684 | ||
| 685 | ||
| 686 |
### FIXME: should we here also: |
|
| 687 |
### - weight for groups? (no, for now) |
|
| 688 |
### - handle equality constraints? (yes, for now) |
|
| 689 |
lav_model_delta <- function(lavmodel = NULL, GLIST. = NULL, |
|
| 690 |
m.el.idx. = NULL, x.el.idx. = NULL, |
|
| 691 |
ceq.simple = FALSE, |
|
| 692 |
force.conditional.x.false = FALSE) {
|
|
| 693 | 4634x |
representation <- lavmodel@representation |
| 694 | 4634x |
categorical <- lavmodel@categorical |
| 695 | 4634x |
correlation <- lavmodel@correlation |
| 696 | 4634x |
conditional.x <- lavmodel@conditional.x |
| 697 | 4634x |
group.w.free <- lavmodel@group.w.free |
| 698 | 4634x |
nmat <- lavmodel@nmat |
| 699 | 4634x |
nblocks <- lavmodel@nblocks |
| 700 | 4634x |
nvar <- lavmodel@nvar |
| 701 | 4634x |
num.idx <- lavmodel@num.idx |
| 702 | 4634x |
th.idx <- lavmodel@th.idx |
| 703 | 4634x |
nexo <- lavmodel@nexo |
| 704 | 4634x |
parameterization <- lavmodel@parameterization |
| 705 | ||
| 706 |
# number of thresholds per group (if any) |
|
| 707 | 4634x |
nth <- sapply(th.idx, function(x) sum(x > 0L)) |
| 708 | ||
| 709 |
# state or final? |
|
| 710 | 4634x |
if (is.null(GLIST.)) {
|
| 711 | 156x |
GLIST <- lavmodel@GLIST |
| 712 |
} else {
|
|
| 713 | 4478x |
GLIST <- GLIST. |
| 714 |
} |
|
| 715 | ||
| 716 |
# type = "free" or something else? |
|
| 717 | 4634x |
type <- "nonfree" |
| 718 | 4634x |
m.el.idx <- m.el.idx. |
| 719 | 4634x |
x.el.idx <- x.el.idx. |
| 720 | 4634x |
if (is.null(m.el.idx) && is.null(x.el.idx)) {
|
| 721 | 4634x |
type <- "free" |
| 722 |
} |
|
| 723 | ||
| 724 |
# number of rows in DELTA.group |
|
| 725 | 4634x |
pstar <- integer(nblocks) |
| 726 | 4634x |
for (g in 1:nblocks) {
|
| 727 | 6606x |
pstar[g] <- as.integer(nvar[g] * (nvar[g] + 1) / 2) |
| 728 | 6606x |
if (lavmodel@meanstructure) {
|
| 729 | 5679x |
pstar[g] <- nvar[g] + pstar[g] # first the means, then sigma |
| 730 |
} |
|
| 731 | 6606x |
if (categorical) {
|
| 732 | 2719x |
pstar[g] <- pstar[g] - nvar[g] # remove variances |
| 733 | 2719x |
pstar[g] <- pstar[g] - nvar[g] # remove means |
| 734 | ||
| 735 | 2719x |
pstar[g] <- pstar[g] + nth[g] # add thresholds |
| 736 | 2719x |
pstar[g] <- pstar[g] + length(num.idx[[g]]) # add num means |
| 737 | 2719x |
pstar[g] <- pstar[g] + length(num.idx[[g]]) # add num vars |
| 738 | 3887x |
} else if (correlation) {
|
| 739 | ! |
pstar[g] <- pstar[g] - nvar[g] # remove variances |
| 740 |
} |
|
| 741 | 6606x |
if (conditional.x && nexo[g] > 0L) {
|
| 742 | 2719x |
pstar[g] <- pstar[g] + (nvar[g] * nexo[g]) # add slopes |
| 743 |
} |
|
| 744 | 6606x |
if (group.w.free) {
|
| 745 | ! |
pstar[g] <- pstar[g] + 1L # add group weight |
| 746 |
} |
|
| 747 |
} |
|
| 748 | ||
| 749 | ||
| 750 |
# number of columns in DELTA + m.el.idx/x.el.idx |
|
| 751 | 4634x |
if (type == "free") {
|
| 752 | 4634x |
if (lavmodel@ceq.simple.only) {
|
| 753 | ! |
NCOL <- lavmodel@nx.unco |
| 754 |
} else {
|
|
| 755 | 4634x |
NCOL <- lavmodel@nx.free |
| 756 |
} |
|
| 757 | 4634x |
m.el.idx <- x.el.idx <- vector("list", length = length(GLIST))
|
| 758 | 4634x |
for (mm in 1:length(GLIST)) {
|
| 759 | 48205x |
m.el.idx[[mm]] <- lavmodel@m.free.idx[[mm]] |
| 760 | 48205x |
if (lavmodel@ceq.simple.only) {
|
| 761 | ! |
x.el.idx[[mm]] <- lavmodel@x.unco.idx[[mm]] |
| 762 |
} else {
|
|
| 763 | 48205x |
x.el.idx[[mm]] <- lavmodel@x.free.idx[[mm]] |
| 764 |
} |
|
| 765 |
# handle symmetric matrices |
|
| 766 | 48205x |
if (lavmodel@isSymmetric[mm]) {
|
| 767 |
# since we use 'x.free.idx', only symmetric elements |
|
| 768 |
# are duplicated (not the equal ones, only in x.free.free) |
|
| 769 | 15931x |
dix <- duplicated(x.el.idx[[mm]]) |
| 770 | 15931x |
if (any(dix)) {
|
| 771 | 3626x |
m.el.idx[[mm]] <- m.el.idx[[mm]][!dix] |
| 772 | 3626x |
x.el.idx[[mm]] <- x.el.idx[[mm]][!dix] |
| 773 |
} |
|
| 774 |
} |
|
| 775 |
} |
|
| 776 |
} else {
|
|
| 777 |
## FIXME: this does *not* take into account symmetric |
|
| 778 |
## matrices; hence NCOL will be too large, and empty |
|
| 779 |
## columns will be added |
|
| 780 |
## this is ugly, but it doesn't hurt |
|
| 781 |
## alternative could be: |
|
| 782 |
## NCOL <- sum(unlist(lapply(x.el.idx, function(x) length(unique(x))))) |
|
| 783 |
# NCOL <- sum(unlist(lapply(m.el.idx, length))) |
|
| 784 | ! |
NCOL <- sum(unlist(lapply(x.el.idx, function(x) length(unique(x))))) |
| 785 |
# sanity check |
|
| 786 |
# nx <- sum(unlist(lapply(x.el.idx, length))) |
|
| 787 |
# stopifnot(NCOL == nx) |
|
| 788 |
} |
|
| 789 | ||
| 790 | ||
| 791 |
# compute Delta |
|
| 792 | 4634x |
Delta <- vector("list", length = nblocks)
|
| 793 | 4634x |
for (g in 1:nblocks) {
|
| 794 | 6606x |
Delta.group <- matrix(0, nrow = pstar[g], ncol = NCOL) |
| 795 | ||
| 796 |
# which mm belong to group g? |
|
| 797 | 6606x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 798 | ||
| 799 |
# label rows of Delta.group --- FIXME!!! |
|
| 800 |
# if(categorical) {
|
|
| 801 |
# # 1. th (means interleaved?) |
|
| 802 |
# # 2. pi |
|
| 803 |
# # 3. var num + cor |
|
| 804 |
# } else {
|
|
| 805 |
# if(meanstructure) {
|
|
| 806 |
# } |
|
| 807 |
# } |
|
| 808 |
# if(group.w.free) {
|
|
| 809 |
# } |
|
| 810 | ||
| 811 |
# if theta, do some preparation |
|
| 812 | 6606x |
if (representation == "LISREL" && parameterization == "theta") {
|
| 813 | ! |
sigma.hat <- lav_lisrel_sigma( |
| 814 | ! |
MLIST = GLIST[mm.in.group], |
| 815 | ! |
delta = FALSE |
| 816 |
) |
|
| 817 | ! |
dsigma <- diag(sigma.hat) |
| 818 |
# dcor/dcov for sigma |
|
| 819 | ! |
R <- lav_deriv_cov2cor(sigma.hat, num.idx = lavmodel@num.idx[[g]]) |
| 820 | ! |
theta.var.idx <- lav_matrix_diagh_idx(nvar[g]) |
| 821 |
} |
|
| 822 | ||
| 823 | 6606x |
for (mm in mm.in.group) {
|
| 824 | 48205x |
mname <- names(lavmodel@GLIST)[mm] |
| 825 | ||
| 826 |
# skip empty ones |
|
| 827 | 17503x |
if (!length(m.el.idx[[mm]])) next |
| 828 | ||
| 829 |
# get Delta columns for this model matrix |
|
| 830 | 30702x |
if (representation == "LISREL") {
|
| 831 |
# Sigma |
|
| 832 | 30702x |
DELTA <- dxSigma <- |
| 833 | 30702x |
lav_lisrel_dsigma_dx( |
| 834 | 30702x |
MLIST = GLIST[mm.in.group], |
| 835 | 30702x |
m = mname, |
| 836 | 30702x |
idx = m.el.idx[[mm]], |
| 837 | 30702x |
delta = parameterization == "delta" |
| 838 |
) |
|
| 839 | 30702x |
if (categorical && parameterization == "theta") {
|
| 840 | ! |
DELTA <- R %*% DELTA |
| 841 |
} |
|
| 842 | ||
| 843 | 30702x |
if (categorical) {
|
| 844 |
# reorder: first variances (of numeric), then covariances |
|
| 845 | 19009x |
cov.idx <- lav_matrix_vech_idx(nvar[g]) |
| 846 | 19009x |
covd.idx <- lav_matrix_vech_idx(nvar[g], diagonal = FALSE) |
| 847 | ||
| 848 | 19009x |
var.idx <- which(is.na(match( |
| 849 | 19009x |
cov.idx, |
| 850 | 19009x |
covd.idx |
| 851 | 19009x |
)))[num.idx[[g]]] |
| 852 | 19009x |
cor.idx <- match(covd.idx, cov.idx) |
| 853 | ||
| 854 | 19009x |
DELTA <- rbind( |
| 855 | 19009x |
DELTA[var.idx, , drop = FALSE], |
| 856 | 19009x |
DELTA[cor.idx, , drop = FALSE] |
| 857 |
) |
|
| 858 |
} |
|
| 859 | ||
| 860 |
# correlation structure? |
|
| 861 | 30702x |
if (!categorical && correlation) {
|
| 862 | ! |
rm.idx <- lav_matrix_diagh_idx(nvar[g]) |
| 863 | ! |
DELTA <- DELTA[-rm.idx, , drop = FALSE] |
| 864 |
} |
|
| 865 | ||
| 866 | 30702x |
if (!categorical) {
|
| 867 | 11693x |
if (conditional.x) {
|
| 868 |
# means/intercepts |
|
| 869 | ! |
DELTA.mu <- lav_lisrel_dmu_dx( |
| 870 | ! |
MLIST = GLIST[mm.in.group], |
| 871 | ! |
m = mname, |
| 872 | ! |
idx = m.el.idx[[mm]] |
| 873 |
) |
|
| 874 | ||
| 875 |
# slopes |
|
| 876 | ! |
if (lavmodel@nexo[g] > 0L) {
|
| 877 | ! |
DELTA.pi <- lav_lisrel_dpi_dx( |
| 878 | ! |
MLIST = GLIST[mm.in.group], |
| 879 | ! |
m = mname, |
| 880 | ! |
idx = m.el.idx[[mm]] |
| 881 |
) |
|
| 882 | ||
| 883 | ! |
if (lavmodel@multilevel) {
|
| 884 | ! |
DELTA <- rbind(DELTA.mu, DELTA.pi, DELTA) |
| 885 |
} else {
|
|
| 886 |
# ATTENTION: we need to change the order here |
|
| 887 |
# lav_mvreg_scores_* uses 'Beta' where the |
|
| 888 |
# the intercepts are just the first row |
|
| 889 |
# using the col-major approach, we need to |
|
| 890 |
# interweave the intercepts with the slopes! |
|
| 891 | ||
| 892 | ! |
nEls <- NROW(DELTA.mu) + NROW(DELTA.pi) |
| 893 |
# = (nexo + 1 int) * nvar |
|
| 894 | ||
| 895 |
# intercepts on top |
|
| 896 | ! |
tmp <- rbind(DELTA.mu, DELTA.pi) |
| 897 |
# change row index |
|
| 898 | ! |
row.idx <- lav_matrix_vec(matrix(seq.int(nEls), |
| 899 | ! |
nrow = lavmodel@nexo[g] + 1L, |
| 900 | ! |
ncol = lavmodel@nvar[g], byrow = TRUE |
| 901 |
)) |
|
| 902 | ! |
DELTA.beta <- tmp[row.idx, , drop = FALSE] |
| 903 | ! |
DELTA <- rbind(DELTA.beta, DELTA) |
| 904 |
} |
|
| 905 |
} else {
|
|
| 906 | ! |
DELTA <- rbind(DELTA.mu, DELTA) |
| 907 |
} |
|
| 908 | 11693x |
} else if (!conditional.x && lavmodel@meanstructure) {
|
| 909 | 8812x |
DELTA.mu <- lav_lisrel_dmu_dx( |
| 910 | 8812x |
MLIST = GLIST[mm.in.group], |
| 911 | 8812x |
m = mname, |
| 912 | 8812x |
idx = m.el.idx[[mm]] |
| 913 |
) |
|
| 914 | 8812x |
DELTA <- rbind(DELTA.mu, DELTA) |
| 915 |
} |
|
| 916 | 19009x |
} else if (categorical) {
|
| 917 | 19009x |
DELTA.th <- lav_lisrel_dth_dx( |
| 918 | 19009x |
MLIST = GLIST[mm.in.group], |
| 919 | 19009x |
m = mname, |
| 920 | 19009x |
idx = m.el.idx[[mm]], |
| 921 | 19009x |
th.idx = th.idx[[g]], |
| 922 | 19009x |
delta = TRUE |
| 923 |
) |
|
| 924 | 19009x |
if (parameterization == "theta") {
|
| 925 |
# dy/ddsigma = -0.5/(ddsigma*sqrt(ddsigma)) |
|
| 926 | ! |
dDelta.dx <- |
| 927 | ! |
(dxSigma[theta.var.idx, , drop = FALSE] * |
| 928 | ! |
-0.5 / (dsigma * sqrt(dsigma))) |
| 929 | ! |
dth.dDelta <- |
| 930 | ! |
lav_lisrel_dth_dx( |
| 931 | ! |
MLIST = GLIST[mm.in.group], |
| 932 | ! |
m = "delta", |
| 933 | ! |
idx = 1:nvar[g], |
| 934 | ! |
th.idx = th.idx[[g]] |
| 935 |
) |
|
| 936 |
# add dth.dDelta %*% dDelta.dx |
|
| 937 | ! |
no.num.idx <- which(th.idx[[g]] > 0) |
| 938 | ! |
DELTA.th[no.num.idx, ] <- |
| 939 | ! |
DELTA.th[no.num.idx, , drop = FALSE] + |
| 940 | ! |
(dth.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE] |
| 941 |
} |
|
| 942 | 19009x |
if (conditional.x && lavmodel@nexo[g] > 0L) {
|
| 943 | 19009x |
DELTA.pi <- |
| 944 | 19009x |
lav_lisrel_dpi_dx( |
| 945 | 19009x |
MLIST = GLIST[mm.in.group], |
| 946 | 19009x |
m = mname, |
| 947 | 19009x |
idx = m.el.idx[[mm]] |
| 948 |
) |
|
| 949 | 19009x |
if (parameterization == "theta") {
|
| 950 | ! |
dpi.dDelta <- |
| 951 | ! |
lav_lisrel_dpi_dx( |
| 952 | ! |
MLIST = GLIST[mm.in.group], |
| 953 | ! |
m = "delta", |
| 954 | ! |
idx = 1:nvar[g] |
| 955 |
) |
|
| 956 |
# add dpi.dDelta %*% dDelta.dx |
|
| 957 | ! |
no.num.idx <- |
| 958 | ! |
which(!seq.int(1L, nvar[g]) %in% num.idx[[g]]) |
| 959 | ! |
no.num.idx <- rep(seq.int(0, nexo[g] - 1) * nvar[g], |
| 960 | ! |
each = length(no.num.idx) |
| 961 | ! |
) + no.num.idx |
| 962 | ! |
DELTA.pi[no.num.idx, ] <- |
| 963 | ! |
DELTA.pi[no.num.idx, , drop = FALSE] + |
| 964 | ! |
(dpi.dDelta %*% dDelta.dx)[no.num.idx, , drop = FALSE] |
| 965 |
} |
|
| 966 | 19009x |
DELTA <- rbind(DELTA.th, DELTA.pi, DELTA) |
| 967 |
} else {
|
|
| 968 | ! |
DELTA <- rbind(DELTA.th, DELTA) |
| 969 |
} |
|
| 970 |
} |
|
| 971 | 30702x |
if (group.w.free) {
|
| 972 | ! |
DELTA.gw <- lav_lisrel_dgw_dx( |
| 973 | ! |
MLIST = GLIST[mm.in.group], |
| 974 | ! |
m = mname, |
| 975 | ! |
idx = m.el.idx[[mm]] |
| 976 |
) |
|
| 977 | ! |
DELTA <- rbind(DELTA.gw, DELTA) |
| 978 |
} |
|
| 979 | ! |
} else if (representation == "RAM") {
|
| 980 | ! |
DELTA <- dxSigma <- |
| 981 | ! |
lav_ram_dsigma( |
| 982 | ! |
m = mname, |
| 983 | ! |
idx = m.el.idx[[mm]], |
| 984 | ! |
MLIST = GLIST[mm.in.group] |
| 985 |
) |
|
| 986 | ! |
if (lavmodel@meanstructure) {
|
| 987 | ! |
DELTA.mu <- lav_ram_dmu( |
| 988 | ! |
m = mname, |
| 989 | ! |
idx = m.el.idx[[mm]], |
| 990 | ! |
MLIST = GLIST[mm.in.group] |
| 991 |
) |
|
| 992 | ! |
DELTA <- rbind(DELTA.mu, DELTA) |
| 993 |
} |
|
| 994 |
} else {
|
|
| 995 | ! |
lav_msg_stop(gettextf("representation %s not implemented yet",
|
| 996 | ! |
representation)) |
| 997 |
} |
|
| 998 | 30702x |
Delta.group[, x.el.idx[[mm]]] <- DELTA |
| 999 |
} # mm |
|
| 1000 | ||
| 1001 |
# if type == "free" take care of equality constraints |
|
| 1002 | 6606x |
if (type == "free" && ceq.simple && lavmodel@ceq.simple.only) {
|
| 1003 | ! |
Delta.group <- Delta.group %*% lavmodel@ceq.simple.K |
| 1004 |
} |
|
| 1005 | ||
| 1006 | 6606x |
Delta[[g]] <- Delta.group |
| 1007 |
} # g |
|
| 1008 | ||
| 1009 |
# if multilevel, rbind levels within group |
|
| 1010 | 4634x |
if (lavmodel@multilevel) {
|
| 1011 | 656x |
DELTA <- vector("list", length = lavmodel@ngroups)
|
| 1012 | 656x |
for (g in 1:lavmodel@ngroups) {
|
| 1013 | 1312x |
DELTA[[g]] <- rbind( |
| 1014 | 1312x |
Delta[[(g - 1) * 2 + 1]], |
| 1015 | 1312x |
Delta[[(g - 1) * 2 + 2]] |
| 1016 |
) |
|
| 1017 |
} |
|
| 1018 | 656x |
Delta <- DELTA |
| 1019 |
} |
|
| 1020 | ||
| 1021 | 4634x |
Delta |
| 1022 |
} |
|
| 1023 | ||
| 1024 |
lav_model_ddelta_dx <- function(lavmodel = NULL, GLIST = NULL, target = "lambda", |
|
| 1025 |
ceq.simple = FALSE) {
|
|
| 1026 |
# state or final? |
|
| 1027 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 1028 | ||
| 1029 | ! |
representation <- lavmodel@representation |
| 1030 | ! |
nmat <- lavmodel@nmat |
| 1031 | ! |
nblocks <- lavmodel@nblocks |
| 1032 | ! |
th.idx <- lavmodel@th.idx |
| 1033 | ||
| 1034 |
# number of columns in DELTA + m.el.idx/x.el.idx |
|
| 1035 | ! |
type <- "free" |
| 1036 |
# if(type == "free") {
|
|
| 1037 | ! |
if (lavmodel@ceq.simple.only) {
|
| 1038 | ! |
NCOL <- lavmodel@nx.unco |
| 1039 |
} else {
|
|
| 1040 | ! |
NCOL <- lavmodel@nx.free |
| 1041 |
} |
|
| 1042 | ! |
m.el.idx <- x.el.idx <- vector("list", length = length(GLIST))
|
| 1043 | ! |
for (mm in 1:length(GLIST)) {
|
| 1044 | ! |
m.el.idx[[mm]] <- lavmodel@m.free.idx[[mm]] |
| 1045 | ! |
if (lavmodel@ceq.simple.only) {
|
| 1046 | ! |
x.el.idx[[mm]] <- lavmodel@x.unco.idx[[mm]] |
| 1047 |
} else {
|
|
| 1048 | ! |
x.el.idx[[mm]] <- lavmodel@x.free.idx[[mm]] |
| 1049 |
} |
|
| 1050 |
# handle symmetric matrices |
|
| 1051 | ! |
if (lavmodel@isSymmetric[mm]) {
|
| 1052 |
# since we use 'x.free.idx', only symmetric elements |
|
| 1053 |
# are duplicated (not the equal ones, only in x.free.free) |
|
| 1054 | ! |
dix <- duplicated(x.el.idx[[mm]]) |
| 1055 | ! |
if (any(dix)) {
|
| 1056 | ! |
m.el.idx[[mm]] <- m.el.idx[[mm]][!dix] |
| 1057 | ! |
x.el.idx[[mm]] <- x.el.idx[[mm]][!dix] |
| 1058 |
} |
|
| 1059 |
} |
|
| 1060 |
} |
|
| 1061 |
# } else {
|
|
| 1062 |
# NCOL <- sum(unlist(lapply(x.el.idx, function(x) length(unique(x))))) |
|
| 1063 |
# } |
|
| 1064 | ||
| 1065 |
# compute Delta per group |
|
| 1066 | ! |
Delta <- vector("list", length = nblocks)
|
| 1067 | ! |
for (g in 1:nblocks) {
|
| 1068 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 1069 | ! |
Delta.group <- NULL |
| 1070 | ! |
for (mm in mm.in.group) {
|
| 1071 | ! |
mname <- names(lavmodel@GLIST)[mm] |
| 1072 | ||
| 1073 |
# skip empty ones |
|
| 1074 | ! |
if (!length(m.el.idx[[mm]])) next |
| 1075 | ||
| 1076 |
# get Delta columns for this model matrix |
|
| 1077 | ! |
if (representation == "LISREL") {
|
| 1078 | ! |
if (target == "lambda") {
|
| 1079 | ! |
DELTA <- lav_lisrel_dlambda_dx( |
| 1080 | ! |
MLIST = GLIST[mm.in.group], |
| 1081 | ! |
m = mname, |
| 1082 | ! |
idx = m.el.idx[[mm]] |
| 1083 |
) |
|
| 1084 | ! |
} else if (target == "th") {
|
| 1085 | ! |
DELTA <- lav_lisrel_dth_dx( |
| 1086 | ! |
MLIST = GLIST[mm.in.group], m = mname, th.idx = th.idx[[g]], |
| 1087 | ! |
idx = m.el.idx[[mm]], |
| 1088 | ! |
delta = TRUE |
| 1089 |
) |
|
| 1090 | ! |
} else if (target == "mu") {
|
| 1091 | ! |
DELTA <- lav_lisrel_dmu_dx( |
| 1092 | ! |
MLIST = GLIST[mm.in.group], |
| 1093 | ! |
m = mname, |
| 1094 | ! |
idx = m.el.idx[[mm]] |
| 1095 |
) |
|
| 1096 | ! |
} else if (target == "nu") {
|
| 1097 | ! |
DELTA <- lav_lisrel_dnu_dx( |
| 1098 | ! |
MLIST = GLIST[mm.in.group], |
| 1099 | ! |
m = mname, |
| 1100 | ! |
idx = m.el.idx[[mm]] |
| 1101 |
) |
|
| 1102 | ! |
} else if (target == "tau") {
|
| 1103 | ! |
DELTA <- lav_lisrel_dtau_dx( |
| 1104 | ! |
MLIST = GLIST[mm.in.group], |
| 1105 | ! |
m = mname, |
| 1106 | ! |
idx = m.el.idx[[mm]] |
| 1107 |
) |
|
| 1108 | ! |
} else if (target == "theta") {
|
| 1109 | ! |
DELTA <- lav_lisrel_dtheta_dx( |
| 1110 | ! |
MLIST = GLIST[mm.in.group], |
| 1111 | ! |
m = mname, |
| 1112 | ! |
idx = m.el.idx[[mm]] |
| 1113 |
) |
|
| 1114 | ! |
} else if (target == "gamma") {
|
| 1115 | ! |
DELTA <- lav_lisrel_dgamma_dx( |
| 1116 | ! |
MLIST = GLIST[mm.in.group], |
| 1117 | ! |
m = mname, |
| 1118 | ! |
idx = m.el.idx[[mm]] |
| 1119 |
) |
|
| 1120 | ! |
} else if (target == "beta") {
|
| 1121 | ! |
DELTA <- lav_lisrel_dbeta_dx( |
| 1122 | ! |
MLIST = GLIST[mm.in.group], |
| 1123 | ! |
m = mname, |
| 1124 | ! |
idx = m.el.idx[[mm]] |
| 1125 |
) |
|
| 1126 | ! |
} else if (target == "alpha") {
|
| 1127 | ! |
DELTA <- lav_lisrel_dalpha_dx( |
| 1128 | ! |
MLIST = GLIST[mm.in.group], |
| 1129 | ! |
m = mname, |
| 1130 | ! |
idx = m.el.idx[[mm]] |
| 1131 |
) |
|
| 1132 | ! |
} else if (target == "psi") {
|
| 1133 | ! |
DELTA <- lav_lisrel_dpsi_dx( |
| 1134 | ! |
MLIST = GLIST[mm.in.group], |
| 1135 | ! |
m = mname, |
| 1136 | ! |
idx = m.el.idx[[mm]] |
| 1137 |
) |
|
| 1138 | ! |
} else if (target == "sigma") {
|
| 1139 | ! |
DELTA <- lav_lisrel_dsigma_dx( |
| 1140 | ! |
MLIST = GLIST[mm.in.group], |
| 1141 | ! |
m = mname, |
| 1142 | ! |
idx = m.el.idx[[mm]], |
| 1143 | ! |
delta = TRUE |
| 1144 |
) |
|
| 1145 |
} else {
|
|
| 1146 | ! |
lav_msg_stop(gettextf("target %s not implemented yet", target))
|
| 1147 |
} |
|
| 1148 | ||
| 1149 |
# initialize? |
|
| 1150 | ! |
if (is.null(Delta.group)) {
|
| 1151 | ! |
Delta.group <- matrix(0, nrow = nrow(DELTA), ncol = NCOL) |
| 1152 |
} |
|
| 1153 | ! |
Delta.group[, x.el.idx[[mm]]] <- DELTA |
| 1154 |
} |
|
| 1155 |
} # mm |
|
| 1156 | ||
| 1157 | ! |
if (type == "free" && ceq.simple && lavmodel@ceq.simple.only) {
|
| 1158 | ! |
Delta.group <- Delta.group %*% lavmodel@ceq.simple.K |
| 1159 |
} |
|
| 1160 | ||
| 1161 | ! |
Delta[[g]] <- Delta.group |
| 1162 |
} # g |
|
| 1163 | ||
| 1164 | ! |
Delta |
| 1165 |
} |
|
| 1166 | ||
| 1167 |
lav_model_omega <- function(Sigma.hat = NULL, Mu.hat = NULL, |
|
| 1168 |
lavsamplestats = NULL, estimator = "ML", |
|
| 1169 |
meanstructure = FALSE, conditional.x = FALSE, |
|
| 1170 |
correlation = FALSE) {
|
|
| 1171 |
# nblocks |
|
| 1172 | 3898x |
nblocks <- length(Sigma.hat) |
| 1173 | ||
| 1174 | 3898x |
Omega <- vector("list", length = nblocks)
|
| 1175 | 3898x |
Omega.mu <- vector("list", length = nblocks)
|
| 1176 | ||
| 1177 | 3898x |
for (g in 1:nblocks) {
|
| 1178 |
# ML |
|
| 1179 | 4264x |
if (estimator %in% c("ML", "REML", "catML")) {
|
| 1180 | 4264x |
if (attr(Sigma.hat[[g]], "po") == FALSE) {
|
| 1181 |
# FIXME: WHAT IS THE BEST THING TO DO HERE?? |
|
| 1182 |
# CURRENTLY: stop |
|
| 1183 | ! |
lav_msg_warn(gettext( |
| 1184 | ! |
"lav_model_gradient: Sigma.hat is not positive definite\n")) |
| 1185 | ! |
Sigma.hat.inv <- MASS::ginv(Sigma.hat[[g]]) |
| 1186 |
} else {
|
|
| 1187 | 4264x |
Sigma.hat.inv <- attr(Sigma.hat[[g]], "inv") |
| 1188 |
} |
|
| 1189 | ||
| 1190 | 4264x |
if (!lavsamplestats@missing.flag) { # complete data
|
| 1191 | 2934x |
if (meanstructure) {
|
| 1192 | 2041x |
if (conditional.x) {
|
| 1193 | ! |
diff <- lavsamplestats@res.int[[g]] - Mu.hat[[g]] |
| 1194 | ! |
W.tilde <- lavsamplestats@res.cov[[g]] + tcrossprod(diff) |
| 1195 |
} else {
|
|
| 1196 | 2041x |
diff <- lavsamplestats@mean[[g]] - Mu.hat[[g]] |
| 1197 | 2041x |
W.tilde <- lavsamplestats@cov[[g]] + tcrossprod(diff) |
| 1198 |
} |
|
| 1199 |
# Browne 1995 eq 4.55 |
|
| 1200 | 2041x |
Omega.mu[[g]] <- t(t(diff) %*% Sigma.hat.inv) |
| 1201 | 2041x |
Omega[[g]] <- |
| 1202 | 2041x |
(Sigma.hat.inv %*% (W.tilde - Sigma.hat[[g]]) %*% |
| 1203 | 2041x |
Sigma.hat.inv) |
| 1204 |
} else {
|
|
| 1205 | 893x |
if (conditional.x) {
|
| 1206 | ! |
W.tilde <- lavsamplestats@res.cov[[g]] |
| 1207 |
} else {
|
|
| 1208 | 893x |
W.tilde <- lavsamplestats@cov[[g]] |
| 1209 |
} |
|
| 1210 | 893x |
Omega[[g]] <- |
| 1211 | 893x |
(Sigma.hat.inv %*% (W.tilde - Sigma.hat[[g]]) %*% |
| 1212 | 893x |
Sigma.hat.inv) |
| 1213 |
} |
|
| 1214 |
} else { # missing data
|
|
| 1215 | 1330x |
M <- lavsamplestats@missing[[g]] |
| 1216 | ||
| 1217 | 1330x |
nvar <- ncol(lavsamplestats@cov[[g]]) |
| 1218 | 1330x |
OMEGA <- matrix(0, nvar, nvar) |
| 1219 | 1330x |
OMEGA.MU <- matrix(0, nvar, 1) |
| 1220 | ||
| 1221 | 1330x |
for (p in 1:length(M)) {
|
| 1222 | 3459x |
SX <- M[[p]][["SY"]] |
| 1223 | 3459x |
MX <- M[[p]][["MY"]] |
| 1224 | 3459x |
nobs <- M[[p]][["freq"]] |
| 1225 | 3459x |
var.idx <- M[[p]][["var.idx"]] |
| 1226 | ||
| 1227 | 3459x |
Sigma.inv <- chol2inv(chol(Sigma.hat[[g]][var.idx, var.idx])) |
| 1228 | 3459x |
Mu <- Mu.hat[[g]][var.idx] |
| 1229 | 3459x |
W.tilde <- SX + tcrossprod(MX - Mu) |
| 1230 | ||
| 1231 | 3459x |
OMEGA.MU[var.idx, 1] <- |
| 1232 | 3459x |
(OMEGA.MU[var.idx, 1] + nobs / lavsamplestats@ntotal * |
| 1233 | 3459x |
t(t(MX - Mu) %*% Sigma.inv)) |
| 1234 | ||
| 1235 | 3459x |
OMEGA[var.idx, var.idx] <- |
| 1236 | 3459x |
(OMEGA[var.idx, var.idx] + nobs / lavsamplestats@ntotal * |
| 1237 | 3459x |
(Sigma.inv %*% |
| 1238 | 3459x |
(W.tilde - Sigma.hat[[g]][var.idx, var.idx]) %*% |
| 1239 | 3459x |
Sigma.inv)) |
| 1240 |
} |
|
| 1241 | 1330x |
Omega.mu[[g]] <- OMEGA.MU |
| 1242 | 1330x |
Omega[[g]] <- OMEGA |
| 1243 |
} # missing |
|
| 1244 | ||
| 1245 |
# GLS |
|
| 1246 | ! |
} else if (estimator == "GLS") {
|
| 1247 | ! |
W.inv <- lavsamplestats@icov[[g]] |
| 1248 | ! |
W <- lavsamplestats@cov[[g]] |
| 1249 | ! |
Omega[[g]] <- (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]] * |
| 1250 | ! |
(W.inv %*% (W - Sigma.hat[[g]]) %*% W.inv) |
| 1251 | ! |
if (meanstructure) {
|
| 1252 | ! |
diff <- as.matrix(lavsamplestats@mean[[g]] - Mu.hat[[g]]) |
| 1253 | ! |
Omega.mu[[g]] <- t(t(diff) %*% W.inv) |
| 1254 |
} |
|
| 1255 |
} |
|
| 1256 | ||
| 1257 |
# new in 0.6-18 |
|
| 1258 | 4264x |
if(correlation) {
|
| 1259 | ! |
diag(Omega[[g]]) <- 0 |
| 1260 |
} |
|
| 1261 |
} # g |
|
| 1262 | ||
| 1263 | 3005x |
if (meanstructure) attr(Omega, "mu") <- Omega.mu |
| 1264 | ||
| 1265 | 3898x |
Omega |
| 1266 |
} |
|
| 1267 | ||
| 1268 |
lav_model_gradient_DD <- function(lavmodel, GLIST = NULL, group = 1L) {
|
|
| 1269 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 1270 | ||
| 1271 |
#### FIX th + mu!!!!! |
|
| 1272 | ! |
Delta.lambda <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "lambda")[[group]] |
| 1273 | ! |
Delta.tau <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "tau")[[group]] |
| 1274 | ! |
Delta.nu <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "nu")[[group]] |
| 1275 | ! |
Delta.theta <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "theta")[[group]] |
| 1276 | ! |
Delta.beta <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "beta")[[group]] |
| 1277 | ! |
Delta.psi <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "psi")[[group]] |
| 1278 | ! |
Delta.alpha <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "alpha")[[group]] |
| 1279 | ! |
Delta.gamma <- lav_model_ddelta_dx(lavmodel, GLIST = GLIST, target = "gamma")[[group]] |
| 1280 | ||
| 1281 | ! |
ov.y.dummy.ov.idx <- lavmodel@ov.y.dummy.ov.idx[[group]] |
| 1282 | ! |
ov.x.dummy.ov.idx <- lavmodel@ov.x.dummy.ov.idx[[group]] |
| 1283 | ! |
ov.y.dummy.lv.idx <- lavmodel@ov.y.dummy.lv.idx[[group]] |
| 1284 | ! |
ov.x.dummy.lv.idx <- lavmodel@ov.x.dummy.lv.idx[[group]] |
| 1285 | ! |
ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx) |
| 1286 | ! |
lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 1287 | ! |
th.idx <- lavmodel@th.idx[[group]] |
| 1288 | ! |
num.idx <- lavmodel@num.idx[[group]] |
| 1289 | ! |
ord.idx <- unique(th.idx[th.idx > 0L]) |
| 1290 | ||
| 1291 |
# fix Delta's... |
|
| 1292 | ! |
mm.in.group <- 1:lavmodel@nmat[group] + cumsum(c(0, lavmodel@nmat))[group] |
| 1293 | ! |
MLIST <- GLIST[mm.in.group] |
| 1294 | ||
| 1295 | ! |
DD <- list() |
| 1296 | ! |
nvar <- lavmodel@nvar |
| 1297 | ! |
nfac <- ncol(MLIST$lambda) - length(lv.dummy.idx) |
| 1298 | ||
| 1299 |
# DD$theta |
|
| 1300 | ! |
theta.idx <- lav_matrix_diagh_idx(nvar) |
| 1301 | ! |
DD$theta <- Delta.theta[theta.idx, , drop = FALSE] |
| 1302 | ! |
if (length(ov.dummy.idx) > 0L) {
|
| 1303 | ! |
psi.idx <- lav_matrix_diagh_idx(ncol(MLIST$psi))[lv.dummy.idx] |
| 1304 | ! |
DD$theta[ov.dummy.idx, ] <- Delta.psi[psi.idx, , drop = FALSE] |
| 1305 |
} |
|
| 1306 |
# num only? FIXME or just all of them? |
|
| 1307 | ! |
DD$theta <- DD$theta[num.idx, , drop = FALSE] |
| 1308 | ||
| 1309 |
# DD$nu |
|
| 1310 | ! |
DD$nu <- Delta.nu |
| 1311 | ! |
if (length(ov.dummy.idx) > 0L) {
|
| 1312 | ! |
DD$nu[ov.dummy.idx, ] <- Delta.alpha[lv.dummy.idx, ] |
| 1313 |
} |
|
| 1314 | ! |
DD$nu <- DD$nu[num.idx, , drop = FALSE] # needed? |
| 1315 | ||
| 1316 |
# DD$lambda |
|
| 1317 | ! |
nr <- nvar |
| 1318 | ! |
nc <- nfac |
| 1319 | ! |
lambda.idx <- nr * ((1:nc) - 1L) + rep(1:nvar, each = nc) |
| 1320 | ! |
DD$lambda <- Delta.lambda[lambda.idx, , drop = FALSE] |
| 1321 | ! |
if (length(ov.dummy.idx) > 0L) {
|
| 1322 | ! |
nr <- nrow(MLIST$beta) |
| 1323 | ! |
nc <- nfac # only the first 1:nfac columns |
| 1324 |
# beta.idx <- rep(nr*((1:nc) - 1L), each=length(lv.dummy.idx)) + rep(lv.dummy.idx, times=nc) ## FIXME |
|
| 1325 | ! |
beta.idx <- rep(nr * ((1:nc) - 1L), times = length(lv.dummy.idx)) + rep(lv.dummy.idx, each = nc) |
| 1326 | ||
| 1327 |
# l.idx <- inr*((1:nc) - 1L) + rep(ov.dummy.idx, each=nc) ## FIXME |
|
| 1328 |
# l.idx <- rep(nr*((1:nc) - 1L), each=length(ov.dummy.idx)) + rep(ov.dummy.idx, times=nc) |
|
| 1329 | ! |
l.idx <- rep(nr * ((1:nc) - 1L), times = length(ov.dummy.idx)) + rep(ov.dummy.idx, each = nc) |
| 1330 | ! |
DD$lambda[match(l.idx, lambda.idx), ] <- Delta.beta[beta.idx, , drop = FALSE] |
| 1331 |
} |
|
| 1332 | ||
| 1333 |
# DD$KAPPA |
|
| 1334 | ! |
DD$kappa <- Delta.gamma |
| 1335 | ! |
if (length(ov.dummy.idx) > 0L) {
|
| 1336 | ! |
nr <- nrow(MLIST$gamma) |
| 1337 | ! |
nc <- ncol(MLIST$gamma) |
| 1338 | ! |
kappa.idx <- nr * ((1:nc) - 1L) + rep(lv.dummy.idx, each = nc) |
| 1339 | ! |
DD$kappa <- DD$kappa[kappa.idx, , drop = FALSE] |
| 1340 |
} |
|
| 1341 | ||
| 1342 |
# DD$GAMMA |
|
| 1343 | ! |
if (!is.null(MLIST$gamma)) {
|
| 1344 | ! |
nr <- nrow(MLIST$gamma) |
| 1345 | ! |
nc <- ncol(MLIST$gamma) |
| 1346 | ! |
lv.idx <- 1:nfac |
| 1347 |
# MUST BE ROWWISE! |
|
| 1348 | ! |
gamma.idx <- rep(nr * ((1:nc) - 1L), times = length(lv.idx)) + rep(lv.idx, each = nc) |
| 1349 | ! |
DD$gamma <- Delta.gamma[gamma.idx, , drop = FALSE] |
| 1350 |
} |
|
| 1351 | ||
| 1352 |
# DD$BETA |
|
| 1353 | ! |
if (!is.null(MLIST$beta)) {
|
| 1354 | ! |
nr <- nc <- nrow(MLIST$beta) |
| 1355 | ! |
lv.idx <- 1:nfac |
| 1356 |
# MUST BE ROWWISE! |
|
| 1357 | ! |
beta.idx <- rep(nr * ((1:nfac) - 1L), times = nfac) + rep(lv.idx, each = nfac) |
| 1358 | ! |
DD$beta <- Delta.beta[beta.idx, , drop = FALSE] |
| 1359 |
} |
|
| 1360 | ||
| 1361 |
## DD$psi |
|
| 1362 | ! |
DD$psi <- Delta.psi |
| 1363 | ! |
if (length(lv.dummy.idx) > 0L) {
|
| 1364 | ! |
nr <- nc <- nrow(MLIST$psi) |
| 1365 | ! |
lv.idx <- 1:nfac |
| 1366 |
# MUST BE ROWWISE! |
|
| 1367 | ! |
psi.idx <- rep(nr * ((1:nfac) - 1L), times = nfac) + rep(lv.idx, each = nfac) |
| 1368 | ||
| 1369 | ! |
DD$psi <- DD$psi[psi.idx, , drop = FALSE] |
| 1370 |
} |
|
| 1371 | ||
| 1372 |
## DD$tau |
|
| 1373 | ! |
if (!is.null(MLIST$tau)) {
|
| 1374 | ! |
DD$tau <- Delta.tau |
| 1375 |
} |
|
| 1376 | ||
| 1377 | ! |
DD |
| 1378 |
} |
| 1 |
# This file will (eventually) contain functions that can be used to |
|
| 2 |
# 'predict' the values of outcome variables (y), given the values of |
|
| 3 |
# input variables (x). |
|
| 4 | ||
| 5 |
# first version YR 2 Nov 2022 |
|
| 6 | ||
| 7 |
# method = "conditional.mean" is based on the following article: |
|
| 8 | ||
| 9 |
# Mark de Rooij, Julian D. Karch, Marjolein Fokkema, Zsuzsa Bakk, Bunga Citra |
|
| 10 |
# Pratiwi & Henk Kelderman (2022) SEM-Based Out-of-Sample Predictions, |
|
| 11 |
# StructuralEquation Modeling: A Multidisciplinary Journal |
|
| 12 |
# DOI:10.1080/10705511.2022.2061494 |
|
| 13 | ||
| 14 |
# YR 31 Jan 2023: we always 'force' meanstructure = TRUE (for now) |
|
| 15 | ||
| 16 |
# main function |
|
| 17 |
lavPredictY <- function(object, |
|
| 18 |
newdata = NULL, |
|
| 19 |
ynames = lav_object_vnames(object, "ov.y"), |
|
| 20 |
xnames = lav_object_vnames(object, "ov.x"), |
|
| 21 |
method = "conditional.mean", |
|
| 22 |
label = TRUE, |
|
| 23 |
assemble = TRUE, |
|
| 24 |
force.zero.mean = FALSE, |
|
| 25 |
lambda = 0) {
|
|
| 26 | ! |
stopifnot(inherits(object, "lavaan")) |
| 27 |
# check object |
|
| 28 | ! |
object <- lav_object_check_version(object) |
| 29 | ||
| 30 | ! |
lavmodel <- object@Model |
| 31 | ! |
lavdata <- object@Data |
| 32 | ! |
lavimplied <- object@implied |
| 33 | ||
| 34 |
# check meanstructure |
|
| 35 | ! |
if (!lavmodel@meanstructure) {
|
| 36 | ! |
lavimplied$mean <- lapply(object@SampleStats@mean, as.matrix) |
| 37 |
} |
|
| 38 | ||
| 39 |
# need full data set |
|
| 40 | ! |
if (is.null(newdata)) {
|
| 41 |
# use internal copy: |
|
| 42 | ! |
if (lavdata@data.type != "full") {
|
| 43 | ! |
lav_msg_stop(gettext( |
| 44 | ! |
"sample statistics were used for fitting and newdata is empty" |
| 45 |
)) |
|
| 46 | ! |
} else if (is.null(lavdata@X[[1]])) {
|
| 47 | ! |
lav_msg_stop(gettext("no local copy of data; FIXME!"))
|
| 48 |
} else {
|
|
| 49 | ! |
data.obs <- lavdata@X |
| 50 | ! |
ov.names <- lavdata@ov.names |
| 51 |
} |
|
| 52 |
# eXo <- lavdata@eXo |
|
| 53 |
} else {
|
|
| 54 |
# newdata is given! |
|
| 55 | ||
| 56 |
# create lavData object |
|
| 57 | ! |
OV <- lavdata@ov |
| 58 | ! |
newData <- lav_lavdata( |
| 59 | ! |
data = newdata, |
| 60 | ! |
group = lavdata@group, |
| 61 | ! |
ov.names = lavdata@ov.names, |
| 62 | ! |
ov.names.x = lavdata@ov.names.x, |
| 63 | ! |
ordered = OV$name[OV$type == "ordered"], |
| 64 | ! |
lavoptions = list( |
| 65 | ! |
std.ov = lavdata@std.ov, |
| 66 | ! |
group.label = lavdata@group.label, |
| 67 | ! |
missing = "ml.x", # always! |
| 68 | ! |
warn = TRUE |
| 69 |
), |
|
| 70 | ! |
allow.single.case = TRUE |
| 71 |
) |
|
| 72 |
# if ordered, check if number of levels is still the same (new in 0.6-7) |
|
| 73 | ! |
if (lavmodel@categorical) {
|
| 74 | ! |
orig.ordered.idx <- which(lavdata@ov$type == "ordered") |
| 75 | ! |
orig.ordered.lev <- lavdata@ov$nlev[orig.ordered.idx] |
| 76 | ! |
match.new.idx <- match( |
| 77 | ! |
lavdata@ov$name[orig.ordered.idx], |
| 78 | ! |
newData@ov$name |
| 79 |
) |
|
| 80 | ! |
new.ordered.lev <- newData@ov$nlev[match.new.idx] |
| 81 | ! |
if (any(orig.ordered.lev - new.ordered.lev != 0)) {
|
| 82 | ! |
lav_msg_stop(gettext( |
| 83 | ! |
"mismatch number of categories for some ordered variables in |
| 84 | ! |
newdata compared to original data." |
| 85 |
)) |
|
| 86 |
} |
|
| 87 |
} |
|
| 88 | ||
| 89 | ! |
data.obs <- newData@X |
| 90 |
# eXo <- newData@eXo |
|
| 91 | ! |
ov.names <- newData@ov.names |
| 92 |
} # newdata |
|
| 93 | ||
| 94 |
# check ynames |
|
| 95 | ! |
if (length(ynames) == 0L) {
|
| 96 | ! |
lav_msg_stop(gettext( |
| 97 | ! |
"please specify the y-variables in the ynames= argument" |
| 98 |
)) |
|
| 99 |
} |
|
| 100 | ||
| 101 | ! |
if (anyDuplicated((ynames))) {
|
| 102 | ! |
lav_msg_stop(gettext( |
| 103 | ! |
"ynames contains duplicate variable names" |
| 104 |
)) |
|
| 105 |
} |
|
| 106 | ||
| 107 | ! |
if (!is.list(ynames)) {
|
| 108 | ! |
ynames <- rep(list(ynames), lavdata@ngroups) |
| 109 |
} |
|
| 110 | ||
| 111 |
# check xnames |
|
| 112 | ! |
if (length(xnames) == 0L) {
|
| 113 | ! |
lav_msg_stop(gettext( |
| 114 | ! |
"please specify the x-variables in the xnames= argument" |
| 115 |
)) |
|
| 116 |
} |
|
| 117 | ||
| 118 | ! |
if (anyDuplicated((xnames))) {
|
| 119 | ! |
lav_msg_stop(gettext( |
| 120 | ! |
"ynames contains duplicate variable names" |
| 121 |
)) |
|
| 122 |
} |
|
| 123 | ||
| 124 | ! |
if (!is.list(xnames)) {
|
| 125 | ! |
xnames <- rep(list(xnames), lavdata@ngroups) |
| 126 |
} |
|
| 127 | ||
| 128 |
# create y.idx and x.idx |
|
| 129 | ! |
y.idx <- x.idx <- vector("list", lavdata@ngroups)
|
| 130 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 131 |
# ynames in ov.names for this group? |
|
| 132 | ! |
missing.idx <- which(!ynames[[g]] %in% ov.names[[g]]) |
| 133 | ! |
if (length(missing.idx) > 0L) {
|
| 134 | ! |
lav_msg_stop( |
| 135 | ! |
gettext( |
| 136 | ! |
"some variable names in ynames do not appear in the dataset:" |
| 137 |
), |
|
| 138 | ! |
lav_msg_view(ynames[[g]][missing.idx], "none") |
| 139 |
) |
|
| 140 |
} else {
|
|
| 141 | ! |
y.idx[[g]] <- match(ynames[[g]], ov.names[[g]]) |
| 142 |
} |
|
| 143 | ||
| 144 |
# xnames in ov.names for this group? |
|
| 145 | ! |
missing.idx <- which(!xnames[[g]] %in% ov.names[[g]]) |
| 146 | ! |
if (length(missing.idx) > 0L) {
|
| 147 | ! |
lav_msg_stop( |
| 148 | ! |
gettext( |
| 149 | ! |
"some variable names in xnames do not appear in the dataset:" |
| 150 |
), |
|
| 151 | ! |
lav_msg_view(xnames[[g]][missing.idx], "none") |
| 152 |
) |
|
| 153 |
} else {
|
|
| 154 | ! |
x.idx[[g]] <- match(xnames[[g]], ov.names[[g]]) |
| 155 |
} |
|
| 156 |
} |
|
| 157 | ||
| 158 |
# prediction method |
|
| 159 | ! |
method <- tolower(method) |
| 160 | ! |
if (method == "conditional.mean") {
|
| 161 | ! |
out <- lav_predict_y_conditional_mean( |
| 162 | ! |
lavobject = NULL, |
| 163 | ! |
lavmodel = lavmodel, lavdata = lavdata, |
| 164 | ! |
lavimplied = lavimplied, |
| 165 | ! |
data.obs = data.obs, y.idx = y.idx, x.idx = x.idx, |
| 166 | ! |
force.zero.mean = force.zero.mean, |
| 167 | ! |
lambda = lambda |
| 168 |
) |
|
| 169 |
} else {
|
|
| 170 | ! |
lav_msg_stop(gettext("method must be \"conditional.mean\" (for now)."))
|
| 171 |
} |
|
| 172 | ||
| 173 |
# label? |
|
| 174 | ! |
if (label) {
|
| 175 |
# column names |
|
| 176 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 177 | ! |
colnames(out[[g]]) <- ynames[[g]] |
| 178 |
} |
|
| 179 | ||
| 180 |
# group.labels |
|
| 181 | ! |
if (lavdata@ngroups > 1L) {
|
| 182 | ! |
names(out) <- lavdata@group.label |
| 183 |
} |
|
| 184 |
} |
|
| 185 | ||
| 186 |
# lavaan.matrix |
|
| 187 | ! |
out <- lapply(out, "class<-", c("lavaan.matrix", "matrix"))
|
| 188 | ||
| 189 | ! |
if (lavdata@ngroups == 1L) {
|
| 190 | ! |
res <- out[[1L]] |
| 191 |
} else {
|
|
| 192 | ! |
res <- out |
| 193 |
} |
|
| 194 | ||
| 195 |
# assemble multiple groups into a single data.frame? |
|
| 196 | ! |
if (lavdata@ngroups > 1L && assemble) {
|
| 197 | ! |
if (!is.null(newdata)) {
|
| 198 | ! |
lavdata <- newData |
| 199 |
} |
|
| 200 | ! |
DATA <- matrix(as.numeric(NA), |
| 201 | ! |
nrow = sum(unlist(lavdata@norig)), |
| 202 | ! |
ncol = ncol(out[[1L]]) |
| 203 | ! |
) # assume == per g |
| 204 | ! |
colnames(DATA) <- colnames(out[[1L]]) |
| 205 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 206 | ! |
DATA[lavdata@case.idx[[g]], ] <- out[[g]] |
| 207 |
} |
|
| 208 | ! |
DATA <- as.data.frame(DATA, stringsAsFactors = FALSE) |
| 209 | ||
| 210 | ! |
if (!is.null(newdata)) {
|
| 211 | ! |
DATA[, lavdata@group] <- newdata[, lavdata@group] |
| 212 |
} else {
|
|
| 213 |
# add group |
|
| 214 | ! |
DATA[, lavdata@group] <- rep(as.character(NA), nrow(DATA)) |
| 215 | ! |
if (lavdata@missing == "listwise") {
|
| 216 |
# we will loose the group label of omitted variables! |
|
| 217 | ! |
DATA[unlist(lavdata@case.idx), lavdata@group] <- |
| 218 | ! |
rep(lavdata@group.label, unlist(lavdata@nobs)) |
| 219 |
} else {
|
|
| 220 | ! |
DATA[unlist(lavdata@case.idx), lavdata@group] <- |
| 221 | ! |
rep(lavdata@group.label, unlist(lavdata@norig)) |
| 222 |
} |
|
| 223 |
} |
|
| 224 | ||
| 225 | ! |
res <- DATA |
| 226 |
} |
|
| 227 | ||
| 228 | ! |
res |
| 229 |
} |
|
| 230 | ||
| 231 | ||
| 232 |
# method = "conditional.mean" |
|
| 233 |
lav_predict_y_conditional_mean <- function( |
|
| 234 |
lavobject = NULL, # for convenience |
|
| 235 |
# object ingredients |
|
| 236 |
lavmodel = NULL, |
|
| 237 |
lavdata = NULL, |
|
| 238 |
lavimplied = NULL, |
|
| 239 |
# new data |
|
| 240 |
data.obs = NULL, |
|
| 241 |
# y and x |
|
| 242 |
y.idx = NULL, |
|
| 243 |
x.idx = NULL, |
|
| 244 |
# options |
|
| 245 |
force.zero.mean = FALSE, |
|
| 246 |
lambda = lambda, |
|
| 247 |
level = 1L) { # not used for now
|
|
| 248 | ||
| 249 |
# full object? |
|
| 250 | ! |
if (inherits(lavobject, "lavaan")) {
|
| 251 | ! |
lavmodel <- lavobject@Model |
| 252 | ! |
lavdata <- lavobject@Data |
| 253 |
# lavsamplestats <- lavobject@SampleStats |
|
| 254 | ! |
lavimplied <- lavobject@implied |
| 255 |
} else {
|
|
| 256 | ! |
stopifnot( |
| 257 | ! |
!is.null(lavmodel), !is.null(lavdata), |
| 258 |
# !is.null(lavsamplestats), |
|
| 259 | ! |
!is.null(lavimplied) |
| 260 |
) |
|
| 261 |
} |
|
| 262 | ||
| 263 |
# data.obs? |
|
| 264 | ! |
if (is.null(data.obs)) {
|
| 265 | ! |
data.obs <- lavdata@X |
| 266 |
} |
|
| 267 | ||
| 268 |
# checks |
|
| 269 | ! |
if (lavmodel@categorical) {
|
| 270 | ! |
lav_msg_stop(gettext("no support for categorical data (yet)."))
|
| 271 |
} |
|
| 272 | ! |
if (lavdata@nlevels > 1L) {
|
| 273 | ! |
lav_msg_stop(gettext("no support for multilevel data (yet)."))
|
| 274 |
} |
|
| 275 | ||
| 276 |
# conditional.x? |
|
| 277 | ! |
if (lavmodel@conditional.x) {
|
| 278 | ! |
SigmaHat <- lav_model_cond2joint_sigma(lavmodel) |
| 279 | ! |
if (lavmodel@meanstructure) {
|
| 280 | ! |
MuHat <- lav_model_cond2joint_mu(lavmodel) |
| 281 |
} |
|
| 282 |
} else {
|
|
| 283 | ! |
SigmaHat <- lavimplied$cov |
| 284 | ! |
MuHat <- lavimplied$mean |
| 285 |
} |
|
| 286 | ||
| 287 |
# output container |
|
| 288 | ! |
YPRED <- vector("list", length = lavdata@ngroups)
|
| 289 | ||
| 290 |
# run over all groups |
|
| 291 | ! |
for (g in 1:lavdata@ngroups) {
|
| 292 |
# multiple levels? |
|
| 293 | ! |
if (lavdata@nlevels > 1L) {
|
| 294 |
# TODO! |
|
| 295 | ! |
lav_msg_stop(gettext("no support for multilevel data (yet)!"))
|
| 296 |
} else {
|
|
| 297 | ! |
data.obs.g <- data.obs[[g]] |
| 298 | ||
| 299 |
# model-implied variance-covariance matrix for this group |
|
| 300 | ! |
cov.g <- SigmaHat[[g]] |
| 301 | ||
| 302 |
# model-implied mean vector for this group |
|
| 303 | ! |
if (force.zero.mean) {
|
| 304 | ! |
mean.g <- rep(0, ncol(data.obs.g)) |
| 305 |
} else {
|
|
| 306 | ! |
mean.g <- as.numeric(MuHat[[g]]) |
| 307 |
} |
|
| 308 | ||
| 309 |
# indices (in ov.names) |
|
| 310 | ! |
y.idx.g <- y.idx[[g]] |
| 311 | ! |
x.idx.g <- x.idx[[g]] |
| 312 | ||
| 313 |
# partition y/x |
|
| 314 | ! |
Sxx <- cov.g[x.idx.g, x.idx.g, drop = FALSE] |
| 315 | ! |
Sxy <- cov.g[x.idx.g, y.idx.g, drop = FALSE] |
| 316 | ||
| 317 |
# x-data only |
|
| 318 | ! |
Xtest <- data.obs.g[, x.idx.g, drop = FALSE] |
| 319 | ||
| 320 |
# mx/my |
|
| 321 | ! |
mx <- mean.g[x.idx.g] |
| 322 | ! |
my <- mean.g[y.idx.g] |
| 323 | ||
| 324 |
# center using mx |
|
| 325 | ! |
Xtest <- t(t(Xtest) - mx) |
| 326 | ||
| 327 |
# Apply regularization |
|
| 328 | ! |
Sxx <- Sxx + lambda * diag(nrow(Sxx)) |
| 329 | ||
| 330 |
# prediction rule |
|
| 331 | ! |
tmp <- Xtest %*% solve(Sxx, Sxy) |
| 332 | ! |
YPRED[[g]] <- t(t(tmp) + my) |
| 333 |
} # single level |
|
| 334 |
} # g |
|
| 335 | ||
| 336 | ! |
YPRED |
| 337 |
} |
|
| 338 | ||
| 339 | ||
| 340 |
# Takes a sequence of lambdas and performs k-fold cross-validation to determine |
|
| 341 |
# the best lambda |
|
| 342 |
lavPredictY_cv <- function( |
|
| 343 |
object, |
|
| 344 |
data = NULL, |
|
| 345 |
xnames = lav_object_vnames(object, "ov.x"), |
|
| 346 |
ynames = lav_object_vnames(object, "ov.y"), |
|
| 347 |
n.folds = 10L, |
|
| 348 |
lambda.seq = seq(0, 1, 0.1)) {
|
|
| 349 | ||
| 350 |
# object should be (or inherit from) a lavaan object |
|
| 351 | ! |
stopifnot(inherits(object, "lavaan")) |
| 352 |
# check object |
|
| 353 | ! |
object <- lav_object_check_version(object) |
| 354 | ||
| 355 |
# results container |
|
| 356 | ! |
results <- matrix(as.numeric(NA), |
| 357 | ! |
nrow = length(lambda.seq) * n.folds, |
| 358 | ! |
ncol = 2L |
| 359 |
) |
|
| 360 | ! |
colnames(results) <- c("mse", "lambda")
|
| 361 | ||
| 362 |
# shuffle folds |
|
| 363 | ! |
folds <- sample(rep(1:n.folds, length.out = nrow(data))) |
| 364 | ||
| 365 |
# extract Y-data |
|
| 366 | ! |
Y <- as.matrix(data[, ynames, drop = FALSE]) |
| 367 | ||
| 368 | ! |
j <- 0L |
| 369 | ! |
for (i in 1:n.folds) {
|
| 370 | ! |
indis <- which(folds == i) |
| 371 | ! |
fold.fit <- try(update(object, |
| 372 | ! |
data = data[-indis, , drop = FALSE], |
| 373 | ! |
warn = FALSE |
| 374 | ! |
), silent = TRUE) |
| 375 | ! |
if (inherits(fold.fit, "try-error")) {
|
| 376 | ! |
lav_msg_warn(gettext("failed fit in fold %s", i))
|
| 377 | ! |
next |
| 378 |
} |
|
| 379 | ! |
for (l in lambda.seq) {
|
| 380 | ! |
j <- j + 1L |
| 381 | ! |
yhat <- lavPredictY( |
| 382 | ! |
fold.fit, |
| 383 | ! |
newdata = data[indis, , drop = FALSE], |
| 384 | ! |
xnames = xnames, |
| 385 | ! |
ynames = ynames, |
| 386 | ! |
lambda = l |
| 387 |
) |
|
| 388 | ! |
y.error <- Y[indis, , drop = FALSE] - yhat |
| 389 | ! |
mse <- mean(y.error * y.error) |
| 390 | ! |
results[j, ] <- c(mse, l) |
| 391 |
} |
|
| 392 |
} |
|
| 393 | ||
| 394 |
# Group by lambda and determine average MSE per group |
|
| 395 | ! |
avg <- aggregate(results[, "mse"], |
| 396 | ! |
by = list(results[, "lambda"]), |
| 397 | ! |
FUN = mean, na.rm = TRUE |
| 398 |
) |
|
| 399 | ! |
avg <- avg[order(avg[, 2]), ] |
| 400 | ! |
names(avg) <- c("lambda", "mse")
|
| 401 | ! |
lambda.min <- avg[1L, "lambda"] |
| 402 | ||
| 403 | ! |
list(results = avg, lambda.min = lambda.min) |
| 404 |
} |
| 1 |
# lavPredict() contains a collection of `predict' methods |
|
| 2 |
# the unifying theme is that they all rely on the (unknown, to be estimated) |
|
| 3 |
# or (known, apriori specified) values for the latent variables |
|
| 4 |
# |
|
| 5 |
# lv: latent variables (aka `factor scores') |
|
| 6 |
# ov: predict linear part of y_i |
|
| 7 |
# |
|
| 8 |
# - YR 11 June 2013: first version, in order to get factor scores for the |
|
| 9 |
# categorical case |
|
| 10 |
# - YR 12 Jan 2014: refactoring + lav_predict_fy (to be used by estimator MML) |
|
| 11 |
# |
|
| 12 |
# - YR 25 Mar 2025: transformed factor scores (correlation-preserving) |
|
| 13 | ||
| 14 |
# overload standard R function `predict' |
|
| 15 |
setMethod( |
|
| 16 |
"predict", "lavaan", |
|
| 17 |
function(object, newdata = NULL, ...) {
|
|
| 18 | 3x |
dotdotdot <- list(...) |
| 19 | 3x |
if (length(dotdotdot) > 0L) {
|
| 20 | ! |
for (j in seq_along(dotdotdot)) {
|
| 21 | ! |
lav_msg_warn(gettextf( |
| 22 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 23 | ! |
sQuote("predict"))
|
| 24 |
) |
|
| 25 |
} |
|
| 26 |
} |
|
| 27 | 3x |
lavPredict( |
| 28 | 3x |
object = object, newdata = newdata, type = "lv", method = "EBM", |
| 29 | 3x |
fsm = FALSE, rel = FALSE, optim.method = "bfgs" |
| 30 |
) |
|
| 31 |
} |
|
| 32 |
) |
|
| 33 | ||
| 34 |
# efaList version |
|
| 35 |
lav_efalist_predict <- function(object, ...) {
|
|
| 36 |
# kill object$loadings if present |
|
| 37 | ! |
object[["loadings"]] <- NULL |
| 38 | ||
| 39 | ! |
if (length(object) == 1L) {
|
| 40 |
# unlist |
|
| 41 | ! |
object <- object[[1]] |
| 42 |
} else {
|
|
| 43 |
# use the 'last' one per default |
|
| 44 | ! |
object <- object[[length(object)]] |
| 45 |
} |
|
| 46 | ||
| 47 | ! |
predict(object, ...) |
| 48 |
} |
|
| 49 | ||
| 50 |
# public function |
|
| 51 |
lavPredict <- function(object, newdata = NULL, # keep order of predict(), 0.6-7 |
|
| 52 |
type = "lv", method = "EBM", transform = FALSE, |
|
| 53 |
se = "none", acov = "none", label = TRUE, fsm = FALSE, |
|
| 54 |
mdist = FALSE, rel = FALSE, |
|
| 55 |
append.data = FALSE, assemble = FALSE, # or TRUE? |
|
| 56 |
level = 1L, optim.method = "bfgs", ETA = NULL, |
|
| 57 |
drop.list.single.group = TRUE) {
|
|
| 58 |
# check object |
|
| 59 | 21x |
object <- lav_object_check_version(object) |
| 60 | ||
| 61 |
# catch efaList objects |
|
| 62 | 21x |
if (inherits(object, "efaList")) {
|
| 63 |
# kill object$loadings if present |
|
| 64 | ! |
object[["loadings"]] <- NULL |
| 65 | ! |
if (length(object) == 1L) {
|
| 66 |
# unlist |
|
| 67 | ! |
object <- object[[1]] |
| 68 |
} else {
|
|
| 69 |
# use the 'last' one per default |
|
| 70 | ! |
object <- object[[length(object)]] |
| 71 |
} |
|
| 72 |
} |
|
| 73 | ||
| 74 | 21x |
stopifnot(inherits(object, "lavaan")) |
| 75 | 21x |
lavmodel <- object@Model |
| 76 | 21x |
lavdata <- object@Data |
| 77 | 21x |
lavsamplestats <- object@SampleStats |
| 78 | 21x |
lavh1 <- object@h1 |
| 79 | 21x |
lavimplied <- object@implied |
| 80 | 21x |
lavpartable <- object@ParTable |
| 81 | ||
| 82 |
# warn if the model does not contain any 'regular' latent variables |
|
| 83 | 21x |
if (length(lav_object_vnames(lavpartable, "lv.regular")) == 0L) {
|
| 84 | ! |
lav_msg_warn(gettextf("fitted model does not contain regular
|
| 85 | ! |
(i.e., measured) latent variables; the matrix of factor scores may |
| 86 | ! |
contain no columns")) |
| 87 |
} |
|
| 88 | ||
| 89 | 21x |
res <- lav_predict_internal( |
| 90 | 21x |
lavmodel = lavmodel, lavdata = lavdata, |
| 91 | 21x |
lavsamplestats = lavsamplestats, lavimplied = lavimplied, lavh1 = lavh1, |
| 92 | 21x |
lavpartable = lavpartable, newdata = newdata, type = type, method = method, |
| 93 | 21x |
transform = transform, se = se, acov = acov, label = label, |
| 94 | 21x |
fsm = fsm, rel = rel, |
| 95 | 21x |
mdist = mdist, append.data = append.data, assemble = assemble, |
| 96 | 21x |
level = level, optim.method = optim.method, ETA = ETA, |
| 97 | 21x |
drop.list.single.group = drop.list.single.group |
| 98 |
) |
|
| 99 | ||
| 100 | 21x |
res |
| 101 |
} |
|
| 102 | ||
| 103 |
# internal version, to be used if lavobject does not exist yet |
|
| 104 |
lav_predict_internal <- function(lavmodel = NULL, |
|
| 105 |
lavdata = NULL, |
|
| 106 |
lavsamplestats = NULL, |
|
| 107 |
lavh1 = NULL, |
|
| 108 |
lavimplied = NULL, |
|
| 109 |
lavpartable = NULL, |
|
| 110 |
# standard options |
|
| 111 |
newdata = NULL, # keep order of predict(), 0.6-7 |
|
| 112 |
type = "lv", method = "EBM", transform = FALSE, |
|
| 113 |
se = "none", acov = "none", label = TRUE, |
|
| 114 |
fsm = FALSE, rel = FALSE, |
|
| 115 |
mdist = FALSE, |
|
| 116 |
append.data = FALSE, assemble = FALSE, # or TRUE? |
|
| 117 |
level = 1L, optim.method = "bfgs", ETA = NULL, |
|
| 118 |
drop.list.single.group = TRUE) {
|
|
| 119 |
# type |
|
| 120 | 21x |
type <- tolower(type) |
| 121 | 21x |
lavpta <- lav_partable_attributes(lavpartable) |
| 122 | 21x |
if (type %in% c("latent", "lv", "factor", "factor.score", "factorscore")) {
|
| 123 | 21x |
type <- "lv" |
| 124 | ! |
} else if (type %in% c("ov", "yhat")) {
|
| 125 | ! |
type <- "yhat" |
| 126 | ! |
} else if (type %in% c("residuals", "resid", "error")) {
|
| 127 | ! |
type <- "resid" |
| 128 |
} |
|
| 129 | ||
| 130 |
# if resid, not for categorical |
|
| 131 | 21x |
if (type == "resid" && lavmodel@categorical) {
|
| 132 | ! |
lav_msg_stop(gettext("casewise residuals not available if data is categorical"))
|
| 133 |
} |
|
| 134 | ||
| 135 |
# append.data? check level |
|
| 136 | 21x |
if (append.data && level > 1L) {
|
| 137 | ! |
lav_msg_warn(gettext("append.data not available if level > 1L"))
|
| 138 | ! |
append.data <- FALSE |
| 139 |
} |
|
| 140 | ||
| 141 |
# mdist? -> fsm = TRUE |
|
| 142 | 21x |
if (mdist) {
|
| 143 | ! |
fsm <- TRUE |
| 144 |
} |
|
| 145 | ||
| 146 |
# se? |
|
| 147 | 21x |
if (acov != "none") {
|
| 148 | 18x |
se <- acov # ACOV implies SE |
| 149 |
} |
|
| 150 | 21x |
if (se != "none") {
|
| 151 | 18x |
if (is.logical(se) && se) {
|
| 152 | 18x |
se <- "standard" |
| 153 | 18x |
if (acov != "none") {
|
| 154 | 18x |
acov <- se # reverse-imply upstream |
| 155 |
} |
|
| 156 |
} |
|
| 157 | 18x |
if (type != "lv") {
|
| 158 | ! |
lav_msg_stop(gettext("standard errors only available if type = \"lv\""))
|
| 159 |
} |
|
| 160 | 18x |
if (lavmodel@categorical) {
|
| 161 | ! |
se <- acov <- "none" |
| 162 | ! |
lav_msg_warn(gettext( |
| 163 | ! |
"standard errors not available (yet) for non-normal data")) |
| 164 |
} |
|
| 165 |
# if(lavdata@missing %in% c("ml", "ml.x")) {
|
|
| 166 |
# se <- acov <- "none" |
|
| 167 |
# warning("lavaan WARNING: standard errors not available (yet) for missing data + fiml")
|
|
| 168 |
# } |
|
| 169 |
} |
|
| 170 | ||
| 171 |
# need full data set supplied |
|
| 172 | 21x |
if (is.null(newdata)) {
|
| 173 |
# use internal copy: |
|
| 174 | 21x |
if (lavdata@data.type != "full") {
|
| 175 | ! |
lav_msg_stop(gettext( |
| 176 | ! |
"sample statistics were used for fitting and newdata is empty")) |
| 177 | 21x |
} else if (is.null(lavdata@X[[1]])) {
|
| 178 | ! |
lav_msg_stop(gettext("no local copy of data; FIXME!"))
|
| 179 |
} else {
|
|
| 180 | 21x |
data.obs <- lavdata@X |
| 181 | 21x |
ov.names <- lavdata@ov.names |
| 182 |
} |
|
| 183 | 21x |
eXo <- lavdata@eXo |
| 184 |
} else {
|
|
| 185 | ! |
OV <- lavdata@ov |
| 186 | ! |
newData <- lav_lavdata( |
| 187 | ! |
data = newdata, |
| 188 | ! |
group = lavdata@group, |
| 189 | ! |
ov.names = lavdata@ov.names, |
| 190 | ! |
ov.names.x = lavdata@ov.names.x, |
| 191 | ! |
ordered = OV$name[OV$type == "ordered"], |
| 192 | ! |
lavoptions = list( |
| 193 | ! |
std.ov = lavdata@std.ov, |
| 194 | ! |
group.label = lavdata@group.label, |
| 195 | ! |
missing = lavdata@missing |
| 196 | ! |
), # was FALSE before? |
| 197 | ! |
allow.single.case = TRUE |
| 198 |
) |
|
| 199 |
# if ordered, check if number of levels is till the same (new in 0.6-7) |
|
| 200 | ! |
if (lavmodel@categorical) {
|
| 201 | ! |
orig.ordered.idx <- which(lavdata@ov$type == "ordered") |
| 202 | ! |
orig.ordered.lev <- lavdata@ov$nlev[orig.ordered.idx] |
| 203 | ! |
match.new.idx <- match( |
| 204 | ! |
lavdata@ov$name[orig.ordered.idx], |
| 205 | ! |
newData@ov$name |
| 206 |
) |
|
| 207 | ! |
new.ordered.lev <- newData@ov$nlev[match.new.idx] |
| 208 | ! |
if (any(orig.ordered.lev - new.ordered.lev != 0)) {
|
| 209 | ! |
lav_msg_stop( |
| 210 | ! |
gettext("mismatch number of categories for some ordered variables
|
| 211 | ! |
in newdata compared to original data.") |
| 212 |
) |
|
| 213 |
} |
|
| 214 |
} |
|
| 215 | ! |
data.obs <- newData@X |
| 216 | ! |
eXo <- newData@eXo |
| 217 | ! |
ov.names <- newData@ov.names |
| 218 |
} |
|
| 219 | ||
| 220 | 21x |
if (type == "lv") {
|
| 221 | 21x |
if (!is.null(ETA)) {
|
| 222 | ! |
lav_msg_warn(gettext("lvs will be predicted here;
|
| 223 | ! |
supplying ETA has no effect")) |
| 224 |
} |
|
| 225 | ||
| 226 |
# post fit check (lv pd?) |
|
| 227 |
# ok <- lav_object_post_check(object) |
|
| 228 |
# if(!ok) {
|
|
| 229 |
# stop("lavaan ERROR: lavInspect(,\"post.check\") is not TRUE; factor scores can not be computed. See the WARNING message.")
|
|
| 230 |
# } |
|
| 231 | ||
| 232 | 21x |
out <- lav_predict_eta( |
| 233 | 21x |
lavobject = NULL, lavmodel = lavmodel, |
| 234 | 21x |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 235 | 21x |
lavimplied = lavimplied, se = se, acov = acov, level = level, |
| 236 | 21x |
data.obs = data.obs, eXo = eXo, method = method, |
| 237 | 21x |
fsm = fsm, rel = rel, transform = transform, optim.method = optim.method |
| 238 |
) |
|
| 239 | ||
| 240 |
# extract fsm here |
|
| 241 | 21x |
if (fsm) {
|
| 242 | 18x |
FSM <- attr(out, "fsm") |
| 243 |
} |
|
| 244 | ||
| 245 |
# extract rel here |
|
| 246 | 21x |
if (rel) {
|
| 247 | ! |
REL <- attr(out, "rel") |
| 248 |
} |
|
| 249 | ||
| 250 |
# extract se here |
|
| 251 | 21x |
if (se != "none") {
|
| 252 | 18x |
SE <- attr(out, "se") |
| 253 | 18x |
if (acov != "none") {
|
| 254 | 18x |
ACOV <- attr(out, "acov") |
| 255 |
} |
|
| 256 |
} |
|
| 257 | ||
| 258 |
# remove dummy lv? (removes attr!) |
|
| 259 | 21x |
out <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 260 |
# determine block |
|
| 261 | 28x |
if (lavdata@nlevels == 1L) {
|
| 262 | 14x |
b <- g |
| 263 |
} else {
|
|
| 264 | 14x |
b <- (g - 1) * lavdata@nlevels + level |
| 265 |
} |
|
| 266 | 28x |
lv.idx <- c( |
| 267 | 28x |
lavmodel@ov.y.dummy.lv.idx[[b]], |
| 268 | 28x |
lavmodel@ov.x.dummy.lv.idx[[b]] |
| 269 |
) |
|
| 270 | 28x |
ret <- out[[g]] |
| 271 | 28x |
if (length(lv.idx) > 0L) {
|
| 272 | ! |
ret <- out[[g]][, -lv.idx, drop = FALSE] |
| 273 |
} |
|
| 274 | 28x |
ret |
| 275 |
}) |
|
| 276 | ||
| 277 |
# we need to remove the dummy's before we transform |
|
| 278 |
# (update 0.6-20: no longer needed... as transform happens internally) |
|
| 279 | 21x |
if (fsm) {
|
| 280 | 18x |
FSM <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 281 |
# determine block |
|
| 282 | 24x |
if (lavdata@nlevels == 1L) {
|
| 283 | 12x |
b <- g |
| 284 |
} else {
|
|
| 285 | 12x |
b <- (g - 1) * lavdata@nlevels + level |
| 286 |
} |
|
| 287 | 24x |
lv.idx <- c( |
| 288 | 24x |
lavmodel@ov.y.dummy.lv.idx[[b]], |
| 289 | 24x |
lavmodel@ov.x.dummy.lv.idx[[b]] |
| 290 |
) |
|
| 291 |
# ov.idx <- lavmodel@ov.x.dummy.ov.idx[[b]] |
|
| 292 |
# or should we use pta$vidx$ov.ind? |
|
| 293 | 24x |
ov.ind <- lavpta$vidx$ov.ind[[b]] |
| 294 | 24x |
ret <- FSM[[g]] |
| 295 | 24x |
if (length(lv.idx) > 0L) {
|
| 296 | ! |
if (is.matrix(FSM[[g]])) {
|
| 297 | ! |
ret <- FSM[[g]][-lv.idx, ov.ind, drop = FALSE] |
| 298 | ! |
} else if (is.list(FSM[[g]])) {
|
| 299 | ! |
FSM[[g]] <- lapply(FSM[[g]], function(x) {
|
| 300 | ! |
ret <- x[-lv.idx, ov.ind, drop = FALSE] |
| 301 | ! |
ret |
| 302 |
}) |
|
| 303 |
} |
|
| 304 |
} |
|
| 305 | 24x |
ret |
| 306 |
}) |
|
| 307 |
} |
|
| 308 | ||
| 309 |
# # new in 0.6-16 |
|
| 310 |
# # we assume the dummy lv's have already been removed |
|
| 311 |
# if (transform) {
|
|
| 312 |
# # VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = TRUE) |
|
| 313 |
# EETA <- lav_model_eeta( |
|
| 314 |
# lavmodel = lavmodel, |
|
| 315 |
# lavsamplestats = lavsamplestats, remove.dummy.lv = TRUE |
|
| 316 |
# ) |
|
| 317 |
# # compute transformation matrix |
|
| 318 |
# if (tolower(method) %in% c("ebm", "regression")) {
|
|
| 319 |
# tmat <- lav_predict_tmat_green(lavmodel = lavmodel, |
|
| 320 |
# lavimplied = lavimplied) |
|
| 321 |
# } else {
|
|
| 322 |
# tmat <- lav_predict_tmat_det(lavmodel = lavmodel, |
|
| 323 |
# lavimplied = lavimplied) |
|
| 324 |
# } |
|
| 325 |
# |
|
| 326 |
# # update FSM |
|
| 327 |
# if (fsm) {
|
|
| 328 |
# FSM <- lapply(seq_len(lavdata@ngroups), function(g) {
|
|
| 329 |
# # determine block |
|
| 330 |
# if (lavdata@nlevels == 1L) {
|
|
| 331 |
# b <- g |
|
| 332 |
# } else {
|
|
| 333 |
# b <- (g - 1) * lavdata@nlevels + level |
|
| 334 |
# } |
|
| 335 |
# ret <- tmat[[b]] %*% FSM[[g]] |
|
| 336 |
# ret |
|
| 337 |
# }) |
|
| 338 |
# } |
|
| 339 |
# |
|
| 340 |
# out <- lapply(seq_len(lavdata@ngroups), function(g) {
|
|
| 341 |
# # determine block |
|
| 342 |
# if (lavdata@nlevels == 1L) {
|
|
| 343 |
# b <- g |
|
| 344 |
# } else {
|
|
| 345 |
# b <- (g - 1) * lavdata@nlevels + level |
|
| 346 |
# } |
|
| 347 |
# |
|
| 348 |
# FS.centered <- scale(out[[g]], center = TRUE, scale = FALSE) |
|
| 349 |
# #FS.cov <- crossprod(FS.centered) / nrow(FS.centered) |
|
| 350 |
# #FS.cov.inv <- try(solve(FS.cov), silent = TRUE) |
|
| 351 |
# #if (inherits(FS.cov.inv, "try-error")) {
|
|
| 352 |
# # lav_msg_warn( |
|
| 353 |
# # gettext("could not invert (co)variance matrix of factor scores;
|
|
| 354 |
# # returning original factor scores.")) |
|
| 355 |
# # return(out[[g]]) |
|
| 356 |
# #} |
|
| 357 |
# #fs.inv.sqrt <- lav_matrix_symmetric_sqrt(FS.cov.inv) |
|
| 358 |
# #veta.sqrt <- lav_matrix_symmetric_sqrt(VETA[[g]]) |
|
| 359 |
# #tmp <- FS.centered %*% fs.inv.sqrt %*% veta.sqrt |
|
| 360 |
# tmp <- FS.centered %*% t(tmat[[b]]) |
|
| 361 |
# ret <- t(t(tmp) + drop(EETA[[g]])) |
|
| 362 |
# |
|
| 363 |
# ret |
|
| 364 |
# }) |
|
| 365 |
# } |
|
| 366 | ||
| 367 |
# new in 0.6-17 |
|
| 368 | 21x |
if (mdist) {
|
| 369 | ! |
VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = TRUE) |
| 370 | ! |
EETA <- lav_model_eeta( |
| 371 | ! |
lavmodel = lavmodel, |
| 372 | ! |
lavsamplestats = lavsamplestats, remove.dummy.lv = TRUE |
| 373 |
) |
|
| 374 | ! |
MDIST <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 375 | ! |
A <- FSM[[g]] |
| 376 | ! |
Sigma <- lavimplied$cov[[g]] |
| 377 | ! |
if (transform) {
|
| 378 | ! |
fs.cov <- VETA[[g]] |
| 379 |
} else {
|
|
| 380 | ! |
fs.cov <- A %*% Sigma %*% t(A) |
| 381 |
} |
|
| 382 | ! |
fs.cov.inv <- solve(fs.cov) |
| 383 |
# Mahalobis distance |
|
| 384 | ! |
fs.c <- t(t(out[[g]]) - EETA[[g]]) # center |
| 385 | ! |
df.squared <- rowSums((fs.c %*% fs.cov.inv) * fs.c) |
| 386 | ! |
ret <- df.squared # squared! |
| 387 | ! |
ret |
| 388 |
}) |
|
| 389 |
} |
|
| 390 | ||
| 391 |
# append original/new data? (also remove attr) |
|
| 392 | 21x |
if (append.data && level == 1L) {
|
| 393 | ! |
out <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 394 | ! |
ret <- cbind(out[[g]], data.obs[[g]]) |
| 395 | ! |
ret |
| 396 |
}) |
|
| 397 |
} |
|
| 398 | ||
| 399 | 21x |
if (se != "none") {
|
| 400 | 18x |
SE <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 401 |
# determine block |
|
| 402 | 24x |
if (lavdata@nlevels == 1L) {
|
| 403 | 12x |
b <- g |
| 404 |
} else {
|
|
| 405 | 12x |
b <- (g - 1) * lavdata@nlevels + level |
| 406 |
} |
|
| 407 | 24x |
lv.idx <- c( |
| 408 | 24x |
lavmodel@ov.y.dummy.lv.idx[[b]], |
| 409 | 24x |
lavmodel@ov.x.dummy.lv.idx[[b]] |
| 410 |
) |
|
| 411 | 24x |
ret <- SE[[g]] |
| 412 | 24x |
if (length(lv.idx) > 0L) {
|
| 413 | ! |
ret <- SE[[g]][, -lv.idx, drop = FALSE] |
| 414 |
} |
|
| 415 | 24x |
ret |
| 416 |
}) |
|
| 417 | 18x |
if (acov != "none") {
|
| 418 | 18x |
ACOV <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 419 |
# determine block |
|
| 420 | 24x |
if (lavdata@nlevels == 1L) {
|
| 421 | 12x |
b <- g |
| 422 |
} else {
|
|
| 423 | 12x |
b <- (g - 1) * lavdata@nlevels + level |
| 424 |
} |
|
| 425 | 24x |
lv.idx <- c( |
| 426 | 24x |
lavmodel@ov.y.dummy.lv.idx[[b]], |
| 427 | 24x |
lavmodel@ov.x.dummy.lv.idx[[b]] |
| 428 |
) |
|
| 429 | 24x |
ret <- ACOV[[g]] |
| 430 | 24x |
if (length(lv.idx) > 0L) {
|
| 431 | ! |
if (is.matrix(ACOV[[g]])) {
|
| 432 | ! |
ret <- ACOV[[g]][-lv.idx, -lv.idx, drop = FALSE] |
| 433 | ! |
} else if (is.list(ACOV[[g]])) {
|
| 434 | ! |
ret <- lapply(ACOV[[g]], function(x) {
|
| 435 | ! |
ret <- x[-lv.idx, -lv.idx, drop = FALSE] |
| 436 | ! |
ret |
| 437 |
}) |
|
| 438 |
} |
|
| 439 |
} |
|
| 440 | 24x |
ret |
| 441 |
}) |
|
| 442 |
} # acov |
|
| 443 |
} # se |
|
| 444 | ||
| 445 |
# label? |
|
| 446 | 21x |
if (label) {
|
| 447 | 21x |
for (g in seq_len(lavdata@ngroups)) {
|
| 448 | 28x |
if (lavdata@nlevels > 1L) {
|
| 449 | 14x |
gg <- (g - 1) * lavdata@nlevels + level |
| 450 |
} else {
|
|
| 451 | 14x |
gg <- g |
| 452 |
} |
|
| 453 | ||
| 454 | 28x |
if (append.data) {
|
| 455 | ! |
colnames(out[[g]]) <- c( |
| 456 | ! |
lavpta$vnames$lv[[gg]], |
| 457 | ! |
ov.names[[g]] |
| 458 | ! |
) # !not gg |
| 459 |
} else {
|
|
| 460 | 28x |
colnames(out[[g]]) <- lavpta$vnames$lv[[gg]] |
| 461 |
} |
|
| 462 | ||
| 463 | 28x |
if (fsm) {
|
| 464 | 24x |
if (is.null(FSM[[g]])) {
|
| 465 |
# skip |
|
| 466 | 24x |
} else if (is.matrix(FSM[[g]])) {
|
| 467 | 24x |
dimnames(FSM[[g]]) <- list( |
| 468 | 24x |
lavpta$vnames$lv[[gg]], |
| 469 |
# ov.names[[g]]) # !not gg |
|
| 470 | 24x |
lavpta$vnames$ov.ind[[gg]] |
| 471 |
) |
|
| 472 | ! |
} else if (is.list(FSM[[g]])) {
|
| 473 | ! |
FSM[[g]] <- lapply(FSM[[g]], function(x) {
|
| 474 | ! |
dimnames(x) <- list( |
| 475 | ! |
lavpta$vnames$lv[[gg]], |
| 476 |
# ov.names[[g]]) # !not gg |
|
| 477 | ! |
lavpta$vnames$ov.ind[[gg]] |
| 478 |
) |
|
| 479 | ! |
x |
| 480 |
}) |
|
| 481 |
} |
|
| 482 |
} |
|
| 483 | ||
| 484 | 28x |
if (se != "none") {
|
| 485 | 24x |
if (!is.null(SE[[g]])) {
|
| 486 | 24x |
colnames(SE[[g]]) <- lavpta$vnames$lv[[gg]] |
| 487 |
} |
|
| 488 |
} |
|
| 489 | ||
| 490 | 28x |
if (rel) {
|
| 491 | ! |
if (!is.null(REL[[g]])) {
|
| 492 | ! |
names(REL[[g]]) <- lavpta$vnames$lv[[gg]] |
| 493 |
} |
|
| 494 |
} |
|
| 495 | ||
| 496 | 28x |
if (acov != "none") {
|
| 497 | 24x |
if (is.null(ACOV[[g]])) {
|
| 498 |
# skip |
|
| 499 | 24x |
} else if (is.matrix(ACOV[[g]])) {
|
| 500 | 24x |
dimnames(ACOV[[g]]) <- list( |
| 501 | 24x |
lavpta$vnames$lv[[gg]], |
| 502 | 24x |
lavpta$vnames$lv[[gg]] |
| 503 |
) |
|
| 504 | ! |
} else if (is.list(ACOV[[g]])) {
|
| 505 | ! |
ACOV[[g]] <- lapply(ACOV[[g]], function(x) {
|
| 506 | ! |
dimnames(x) <- list( |
| 507 | ! |
lavpta$vnames$lv[[gg]], |
| 508 | ! |
lavpta$vnames$lv[[gg]] |
| 509 |
) |
|
| 510 | ! |
x |
| 511 |
}) |
|
| 512 |
} |
|
| 513 |
} |
|
| 514 |
} # g |
|
| 515 | ||
| 516 |
# group.labels |
|
| 517 | 21x |
if (lavdata@ngroups > 1L) {
|
| 518 | 7x |
names(out) <- lavdata@group.label |
| 519 | 7x |
if (se != "none") {
|
| 520 | 6x |
names(SE) <- lavdata@group.label |
| 521 |
} |
|
| 522 | 7x |
if (acov != "none") {
|
| 523 | 6x |
names(ACOV) <- lavdata@group.label |
| 524 |
} |
|
| 525 |
} |
|
| 526 |
} # label |
|
| 527 | ||
| 528 |
# yhat: estimated value for the observed indicators, given (estimated) |
|
| 529 |
# factor scores |
|
| 530 |
# resid: y - yhat |
|
| 531 | ! |
} else if (type %in% c("yhat", "resid")) {
|
| 532 | ! |
resid.flag <- type == "resid" |
| 533 | ! |
out <- lav_predict_yhat( |
| 534 | ! |
lavobject = NULL, lavmodel = lavmodel, |
| 535 | ! |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 536 | ! |
lavimplied = lavimplied, |
| 537 | ! |
data.obs = data.obs, eXo = eXo, |
| 538 | ! |
ETA = ETA, method = method, optim.method = optim.method, |
| 539 | ! |
fsm = fsm, |
| 540 | ! |
resid.flag = resid.flag |
| 541 |
) |
|
| 542 | ! |
if (fsm) {
|
| 543 | ! |
FSM <- attr(out, "fsm") |
| 544 |
} |
|
| 545 | ||
| 546 |
# label? |
|
| 547 | ! |
if (label) {
|
| 548 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 549 | ! |
colnames(out[[g]]) <- lavpta$vnames$ov[[g]] |
| 550 |
} |
|
| 551 |
} |
|
| 552 | ||
| 553 |
# mdist |
|
| 554 | ! |
if (mdist) {
|
| 555 | ! |
LAMBDA <- lav_model_lambda( |
| 556 | ! |
lavmodel = lavmodel, |
| 557 | ! |
remove.dummy.lv = FALSE |
| 558 |
) |
|
| 559 | ! |
MDIST <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 560 | ! |
Sigma <- lavimplied$cov[[g]] |
| 561 | ! |
LA <- LAMBDA[[g]] |
| 562 | ! |
if (type == "resid") {
|
| 563 | ! |
ILA <- diag(ncol(Sigma)) - LA %*% FSM[[g]] |
| 564 | ! |
Omega.e <- ILA %*% Sigma %*% t(ILA) |
| 565 | ! |
eig <- eigen(Omega.e, symmetric = TRUE) |
| 566 | ! |
A <- eig$vectors[, seq_len(nrow(LA) - ncol(LA)), |
| 567 | ! |
drop = FALSE |
| 568 |
] |
|
| 569 | ! |
} else if (type == "yhat") {
|
| 570 | ! |
LAA <- LA %*% FSM[[g]] |
| 571 | ! |
Omega.e <- LAA %*% Sigma %*% t(LAA) |
| 572 | ! |
eig <- eigen(Omega.e, symmetric = TRUE) |
| 573 | ! |
A <- eig$vectors[, seq_len(ncol(LA)), drop = FALSE] |
| 574 |
} |
|
| 575 | ! |
outA <- apply(out[[g]], 1L, function(x) {
|
| 576 | ! |
colSums(A * x, na.rm = TRUE) |
| 577 |
}) |
|
| 578 | ! |
if (is.matrix(outA)) {
|
| 579 | ! |
outA <- t(outA) |
| 580 |
} else {
|
|
| 581 | ! |
outA <- as.matrix(outA) |
| 582 |
} |
|
| 583 |
# if(lavmodel@meanstructure) {
|
|
| 584 |
# est.mean <- drop(t(lavimplied$mean[[g]]) %*% A) |
|
| 585 |
# if(type == "resid") {
|
|
| 586 |
# obs.mean <- drop(lavh1$implied$mean[[g]] %*% A) |
|
| 587 |
# est.mean <- drop(t(lavimplied$mean[[g]]) %*% A) |
|
| 588 |
# outA.mean <- obs.mean - est.mean |
|
| 589 |
# } else if(type == "yhat") {
|
|
| 590 |
# outA.mean <- est.mean |
|
| 591 |
# } |
|
| 592 |
# } else {
|
|
| 593 |
# outA.mean <- colMeans(outA) |
|
| 594 |
# } |
|
| 595 | ! |
outA.cov <- t(A) %*% Omega.e %*% A |
| 596 | ! |
outA.cov.inv <- solve(outA.cov) |
| 597 |
# Mahalobis distance |
|
| 598 |
# outA.c <- t( t(outA) - outA.mean ) # center |
|
| 599 | ! |
outA.c <- outA |
| 600 | ! |
df.squared <- rowSums((outA.c %*% outA.cov.inv) * outA.c) |
| 601 | ! |
ret <- df.squared # squared! |
| 602 | ! |
ret |
| 603 |
}) |
|
| 604 |
} |
|
| 605 | ||
| 606 | ||
| 607 |
# density for each observed item, given (estimated) factor scores |
|
| 608 | ! |
} else if (type == "fy") {
|
| 609 | ! |
out <- lav_predict_fy( |
| 610 | ! |
lavobject = NULL, lavmodel = lavmodel, |
| 611 | ! |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 612 | ! |
lavimplied = lavimplied, |
| 613 | ! |
data.obs = data.obs, eXo = eXo, |
| 614 | ! |
ETA = ETA, method = method, optim.method = optim.method |
| 615 |
) |
|
| 616 | ||
| 617 |
# label? |
|
| 618 | ! |
if (label) {
|
| 619 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 620 | ! |
colnames(out[[g]]) <- lavpta$vnames$ov[[g]] |
| 621 |
} |
|
| 622 |
} |
|
| 623 |
} else {
|
|
| 624 | ! |
lav_msg_stop(gettext("type must be one of: lv yhat fy"))
|
| 625 |
} |
|
| 626 | ||
| 627 |
# lavaan.matrix |
|
| 628 | 21x |
out <- lapply(out, "class<-", c("lavaan.matrix", "matrix"))
|
| 629 | ||
| 630 | 21x |
if (lavdata@ngroups == 1L && drop.list.single.group) {
|
| 631 | 14x |
res <- out[[1L]] |
| 632 |
} else {
|
|
| 633 | 7x |
res <- out |
| 634 |
} |
|
| 635 | ||
| 636 |
# assemble multiple groups into a single data.frame? (new in 0.6-4) |
|
| 637 | 21x |
if (lavdata@ngroups > 1L && assemble) {
|
| 638 | ! |
if (!is.null(newdata)) {
|
| 639 | ! |
lavdata <- newData |
| 640 |
} |
|
| 641 | ! |
DATA <- matrix(as.numeric(NA), |
| 642 | ! |
nrow = sum(unlist(lavdata@norig)), |
| 643 | ! |
ncol = ncol(out[[1L]]) |
| 644 | ! |
) # assume == per g |
| 645 | ! |
colnames(DATA) <- colnames(out[[1L]]) |
| 646 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 647 | ! |
DATA[lavdata@case.idx[[g]], ] <- out[[g]] |
| 648 |
} |
|
| 649 | ! |
DATA <- as.data.frame(DATA, stringsAsFactors = FALSE) |
| 650 | ||
| 651 | ! |
if (!is.null(newdata)) {
|
| 652 | ! |
DATA[, lavdata@group] <- newdata[, lavdata@group] |
| 653 |
} else {
|
|
| 654 |
# add group |
|
| 655 | ! |
DATA[, lavdata@group] <- rep(as.character(NA), nrow(DATA)) |
| 656 | ! |
if (lavdata@missing == "listwise") {
|
| 657 |
# we will loose the group label of omitted variables! |
|
| 658 | ! |
DATA[unlist(lavdata@case.idx), lavdata@group] <- |
| 659 | ! |
rep(lavdata@group.label, unlist(lavdata@nobs)) |
| 660 |
} else {
|
|
| 661 | ! |
DATA[unlist(lavdata@case.idx), lavdata@group] <- |
| 662 | ! |
rep(lavdata@group.label, unlist(lavdata@norig)) |
| 663 |
} |
|
| 664 |
} |
|
| 665 | ||
| 666 | ! |
res <- DATA |
| 667 |
} |
|
| 668 | ||
| 669 | 21x |
if (fsm && type == "lv") {
|
| 670 | 18x |
attr(res, "fsm") <- FSM |
| 671 |
} |
|
| 672 | ||
| 673 | 21x |
if (rel && type == "lv") {
|
| 674 | ! |
attr(res, "rel") <- REL |
| 675 |
} |
|
| 676 | ||
| 677 | 21x |
if (mdist) {
|
| 678 | ! |
attr(res, "mdist") <- MDIST |
| 679 |
} |
|
| 680 | ||
| 681 | 21x |
if (se != "none") {
|
| 682 | 18x |
attr(res, "se") <- SE |
| 683 |
# return full sampling covariance matrix? |
|
| 684 | 18x |
if (acov == "standard") {
|
| 685 | 18x |
attr(res, "acov") <- ACOV |
| 686 |
} |
|
| 687 |
} |
|
| 688 | ||
| 689 | 21x |
res |
| 690 |
} |
|
| 691 | ||
| 692 |
# internal function |
|
| 693 |
lav_predict_eta <- function(lavobject = NULL, # for convenience |
|
| 694 |
# sub objects |
|
| 695 |
lavmodel = NULL, lavdata = NULL, |
|
| 696 |
lavsamplestats = NULL, |
|
| 697 |
lavimplied = NULL, |
|
| 698 |
# new data |
|
| 699 |
data.obs = NULL, eXo = NULL, |
|
| 700 |
# options |
|
| 701 |
method = "EBM", |
|
| 702 |
fsm = FALSE, |
|
| 703 |
rel = FALSE, |
|
| 704 |
transform = FALSE, |
|
| 705 |
se = "none", acov = "none", |
|
| 706 |
level = 1L, |
|
| 707 |
optim.method = "bfgs") {
|
|
| 708 |
# full object? |
|
| 709 | 24x |
if (inherits(lavobject, "lavaan")) {
|
| 710 | ! |
lavdata <- lavobject@Data |
| 711 |
} else {
|
|
| 712 | 24x |
stopifnot(!is.null(lavdata)) |
| 713 |
} |
|
| 714 | ||
| 715 |
# method |
|
| 716 | 24x |
method <- tolower(method) |
| 717 | ||
| 718 |
# alias |
|
| 719 | 24x |
if (method == "regression") {
|
| 720 | ! |
method <- "ebm" |
| 721 | 24x |
} else if (method == "bartlett" || method == "bartlet") {
|
| 722 | 9x |
method <- "ml" |
| 723 |
} |
|
| 724 | ||
| 725 |
# normal case? |
|
| 726 | 24x |
if (all(lavdata@ov$type == "numeric")) {
|
| 727 | 24x |
if (method == "ebm") {
|
| 728 | 15x |
out <- lav_predict_eta_normal( |
| 729 | 15x |
lavobject = lavobject, |
| 730 | 15x |
lavmodel = lavmodel, lavdata = lavdata, |
| 731 | 15x |
lavimplied = lavimplied, se = se, acov = acov, |
| 732 | 15x |
level = level, lavsamplestats = lavsamplestats, |
| 733 | 15x |
data.obs = data.obs, eXo = eXo, fsm = fsm, rel = rel, |
| 734 | 15x |
transform = transform |
| 735 |
) |
|
| 736 | 9x |
} else if (method == "ml") {
|
| 737 | 9x |
out <- lav_predict_eta_bartlett( |
| 738 | 9x |
lavobject = lavobject, |
| 739 | 9x |
lavmodel = lavmodel, lavdata = lavdata, |
| 740 | 9x |
lavimplied = lavimplied, se = se, acov = acov, |
| 741 | 9x |
level = level, lavsamplestats = lavsamplestats, |
| 742 | 9x |
data.obs = data.obs, eXo = eXo, fsm = fsm, rel = rel, |
| 743 | 9x |
transform = transform |
| 744 |
) |
|
| 745 |
} else {
|
|
| 746 | ! |
lav_msg_stop(gettextf("unkown method: %s.", method))
|
| 747 |
} |
|
| 748 |
} else {
|
|
| 749 | ! |
if (method == "ebm") {
|
| 750 | ! |
out <- lav_predict_eta_ebm_ml( |
| 751 | ! |
lavobject = lavobject, |
| 752 | ! |
lavmodel = lavmodel, lavdata = lavdata, |
| 753 | ! |
lavsamplestats = lavsamplestats, se = se, acov = acov, |
| 754 | ! |
level = level, data.obs = data.obs, eXo = eXo, |
| 755 | ! |
ML = FALSE, optim.method = optim.method |
| 756 |
) |
|
| 757 | ! |
} else if (method == "ml") {
|
| 758 | ! |
out <- lav_predict_eta_ebm_ml( |
| 759 | ! |
lavobject = lavobject, |
| 760 | ! |
lavmodel = lavmodel, lavdata = lavdata, |
| 761 | ! |
lavsamplestats = lavsamplestats, se = se, acov = acov, |
| 762 | ! |
level = level, data.obs = data.obs, eXo = eXo, |
| 763 | ! |
ML = TRUE, optim.method = optim.method |
| 764 |
) |
|
| 765 |
} else {
|
|
| 766 | ! |
lav_msg_stop(gettextf("unkown method: %s.", method))
|
| 767 |
} |
|
| 768 |
} |
|
| 769 | ||
| 770 | 24x |
out |
| 771 |
} |
|
| 772 | ||
| 773 | ||
| 774 |
# factor scores - normal case |
|
| 775 |
# NOTE: this is the classic 'regression' method; for the linear/continuous |
|
| 776 |
# case, this is equivalent to both EB and EBM |
|
| 777 |
lav_predict_eta_normal <- function(lavobject = NULL, # for convenience |
|
| 778 |
# sub objects |
|
| 779 |
lavmodel = NULL, lavdata = NULL, |
|
| 780 |
lavsamplestats = NULL, |
|
| 781 |
lavimplied = NULL, |
|
| 782 |
# optional new data |
|
| 783 |
data.obs = NULL, eXo = NULL, |
|
| 784 |
se = "none", acov = "none", level = 1L, |
|
| 785 |
fsm = FALSE, rel = FALSE, |
|
| 786 |
transform = FALSE) {
|
|
| 787 |
# full object? |
|
| 788 | 15x |
if (inherits(lavobject, "lavaan")) {
|
| 789 | ! |
lavmodel <- lavobject@Model |
| 790 | ! |
lavdata <- lavobject@Data |
| 791 | ! |
lavsamplestats <- lavobject@SampleStats |
| 792 | ! |
lavimplied <- lavobject@implied |
| 793 |
} else {
|
|
| 794 | 15x |
stopifnot( |
| 795 | 15x |
!is.null(lavmodel), !is.null(lavdata), |
| 796 | 15x |
!is.null(lavsamplestats), !is.null(lavimplied) |
| 797 |
) |
|
| 798 |
} |
|
| 799 | ||
| 800 | 15x |
if (is.null(data.obs)) {
|
| 801 | ! |
data.obs <- lavdata@X |
| 802 | ! |
newdata.flag <- FALSE |
| 803 |
} else {
|
|
| 804 | 15x |
newdata.flag <- TRUE |
| 805 |
} |
|
| 806 |
# eXo not needed |
|
| 807 | ||
| 808 |
# missings? and missing = "ml"? |
|
| 809 | 15x |
if (lavdata@missing %in% c("ml", "ml.x")) {
|
| 810 | ! |
if (newdata.flag) {
|
| 811 | ! |
MP <- vector("list", lavdata@ngroups)
|
| 812 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 813 | ! |
MP[[g]] <- lav_data_missing_patterns(data.obs[[g]]) |
| 814 |
} |
|
| 815 |
} else {
|
|
| 816 | ! |
MP <- lavdata@Mp |
| 817 |
} |
|
| 818 |
} |
|
| 819 | ||
| 820 | 15x |
LAMBDA <- lav_model_lambda(lavmodel = lavmodel, remove.dummy.lv = FALSE) |
| 821 | 15x |
Sigma.hat <- lavimplied$cov |
| 822 | 15x |
Sigma.inv <- lapply(Sigma.hat, MASS::ginv) |
| 823 | 15x |
VETA <- lav_model_veta(lavmodel = lavmodel) |
| 824 | 15x |
EETA <- lav_model_eeta(lavmodel = lavmodel, lavsamplestats = lavsamplestats) |
| 825 | 15x |
EY <- lav_model_ey(lavmodel = lavmodel, lavsamplestats = lavsamplestats) |
| 826 | ||
| 827 | 15x |
FS <- vector("list", length = lavdata@ngroups)
|
| 828 | 15x |
if (fsm) {
|
| 829 | 9x |
FSM <- vector("list", length = lavdata@ngroups)
|
| 830 |
} |
|
| 831 | 15x |
if (rel) {
|
| 832 | ! |
REL <- vector("list", length = lavdata@ngroups)
|
| 833 |
} |
|
| 834 | 15x |
if (transform) {
|
| 835 | ! |
TMAT <- lav_predict_tmat_green(lavmodel = lavmodel, |
| 836 | ! |
lavimplied = lavimplied) |
| 837 |
} |
|
| 838 | ||
| 839 | 15x |
if (acov != "none") {
|
| 840 | 9x |
se <- acov # ACOV implies SE |
| 841 |
} |
|
| 842 | 15x |
if (se != "none") {
|
| 843 | 9x |
SE <- vector("list", length = lavdata@ngroups)
|
| 844 |
# return full sampling covariance matrix? |
|
| 845 | 9x |
if (acov != "none") {
|
| 846 | 9x |
ACOV <- vector("list", length = lavdata@ngroups)
|
| 847 |
} |
|
| 848 |
} |
|
| 849 | ||
| 850 | 15x |
for (g in 1:lavdata@ngroups) {
|
| 851 |
# determine block |
|
| 852 | 20x |
if (lavdata@nlevels == 1L) {
|
| 853 | 10x |
b <- g |
| 854 |
} else {
|
|
| 855 | 10x |
b <- (g - 1) * lavdata@nlevels + level |
| 856 |
} |
|
| 857 | ||
| 858 | 20x |
VETA.g <- VETA[[b]] |
| 859 | 20x |
EETA.g <- EETA[[b]] |
| 860 | 20x |
LAMBDA.g <- LAMBDA[[b]] |
| 861 | 20x |
EY.g <- EY[[b]] |
| 862 | 20x |
Sigma.inv.g <- Sigma.inv[[b]] |
| 863 | ||
| 864 | 20x |
if (lavdata@nlevels > 1L) {
|
| 865 | 10x |
Lp <- lavdata@Lp[[g]] |
| 866 | 10x |
YLp <- lavsamplestats@YLp[[g]] |
| 867 | ||
| 868 |
# implied for this group |
|
| 869 | 10x |
group.idx <- (g - 1) * lavdata@nlevels + seq_len(lavdata@nlevels) |
| 870 | 10x |
implied.group <- lapply(lavimplied, function(x) x[group.idx]) |
| 871 | ||
| 872 |
# random effects (=random intercepts or cluster means) |
|
| 873 | 10x |
out <- lav_mvnorm_cluster_implied22l( |
| 874 | 10x |
Lp = Lp, |
| 875 | 10x |
implied = implied.group |
| 876 |
) |
|
| 877 | 10x |
MB.j <- lav_mvnorm_cluster_em_estep_ranef( |
| 878 | 10x |
YLp = YLp, Lp = Lp, |
| 879 | 10x |
sigma.w = out$sigma.w, sigma.b = out$sigma.b, |
| 880 | 10x |
sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz, |
| 881 | 10x |
mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b, |
| 882 | 10x |
se = FALSE |
| 883 |
) |
|
| 884 | ||
| 885 | 10x |
ov.idx <- Lp$ov.idx |
| 886 | ||
| 887 | 10x |
if (level == 1L) {
|
| 888 | 10x |
data.W <- data.obs[[g]][, ov.idx[[1]]] |
| 889 | 10x |
data.B <- MB.j[Lp$cluster.idx[[2]], , drop = FALSE] |
| 890 | ||
| 891 |
# center |
|
| 892 | 10x |
data.obs.g <- data.W - data.B |
| 893 | ! |
} else if (level == 2L) {
|
| 894 | ! |
Data.B <- matrix(0, |
| 895 | ! |
nrow = nrow(MB.j), |
| 896 | ! |
ncol = ncol(data.obs[[g]]) |
| 897 |
) |
|
| 898 | ! |
Data.B[, ov.idx[[1]]] <- MB.j |
| 899 | ! |
between.idx <- Lp$between.idx[[2 * g]] |
| 900 | ! |
if (length(between.idx) > 0L) {
|
| 901 | ! |
Data.B[, between.idx] <- data.obs[[g]][ |
| 902 | ! |
!duplicated(Lp$cluster.idx[[2]]), |
| 903 | ! |
between.idx |
| 904 |
] |
|
| 905 |
} |
|
| 906 | ! |
data.obs.g <- Data.B[, ov.idx[[2]]] |
| 907 |
} else {
|
|
| 908 | ! |
lav_msg_stop(gettext("only 2 levels are supported"))
|
| 909 |
} |
|
| 910 |
} else {
|
|
| 911 | 10x |
data.obs.g <- data.obs[[b]] |
| 912 |
} |
|
| 913 | ||
| 914 | 20x |
nfac <- ncol(VETA.g) |
| 915 | 20x |
if (nfac == 0L) {
|
| 916 | ! |
FS[[g]] <- matrix(0, lavdata@nobs[[g]], nfac) |
| 917 | ! |
next |
| 918 |
} |
|
| 919 | ||
| 920 |
# center data |
|
| 921 | 20x |
Yc <- t(t(data.obs.g) - EY.g) |
| 922 | ||
| 923 |
# sampling weights? -- CHECKME: needed?? |
|
| 924 | 20x |
if (!is.null(lavdata@weights[[g]]) && level == 1L) {
|
| 925 |
# EY.g is already weighted |
|
| 926 |
# use sampling.weights.normalization == "group" |
|
| 927 | ! |
WT <- lavdata@weights[[g]] |
| 928 | ! |
WT2 <- WT / sum(WT) * lavdata@nobs[[g]] |
| 929 | ! |
Yc <- Yc * sqrt(WT2) |
| 930 |
} |
|
| 931 | ||
| 932 |
# global factor score coefficient matrix 'C' |
|
| 933 | 20x |
FSC <- VETA.g %*% t(LAMBDA.g) %*% Sigma.inv.g |
| 934 | ||
| 935 |
# transform? |
|
| 936 | 20x |
if (transform) {
|
| 937 | ! |
FSC <- TMAT[[b]] %*% FSC |
| 938 |
} |
|
| 939 | ||
| 940 |
# store fsm? |
|
| 941 | 20x |
if (fsm) {
|
| 942 | 12x |
FSM.g <- FSC |
| 943 |
} |
|
| 944 | ||
| 945 |
# reliability? |
|
| 946 | 20x |
if (rel) {
|
| 947 | ! |
Var.f <- FSC %*% Sigma.hat[[g]] %*% t(FSC) # or S? |
| 948 | ! |
Cov.f.eta <- FSC %*% LAMBDA.g %*% VETA.g |
| 949 | ! |
Var.eta <- VETA.g |
| 950 |
# FS.determinacy <- diag( diag(1/sqrt(diag(Var.f))) %*% |
|
| 951 |
# Cov.f.eta %*% |
|
| 952 |
# diag(1/sqrt(diag(Var.eta))) |
|
| 953 |
# ) |
|
| 954 | ! |
FS.determinacy <- ( diag(Cov.f.eta) / |
| 955 | ! |
(sqrt(diag(Var.f)) * sqrt(diag(Var.eta))) ) |
| 956 | ! |
REL.g <- FS.determinacy*FS.determinacy |
| 957 |
} |
|
| 958 | ||
| 959 |
# compute factor scores |
|
| 960 | 20x |
if (lavdata@missing %in% c("ml", "ml.x")) {
|
| 961 |
# missing patterns for this group |
|
| 962 | ! |
Mp <- MP[[g]] |
| 963 | ||
| 964 |
# factor scores container |
|
| 965 | ! |
FS.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g)) |
| 966 | ||
| 967 |
# if(fsm) {
|
|
| 968 |
# FSM.g <- vector("list", length = Mp$npatterns)
|
|
| 969 |
# } |
|
| 970 | ||
| 971 | ! |
if (se == "standard") {
|
| 972 | ! |
SE.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g)) |
| 973 |
} |
|
| 974 | ||
| 975 | ! |
if (acov == "standard") {
|
| 976 | ! |
ACOV.g <- vector("list", length = Mp$npatterns)
|
| 977 |
} |
|
| 978 | ||
| 979 |
# compute FSC per pattern |
|
| 980 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 981 | ! |
var.idx <- Mp$pat[p, ] # observed |
| 982 | ! |
na.idx <- which(!var.idx) # missing |
| 983 | ||
| 984 |
# extract observed data for these (centered) cases |
|
| 985 | ! |
Oc <- Yc[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE] |
| 986 | ||
| 987 |
# invert Sigma (Sigma_22, observed part only) for this pattern |
|
| 988 | ! |
Sigma_22.inv <- try(lav_matrix_symmetric_inverse_update( |
| 989 | ! |
S.inv = |
| 990 | ! |
Sigma.inv.g, rm.idx = na.idx, |
| 991 | ! |
logdet = FALSE |
| 992 | ! |
), silent = TRUE) |
| 993 | ! |
if (inherits(Sigma_22.inv, "try-error")) {
|
| 994 | ! |
lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
|
| 995 |
} |
|
| 996 | ||
| 997 | ! |
lambda <- LAMBDA.g[var.idx, , drop = FALSE] |
| 998 | ! |
FSC <- VETA.g %*% t(lambda) %*% Sigma_22.inv |
| 999 | ||
| 1000 |
# FSM? |
|
| 1001 |
# if(fsm) {
|
|
| 1002 |
# tmp <- matrix(as.numeric(NA), nrow = ncol(lambda), |
|
| 1003 |
# ncol = ncol(Yc)) |
|
| 1004 |
# tmp[,var.idx] <- FSC |
|
| 1005 |
# FSM.g[[p]] <- tmp |
|
| 1006 |
# } |
|
| 1007 | ||
| 1008 |
# factor score for this pattern |
|
| 1009 | ! |
FS.g[Mp$case.idx[[p]], ] <- t(FSC %*% t(Oc) + EETA.g) |
| 1010 | ||
| 1011 |
# SE? |
|
| 1012 | ! |
if (se == "standard") {
|
| 1013 | ! |
tmp <- (VETA.g - VETA.g %*% t(lambda) %*% |
| 1014 | ! |
Sigma_22.inv %*% lambda %*% VETA.g) |
| 1015 | ! |
tmp.d <- diag(tmp) |
| 1016 | ! |
tmp.d[tmp.d < 1e-05] <- as.numeric(NA) |
| 1017 | ||
| 1018 |
# all cases in this pattern get the same SEs |
|
| 1019 | ! |
SE.g[Mp$case.idx[[p]], ] <- matrix(sqrt(tmp.d), |
| 1020 | ! |
nrow = length(Mp$case.idx[[p]]), |
| 1021 | ! |
ncol = ncol(SE.g), byrow = TRUE |
| 1022 |
) |
|
| 1023 |
} |
|
| 1024 | ||
| 1025 |
# ACOV? |
|
| 1026 | ! |
if (acov == "standard") {
|
| 1027 | ! |
ACOV.g[[p]] <- tmp # for this pattern |
| 1028 |
} |
|
| 1029 |
} # p |
|
| 1030 |
} else {
|
|
| 1031 |
# compute factor scores |
|
| 1032 | 20x |
FS.g <- t(FSC %*% t(Yc) + EETA.g) |
| 1033 |
} |
|
| 1034 | ||
| 1035 |
# replace values in dummy lv's by their observed counterpart |
|
| 1036 | 20x |
if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L && level == 1L) {
|
| 1037 | ! |
FS.g[, lavmodel@ov.y.dummy.lv.idx[[g]]] <- |
| 1038 | ! |
data.obs.g[, lavmodel@ov.y.dummy.ov.idx[[g]], drop = FALSE] |
| 1039 |
} |
|
| 1040 | 20x |
if (length(lavmodel@ov.x.dummy.lv.idx[[g]]) > 0L && level == 1L) {
|
| 1041 | ! |
FS.g[, lavmodel@ov.x.dummy.lv.idx[[g]]] <- |
| 1042 | ! |
data.obs.g[, lavmodel@ov.x.dummy.ov.idx[[g]], drop = FALSE] |
| 1043 |
} |
|
| 1044 | ||
| 1045 | 20x |
FS[[g]] <- FS.g |
| 1046 | ||
| 1047 |
# FSM |
|
| 1048 | 20x |
if (fsm) {
|
| 1049 | 12x |
FSM[[g]] <- FSM.g |
| 1050 |
} |
|
| 1051 | ||
| 1052 |
# REL |
|
| 1053 | 20x |
if (rel) {
|
| 1054 | ! |
REL[[g]] <- REL.g |
| 1055 |
} |
|
| 1056 | ||
| 1057 |
# standard error |
|
| 1058 | 20x |
if (se == "standard" && !transform) { # for now
|
| 1059 | 12x |
if (lavdata@missing %in% c("ml", "ml.x")) {
|
| 1060 | ! |
SE[[g]] <- SE.g |
| 1061 | ! |
if (acov == "standard") {
|
| 1062 | ! |
ACOV[[g]] <- ACOV.g |
| 1063 |
} |
|
| 1064 |
} else { # complete data
|
|
| 1065 | 12x |
tmp <- (VETA.g - VETA.g %*% t(LAMBDA.g) %*% |
| 1066 | 12x |
Sigma.inv.g %*% LAMBDA.g %*% VETA.g) |
| 1067 | 12x |
tmp.d <- diag(tmp) |
| 1068 | 12x |
tmp.d[tmp.d < 1e-05] <- as.numeric(NA) |
| 1069 | 12x |
SE[[g]] <- matrix(sqrt(tmp.d), nrow = 1L) |
| 1070 | ||
| 1071 |
# return full sampling covariance matrix? |
|
| 1072 | 12x |
if (acov == "standard") {
|
| 1073 | 12x |
ACOV[[g]] <- tmp |
| 1074 |
} |
|
| 1075 |
} |
|
| 1076 |
} # se = "standard" |
|
| 1077 |
} # g |
|
| 1078 | ||
| 1079 | 15x |
if (fsm) {
|
| 1080 | 9x |
attr(FS, "fsm") <- FSM |
| 1081 |
} |
|
| 1082 | 15x |
if (rel) {
|
| 1083 | ! |
attr(FS, "rel") <- REL |
| 1084 |
} |
|
| 1085 | 15x |
if (se != "none") {
|
| 1086 | 9x |
attr(FS, "se") <- SE |
| 1087 |
# return full sampling covariance matrix? |
|
| 1088 | 9x |
if (acov == "standard") {
|
| 1089 | 9x |
attr(FS, "acov") <- ACOV |
| 1090 |
} |
|
| 1091 |
} |
|
| 1092 | ||
| 1093 | 15x |
FS |
| 1094 |
} |
|
| 1095 | ||
| 1096 |
# factor scores - normal case - Bartlett method |
|
| 1097 |
# NOTES: 1) this is the classic 'Bartlett' method; for the linear/continuous |
|
| 1098 |
# case, this is equivalent to 'ML' |
|
| 1099 |
# 2) the usual formula is: |
|
| 1100 |
# FSC = solve(lambda' theta.inv lambda) (lambda' theta.inv) |
|
| 1101 |
# BUT to deal with singular THETA (with zeroes on the diagonal), |
|
| 1102 |
# we use the 'GLS' version instead: |
|
| 1103 |
# FSC = solve(lambda' sigma.inv lambda) (lambda' sigma.inv) |
|
| 1104 |
# Reference: Bentler & Yuan (1997) 'Optimal Conditionally Unbiased |
|
| 1105 |
# Equivariant Factor Score Estimators' |
|
| 1106 |
# in Berkane (Ed) 'Latent variable modeling with |
|
| 1107 |
# applications to causality' (Springer-Verlag) |
|
| 1108 |
# 3) instead of solve(), we use MASS::ginv, for special settings where |
|
| 1109 |
# -by construction- (lambda' sigma.inv lambda) is singular |
|
| 1110 |
# note: this will destroy the conditionally unbiased property |
|
| 1111 |
# of Bartlett scores!! |
|
| 1112 |
lav_predict_eta_bartlett <- function(lavobject = NULL, # for convenience |
|
| 1113 |
# sub objects |
|
| 1114 |
lavmodel = NULL, lavdata = NULL, |
|
| 1115 |
lavsamplestats = NULL, |
|
| 1116 |
lavimplied = NULL, |
|
| 1117 |
# optional new data |
|
| 1118 |
data.obs = NULL, eXo = NULL, |
|
| 1119 |
se = "none", acov = "none", level = 1L, |
|
| 1120 |
fsm = FALSE, rel = FALSE, |
|
| 1121 |
transform = FALSE) {
|
|
| 1122 |
# full object? |
|
| 1123 | 9x |
if (inherits(lavobject, "lavaan")) {
|
| 1124 | ! |
lavmodel <- lavobject@Model |
| 1125 | ! |
lavdata <- lavobject@Data |
| 1126 | ! |
lavsamplestats <- lavobject@SampleStats |
| 1127 | ! |
lavimplied <- lavobject@implied |
| 1128 |
} else {
|
|
| 1129 | 9x |
stopifnot( |
| 1130 | 9x |
!is.null(lavmodel), !is.null(lavdata), |
| 1131 | 9x |
!is.null(lavsamplestats), !is.null(lavimplied) |
| 1132 |
) |
|
| 1133 |
} |
|
| 1134 | ||
| 1135 | 9x |
if (is.null(data.obs)) {
|
| 1136 | ! |
data.obs <- lavdata@X |
| 1137 | ! |
newdata.flag <- FALSE |
| 1138 |
} else {
|
|
| 1139 | 9x |
newdata.flag <- TRUE |
| 1140 |
} |
|
| 1141 |
# eXo not needed |
|
| 1142 | ||
| 1143 |
# missings? and missing = "ml"? |
|
| 1144 | 9x |
if (lavdata@missing %in% c("ml", "ml.x")) {
|
| 1145 | ! |
if (newdata.flag) {
|
| 1146 | ! |
MP <- vector("list", lavdata@ngroups)
|
| 1147 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 1148 | ! |
MP[[g]] <- lav_data_missing_patterns(data.obs[[g]]) |
| 1149 |
} |
|
| 1150 |
} else {
|
|
| 1151 | ! |
MP <- lavdata@Mp |
| 1152 |
} |
|
| 1153 |
} |
|
| 1154 | ||
| 1155 | 9x |
LAMBDA <- lav_model_lambda(lavmodel = lavmodel, remove.dummy.lv = FALSE) |
| 1156 | 9x |
Sigma.hat <- lavimplied$cov |
| 1157 | 9x |
Sigma.inv <- lapply(lavimplied$cov, MASS::ginv) |
| 1158 | 9x |
VETA <- lav_model_veta(lavmodel = lavmodel) # for se only |
| 1159 | 9x |
EETA <- lav_model_eeta(lavmodel = lavmodel, lavsamplestats = lavsamplestats) |
| 1160 | 9x |
EY <- lav_model_ey(lavmodel = lavmodel, lavsamplestats = lavsamplestats) |
| 1161 | ||
| 1162 | 9x |
FS <- vector("list", length = lavdata@ngroups)
|
| 1163 | 9x |
if (fsm) {
|
| 1164 | 9x |
FSM <- vector("list", length = lavdata@ngroups)
|
| 1165 |
} |
|
| 1166 | 9x |
if (rel) {
|
| 1167 | ! |
REL <- vector("list", length = lavdata@ngroups)
|
| 1168 |
} |
|
| 1169 | 9x |
if (transform) {
|
| 1170 | ! |
TMAT <- lav_predict_tmat_det(lavmodel = lavmodel, |
| 1171 | ! |
lavimplied = lavimplied) |
| 1172 |
} |
|
| 1173 | ||
| 1174 | 9x |
if (acov != "none") se <- acov # ACOV implies SE |
| 1175 | 9x |
if (se != "none") {
|
| 1176 | 9x |
SE <- vector("list", length = lavdata@ngroups)
|
| 1177 |
# return full sampling covariance matrix? |
|
| 1178 | 9x |
if (acov != "none") {
|
| 1179 | 9x |
ACOV <- vector("list", length = lavdata@ngroups)
|
| 1180 |
} |
|
| 1181 |
} |
|
| 1182 | ||
| 1183 | 9x |
for (g in 1:lavdata@ngroups) {
|
| 1184 |
# determine block |
|
| 1185 | 12x |
if (lavdata@nlevels == 1L) {
|
| 1186 | 6x |
b <- g |
| 1187 |
} else {
|
|
| 1188 | 6x |
b <- (g - 1) * lavdata@nlevels + level |
| 1189 |
} |
|
| 1190 | ||
| 1191 | 12x |
VETA.g <- VETA[[b]] |
| 1192 | 12x |
EETA.g <- EETA[[b]] |
| 1193 | 12x |
LAMBDA.g <- LAMBDA[[b]] |
| 1194 | 12x |
EY.g <- EY[[b]] |
| 1195 | 12x |
Sigma.inv.g <- Sigma.inv[[b]] |
| 1196 | ||
| 1197 | 12x |
if (lavdata@nlevels > 1L) {
|
| 1198 | 6x |
Lp <- lavdata@Lp[[g]] |
| 1199 | 6x |
YLp <- lavsamplestats@YLp[[g]] |
| 1200 | ||
| 1201 |
# implied for this group |
|
| 1202 | 6x |
group.idx <- (g - 1) * lavdata@nlevels + seq_len(lavdata@nlevels) |
| 1203 | 6x |
implied.group <- lapply(lavimplied, function(x) x[group.idx]) |
| 1204 | ||
| 1205 |
# random effects (=random intercepts or cluster means) |
|
| 1206 |
# NOTE: is the 'ML' way not simply using the observed cluster |
|
| 1207 |
# means? |
|
| 1208 | 6x |
out <- lav_mvnorm_cluster_implied22l( |
| 1209 | 6x |
Lp = Lp, |
| 1210 | 6x |
implied = implied.group |
| 1211 |
) |
|
| 1212 | 6x |
MB.j <- lav_mvnorm_cluster_em_estep_ranef( |
| 1213 | 6x |
YLp = YLp, Lp = Lp, |
| 1214 | 6x |
sigma.w = out$sigma.w, sigma.b = out$sigma.b, |
| 1215 | 6x |
sigma.zz = out$sigma.zz, sigma.yz = out$sigma.yz, |
| 1216 | 6x |
mu.z = out$mu.z, mu.w = out$mu.w, mu.b = out$mu.b, |
| 1217 | 6x |
se = FALSE |
| 1218 |
) |
|
| 1219 | ||
| 1220 | 6x |
ov.idx <- Lp$ov.idx |
| 1221 | ||
| 1222 | 6x |
if (level == 1L) {
|
| 1223 | 6x |
data.W <- data.obs[[g]][, ov.idx[[1]]] |
| 1224 | 6x |
data.B <- MB.j[Lp$cluster.idx[[2]], , drop = FALSE] |
| 1225 | ||
| 1226 |
# center |
|
| 1227 | 6x |
data.obs.g <- data.W - data.B |
| 1228 | ! |
} else if (level == 2L) {
|
| 1229 | ! |
Data.B <- matrix(0, |
| 1230 | ! |
nrow = nrow(MB.j), |
| 1231 | ! |
ncol = ncol(data.obs[[g]]) |
| 1232 |
) |
|
| 1233 | ! |
Data.B[, ov.idx[[1]]] <- MB.j |
| 1234 | ! |
between.idx <- Lp$between.idx[[2 * g]] |
| 1235 | ! |
if (length(between.idx) > 0L) {
|
| 1236 | ! |
Data.B[, between.idx] <- data.obs[[g]][ |
| 1237 | ! |
!duplicated(Lp$cluster.idx[[2]]), |
| 1238 | ! |
between.idx |
| 1239 |
] |
|
| 1240 |
} |
|
| 1241 | ! |
data.obs.g <- Data.B[, ov.idx[[2]]] |
| 1242 |
} else {
|
|
| 1243 | ! |
lav_msg_stop(gettext("only 2 levels are supported"))
|
| 1244 |
} |
|
| 1245 |
} else {
|
|
| 1246 | 6x |
data.obs.g <- data.obs[[b]] |
| 1247 |
} |
|
| 1248 | ||
| 1249 | 12x |
nfac <- ncol(VETA.g) |
| 1250 | 12x |
if (nfac == 0L) {
|
| 1251 | ! |
FS[[g]] <- matrix(0, lavdata@nobs[[g]], nfac) |
| 1252 | ! |
next |
| 1253 |
} |
|
| 1254 | ||
| 1255 |
# center data |
|
| 1256 | 12x |
Yc <- t(t(data.obs.g) - EY.g) |
| 1257 | ||
| 1258 |
# sampling weights? CHECKME: needed?? |
|
| 1259 | 12x |
if (!is.null(lavdata@weights[[g]]) && level == 1L) {
|
| 1260 |
# EY.g is already weighted |
|
| 1261 |
# use sampling.weights.normalization == "group" |
|
| 1262 | ! |
WT <- lavdata@weights[[g]] |
| 1263 | ! |
WT2 <- WT / sum(WT) * lavdata@nobs[[g]] |
| 1264 | ! |
Yc <- Yc * sqrt(WT2) |
| 1265 |
} |
|
| 1266 | ||
| 1267 |
# global factor score coefficient matrix 'C' |
|
| 1268 | 12x |
FSC <- (MASS::ginv(t(LAMBDA.g) %*% Sigma.inv.g %*% LAMBDA.g) |
| 1269 | 12x |
%*% t(LAMBDA.g) %*% Sigma.inv.g) |
| 1270 | ||
| 1271 |
# transform? |
|
| 1272 | 12x |
if (transform) {
|
| 1273 | ! |
FSC <- TMAT[[b]] %*% FSC |
| 1274 |
} |
|
| 1275 | ||
| 1276 |
# store fsm? |
|
| 1277 | 12x |
if (fsm) {
|
| 1278 |
# store fsm? |
|
| 1279 | 12x |
FSM.g <- FSC |
| 1280 |
} |
|
| 1281 | ||
| 1282 |
# reliability? |
|
| 1283 | 12x |
if (rel) {
|
| 1284 | ! |
Var.f <- FSC %*% Sigma.hat[[g]] %*% t(FSC) # or S? |
| 1285 | ! |
Cov.f.eta <- FSC %*% LAMBDA.g %*% VETA.g |
| 1286 | ! |
Var.eta <- VETA.g |
| 1287 |
# FS.determinacy <- diag( diag(1/sqrt(diag(Var.f))) %*% |
|
| 1288 |
# Cov.f.eta %*% |
|
| 1289 |
# diag(1/sqrt(diag(Var.eta))) |
|
| 1290 |
# ) |
|
| 1291 | ! |
FS.determinacy <- ( diag(Cov.f.eta) / |
| 1292 | ! |
(sqrt(diag(Var.f)) * sqrt(diag(Var.eta))) ) |
| 1293 | ! |
REL.g <- FS.determinacy*FS.determinacy |
| 1294 |
} |
|
| 1295 | ||
| 1296 |
# compute factor scores |
|
| 1297 | 12x |
if (lavdata@missing %in% c("ml", "ml.x")) {
|
| 1298 |
# missing patterns for this group |
|
| 1299 | ! |
Mp <- MP[[g]] |
| 1300 | ||
| 1301 |
# factor scores container |
|
| 1302 | ! |
FS.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g)) |
| 1303 | ||
| 1304 |
# if(fsm) {
|
|
| 1305 |
# FSM.g <- vector("list", length = Mp$npatterns)
|
|
| 1306 |
# } |
|
| 1307 | ||
| 1308 | ! |
if (se == "standard") {
|
| 1309 | ! |
SE.g <- matrix(as.numeric(NA), nrow(Yc), ncol = length(EETA.g)) |
| 1310 |
} |
|
| 1311 | ||
| 1312 | ! |
if (acov == "standard") {
|
| 1313 | ! |
ACOV.g <- vector("list", length = Mp$npatterns)
|
| 1314 |
} |
|
| 1315 | ||
| 1316 |
# compute FSC per pattern |
|
| 1317 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 1318 | ! |
var.idx <- Mp$pat[p, ] # observed |
| 1319 | ! |
na.idx <- which(!var.idx) # missing |
| 1320 | ||
| 1321 |
# extract observed data for these (centered) cases |
|
| 1322 | ! |
Oc <- Yc[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE] |
| 1323 | ||
| 1324 |
# invert Sigma (Sigma_22, observed part only) for this pattern |
|
| 1325 | ! |
Sigma_22.inv <- try(lav_matrix_symmetric_inverse_update( |
| 1326 | ! |
S.inv = |
| 1327 | ! |
Sigma.inv.g, rm.idx = na.idx, |
| 1328 | ! |
logdet = FALSE |
| 1329 | ! |
), silent = TRUE) |
| 1330 | ! |
if (inherits(Sigma_22.inv, "try-error")) {
|
| 1331 | ! |
lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
|
| 1332 |
} |
|
| 1333 | ||
| 1334 | ! |
lambda <- LAMBDA.g[var.idx, , drop = FALSE] |
| 1335 | ! |
FSC <- (MASS::ginv(t(lambda) %*% Sigma_22.inv %*% lambda) |
| 1336 | ! |
%*% t(lambda) %*% Sigma_22.inv) |
| 1337 | ||
| 1338 |
# if FSC contains rows that are all-zero, replace by NA |
|
| 1339 |
# |
|
| 1340 |
# this happens eg if all the indicators of a single factor |
|
| 1341 |
# are missing; then this column in lambda only contains zeroes |
|
| 1342 |
# and therefore the corresponding row in FSC contains only |
|
| 1343 |
# zeroes, leading to factor score 0 |
|
| 1344 |
# |
|
| 1345 |
# showing 'NA' is better than getting 0 |
|
| 1346 |
# |
|
| 1347 |
# (Note that this is not needed for the 'regression' method, |
|
| 1348 |
# only for Bartlett) |
|
| 1349 |
# |
|
| 1350 | ! |
zero.idx <- which(apply(FSC, 1L, function(x) all(x == 0))) |
| 1351 | ! |
if (length(zero.idx) > 0L) {
|
| 1352 | ! |
FSC[zero.idx, ] <- NA |
| 1353 |
} |
|
| 1354 | ||
| 1355 |
# FSM? |
|
| 1356 |
# if(fsm) {
|
|
| 1357 |
# tmp <- matrix(as.numeric(NA), nrow = ncol(lambda), |
|
| 1358 |
# ncol = ncol(Yc)) |
|
| 1359 |
# tmp[,var.idx] <- FSC |
|
| 1360 |
# FSM.g[[p]] <- tmp |
|
| 1361 |
# } |
|
| 1362 | ||
| 1363 |
# factor scores for this pattern |
|
| 1364 | ! |
FS.g[Mp$case.idx[[p]], ] <- t(FSC %*% t(Oc) + EETA.g) |
| 1365 | ||
| 1366 |
# SE? |
|
| 1367 | ! |
if (se == "standard") {
|
| 1368 | ! |
tmp <- (MASS::ginv(t(lambda) %*% Sigma_22.inv %*% lambda) |
| 1369 | ! |
- VETA.g) |
| 1370 | ! |
tmp.d <- diag(tmp) |
| 1371 | ! |
tmp.d[tmp.d < 1e-05] <- as.numeric(NA) |
| 1372 | ||
| 1373 |
# all cases in this pattern get the same SEs |
|
| 1374 | ! |
SE.g[Mp$case.idx[[p]], ] <- matrix(sqrt(tmp.d), |
| 1375 | ! |
nrow = length(Mp$case.idx[[p]]), |
| 1376 | ! |
ncol = ncol(SE.g), byrow = TRUE |
| 1377 |
) |
|
| 1378 |
} |
|
| 1379 | ||
| 1380 |
# ACOV? |
|
| 1381 | ! |
if (acov == "standard") {
|
| 1382 | ! |
ACOV.g[[p]] <- tmp # for this pattern |
| 1383 |
} |
|
| 1384 |
} |
|
| 1385 | ||
| 1386 |
# what about FSM? There is no single one, but as many as patterns |
|
| 1387 |
# if(fsm) {
|
|
| 1388 |
# # use 'global' version (just like in complete case) |
|
| 1389 |
# FSM[[g]] <- ( MASS::ginv(t(LAMBDA.g) %*% Sigma.inv.g %*% |
|
| 1390 |
# LAMBDA.g) %*% t(LAMBDA.g) %*% Sigma.inv.g ) |
|
| 1391 |
# } |
|
| 1392 |
} else {
|
|
| 1393 |
# compute factor scores |
|
| 1394 | 12x |
FS.g <- t(FSC %*% t(Yc) + EETA.g) |
| 1395 |
} |
|
| 1396 | ||
| 1397 |
# replace values in dummy lv's by their observed counterpart |
|
| 1398 | 12x |
if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L && level == 1L) {
|
| 1399 | ! |
FS.g[, lavmodel@ov.y.dummy.lv.idx[[g]]] <- |
| 1400 | ! |
data.obs[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]], drop = FALSE] |
| 1401 |
} |
|
| 1402 | 12x |
if (length(lavmodel@ov.x.dummy.lv.idx[[g]]) > 0L && level == 1L) {
|
| 1403 | ! |
FS.g[, lavmodel@ov.x.dummy.lv.idx[[g]]] <- |
| 1404 | ! |
data.obs[[g]][, lavmodel@ov.x.dummy.ov.idx[[g]], drop = FALSE] |
| 1405 |
} |
|
| 1406 | ||
| 1407 | 12x |
FS[[g]] <- FS.g |
| 1408 | ||
| 1409 |
# FSM |
|
| 1410 | 12x |
if (fsm) {
|
| 1411 | 12x |
FSM[[g]] <- FSM.g |
| 1412 |
} |
|
| 1413 | ||
| 1414 |
# REL |
|
| 1415 | 12x |
if (rel) {
|
| 1416 | ! |
REL[[g]] <- REL.g |
| 1417 |
} |
|
| 1418 | ||
| 1419 |
# standard error |
|
| 1420 | 12x |
if (se == "standard" && !transform) {
|
| 1421 | 12x |
if (lavdata@missing %in% c("ml", "ml.x")) {
|
| 1422 | ! |
SE[[g]] <- SE.g |
| 1423 | ! |
if (acov == "standard") {
|
| 1424 | ! |
ACOV[[g]] <- ACOV.g |
| 1425 |
} |
|
| 1426 |
} else { # complete data
|
|
| 1427 | ||
| 1428 |
# the traditional formula is: |
|
| 1429 |
# solve(t(lambda) %*% solve(theta) %*% lambda) |
|
| 1430 |
# but we replace it by |
|
| 1431 |
# solve( t(lambda) %*% solve(sigma) %*% lambda ) - psi |
|
| 1432 |
# to handle negative variances |
|
| 1433 |
# in addition, we use ginv |
|
| 1434 | 12x |
tmp <- (MASS::ginv(t(LAMBDA.g) %*% Sigma.inv.g %*% LAMBDA.g) |
| 1435 | 12x |
- VETA.g) |
| 1436 | 12x |
tmp.d <- diag(tmp) |
| 1437 | 12x |
tmp.d[tmp.d < 1e-05] <- as.numeric(NA) |
| 1438 | 12x |
SE[[g]] <- matrix(sqrt(tmp.d), nrow = 1L) |
| 1439 | ||
| 1440 |
# return full sampling covariance matrix? |
|
| 1441 | 12x |
if (acov == "standard") {
|
| 1442 | 12x |
ACOV[[g]] <- tmp |
| 1443 |
} |
|
| 1444 |
} |
|
| 1445 |
} # se |
|
| 1446 |
} # g |
|
| 1447 | ||
| 1448 | 9x |
if (fsm) {
|
| 1449 | 9x |
attr(FS, "fsm") <- FSM |
| 1450 |
} |
|
| 1451 | 9x |
if (rel) {
|
| 1452 | ! |
attr(FS, "rel") <- REL |
| 1453 |
} |
|
| 1454 | 9x |
if (se != "none") {
|
| 1455 | 9x |
attr(FS, "se") <- SE |
| 1456 |
# return full sampling covariance matrix? |
|
| 1457 | 9x |
if (acov == "standard") {
|
| 1458 | 9x |
attr(FS, "acov") <- ACOV |
| 1459 |
} |
|
| 1460 |
} |
|
| 1461 | ||
| 1462 | 9x |
FS |
| 1463 |
} |
|
| 1464 | ||
| 1465 |
# factor scores - EBM or ML |
|
| 1466 |
lav_predict_eta_ebm_ml <- function(lavobject = NULL, # for convenience |
|
| 1467 |
# sub objects |
|
| 1468 |
lavmodel = NULL, lavdata = NULL, |
|
| 1469 |
lavsamplestats = NULL, |
|
| 1470 |
# optional new data |
|
| 1471 |
data.obs = NULL, eXo = NULL, |
|
| 1472 |
se = "none", acov = "none", level = 1L, |
|
| 1473 |
ML = FALSE, |
|
| 1474 |
optim.method = "bfgs") {
|
|
| 1475 | ! |
optim.method <- tolower(optim.method) |
| 1476 | ||
| 1477 | ! |
stopifnot(optim.method %in% c("nlminb", "bfgs"))
|
| 1478 | ||
| 1479 |
### FIXME: if all indicators of a factor are normal, can we not |
|
| 1480 |
### just use the `classic' regression method?? |
|
| 1481 |
### (perhaps after whitening, to get uncorrelated factors...) |
|
| 1482 | ||
| 1483 |
# full object? |
|
| 1484 | ! |
if (inherits(lavobject, "lavaan")) {
|
| 1485 | ! |
lavmodel <- lavobject@Model |
| 1486 | ! |
lavdata <- lavobject@Data |
| 1487 | ! |
lavsamplestats <- lavobject@SampleStats |
| 1488 |
} else {
|
|
| 1489 | ! |
stopifnot( |
| 1490 | ! |
!is.null(lavmodel), !is.null(lavdata), |
| 1491 | ! |
!is.null(lavsamplestats) |
| 1492 |
) |
|
| 1493 |
} |
|
| 1494 | ||
| 1495 |
# new data? |
|
| 1496 | ! |
if (is.null(data.obs)) {
|
| 1497 | ! |
data.obs <- lavdata@X |
| 1498 |
} |
|
| 1499 | ! |
if (is.null(eXo)) {
|
| 1500 | ! |
eXo <- lavdata@eXo |
| 1501 |
} |
|
| 1502 | ||
| 1503 |
# se? |
|
| 1504 | ! |
if (acov != "none") {
|
| 1505 | ! |
se <- acov # ACOV implies SE |
| 1506 |
} |
|
| 1507 |
# if(se != "none") {
|
|
| 1508 |
# warning("lavaan WARNING: standard errors are not available (yet) for the non-normal case")
|
|
| 1509 |
# } |
|
| 1510 | ||
| 1511 | ! |
VETAx <- lav_model_vetax(lavmodel = lavmodel) |
| 1512 | ! |
VETAx.inv <- VETAx |
| 1513 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 1514 | ! |
if (nrow(VETAx[[g]]) > 0L) {
|
| 1515 | ! |
VETAx.inv[[g]] <- solve(VETAx[[g]]) |
| 1516 |
} |
|
| 1517 |
} |
|
| 1518 | ! |
EETAx <- lav_model_eetax( |
| 1519 | ! |
lavmodel = lavmodel, lavsamplestats = lavsamplestats, |
| 1520 | ! |
eXo = eXo, nobs = lapply(data.obs, NROW), |
| 1521 | ! |
remove.dummy.lv = TRUE |
| 1522 | ! |
) ## FIXME? |
| 1523 | ! |
TH <- lav_model_th(lavmodel = lavmodel, delta = FALSE) |
| 1524 | ! |
THETA <- lav_model_theta(lavmodel = lavmodel) |
| 1525 | ||
| 1526 |
# check for zero entries in THETA (new in 0.6-4) |
|
| 1527 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 1528 | ! |
if (any(diag(THETA[[g]]) == 0)) {
|
| 1529 | ! |
lav_msg_stop(gettext( |
| 1530 | ! |
"(residual) variance matrix THETA contains zero elements |
| 1531 | ! |
on the diagonal.")) |
| 1532 |
} |
|
| 1533 |
} |
|
| 1534 | ||
| 1535 |
# local objective function: x = lv values |
|
| 1536 | ! |
f.eta.i <- function(x, y.i, x.i, mu.i) {
|
| 1537 |
# add 'dummy' values (if any) for ov.y |
|
| 1538 | ! |
if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L) {
|
| 1539 | ! |
x2 <- c(x - mu.i, data.obs[[g]][i, |
| 1540 | ! |
lavmodel@ov.y.dummy.ov.idx[[g]], |
| 1541 | ! |
drop = FALSE |
| 1542 |
]) |
|
| 1543 |
} else {
|
|
| 1544 | ! |
x2 <- x - mu.i |
| 1545 |
} |
|
| 1546 | ||
| 1547 |
# conditional density of y, given eta.i(=x) |
|
| 1548 | ! |
log.fy <- lav_predict_fy_eta.i( |
| 1549 | ! |
lavmodel = lavmodel, |
| 1550 | ! |
lavdata = lavdata, |
| 1551 | ! |
lavsamplestats = lavsamplestats, |
| 1552 | ! |
y.i = y.i, |
| 1553 | ! |
x.i = x.i, |
| 1554 | ! |
eta.i = matrix(x2, nrow = 1L), # <---- eta! |
| 1555 | ! |
theta.sd = theta.sd, |
| 1556 | ! |
th = th, |
| 1557 | ! |
th.idx = th.idx, |
| 1558 | ! |
log = TRUE |
| 1559 |
) |
|
| 1560 | ||
| 1561 | ! |
if (ML) {
|
| 1562 |
# NOTE: 'true' ML is simply -1*sum(log.fy) |
|
| 1563 |
# - but there is no upper/lower bound for the extrema: |
|
| 1564 |
# a pattern of all (in)correct drives the 'theta' parameter |
|
| 1565 |
# towards +/- Inf |
|
| 1566 |
# - therefore, we add a vague prior, just to stabilize |
|
| 1567 |
# |
|
| 1568 | ! |
diff <- t(x) - mu.i |
| 1569 | ! |
V <- diag(length(x)) * 1e-05 |
| 1570 | ! |
tmp <- as.numeric(0.5 * diff %*% V %*% t(diff)) |
| 1571 | ! |
out <- 1 + tmp - sum(log.fy, na.rm = TRUE) |
| 1572 |
} else {
|
|
| 1573 | ! |
diff <- t(x) - mu.i |
| 1574 | ! |
V <- VETAx.inv[[g]] |
| 1575 | ! |
tmp <- as.numeric(0.5 * diff %*% V %*% t(diff)) |
| 1576 | ! |
out <- tmp - sum(log.fy, na.rm = TRUE) |
| 1577 |
} |
|
| 1578 | ! |
out |
| 1579 |
} |
|
| 1580 | ||
| 1581 | ! |
FS <- vector("list", length = lavdata@ngroups)
|
| 1582 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 1583 | ! |
nfac <- ncol(VETAx[[g]]) |
| 1584 | ! |
nfac2 <- nfac |
| 1585 | ! |
if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L) {
|
| 1586 | ! |
nfac2 <- nfac2 + length(lavmodel@ov.y.dummy.lv.idx[[g]]) |
| 1587 |
} |
|
| 1588 | ! |
FS[[g]] <- matrix(as.numeric(NA), nrow(data.obs[[g]]), nfac2) |
| 1589 | ||
| 1590 |
# special case: no regular lv's |
|
| 1591 | ! |
if (nfac == 0) {
|
| 1592 |
# impute dummy ov.y (if any) |
|
| 1593 | ! |
FS[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]]] <- |
| 1594 | ! |
data.obs[[g]][, lavmodel@ov.y.dummy.ov.idx[[g]], drop = FALSE] |
| 1595 | ! |
next |
| 1596 |
} |
|
| 1597 | ||
| 1598 |
## FIXME: factor scores not identical (but close) to Mplus |
|
| 1599 |
# if delta elements not equal to 1?? |
|
| 1600 | ! |
mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0, lavmodel@nmat))[g] |
| 1601 | ! |
MLIST <- lavmodel@GLIST[mm.in.group] |
| 1602 | ||
| 1603 |
# check for negative values |
|
| 1604 | ! |
neg.var.idx <- which(diag(THETA[[g]]) < 0) |
| 1605 | ! |
if (length(neg.var.idx) > 0) {
|
| 1606 | ! |
lav_msg_warn( |
| 1607 | ! |
gettext("factor scores could not be computed due to at least
|
| 1608 | ! |
one negative (residual) variance")) |
| 1609 | ! |
next |
| 1610 |
} |
|
| 1611 | ||
| 1612 |
# common values |
|
| 1613 | ! |
theta.sd <- sqrt(diag(THETA[[g]])) |
| 1614 | ! |
th <- TH[[g]] |
| 1615 | ! |
th.idx <- lavmodel@th.idx[[g]] |
| 1616 | ||
| 1617 |
# casewise for now |
|
| 1618 | ! |
N <- nrow(data.obs[[g]]) |
| 1619 | ! |
for (i in 1:N) {
|
| 1620 |
# eXo? |
|
| 1621 | ! |
if (!is.null(eXo[[g]])) {
|
| 1622 | ! |
x.i <- eXo[[g]][i, , drop = FALSE] |
| 1623 |
} else {
|
|
| 1624 | ! |
x.i <- NULL |
| 1625 |
} |
|
| 1626 | ! |
mu.i <- EETAx[[g]][i, , drop = FALSE] |
| 1627 | ! |
y.i <- data.obs[[g]][i, , drop = FALSE] |
| 1628 | ||
| 1629 |
### DEBUG ONLY: |
|
| 1630 |
# cat("i = ", i, "mu.i = ", mu.i, "\n")
|
|
| 1631 | ||
| 1632 | ! |
START <- numeric(nfac) # initial values for eta |
| 1633 | ||
| 1634 | ! |
if (!all(is.na(y.i))) {
|
| 1635 |
# find best values for eta.i |
|
| 1636 | ! |
if (optim.method == "nlminb") {
|
| 1637 | ! |
out <- nlminb( |
| 1638 | ! |
start = START, objective = f.eta.i, |
| 1639 | ! |
gradient = NULL, # for now |
| 1640 | ! |
control = list(rel.tol = 1e-8), |
| 1641 | ! |
y.i = y.i, x.i = x.i, mu.i = mu.i |
| 1642 |
) |
|
| 1643 | ! |
} else if (optim.method == "bfgs") {
|
| 1644 | ! |
out <- optim( |
| 1645 | ! |
par = START, fn = f.eta.i, |
| 1646 | ! |
gr = NULL, |
| 1647 | ! |
control = list(reltol = 1e-8, fnscale = 1.1), |
| 1648 | ! |
method = "BFGS", |
| 1649 | ! |
y.i = y.i, x.i = x.i, mu.i = mu.i |
| 1650 |
) |
|
| 1651 |
} |
|
| 1652 | ! |
if (out$convergence == 0L) {
|
| 1653 | ! |
eta.i <- out$par |
| 1654 |
} else {
|
|
| 1655 | ! |
eta.i <- rep(as.numeric(NA), nfac) |
| 1656 |
} |
|
| 1657 |
} else {
|
|
| 1658 | ! |
eta.i <- rep(as.numeric(NA), nfac) |
| 1659 |
} |
|
| 1660 | ||
| 1661 |
# add dummy ov.y lv values |
|
| 1662 | ! |
if (length(lavmodel@ov.y.dummy.lv.idx[[g]]) > 0L) {
|
| 1663 | ! |
eta.i <- c(eta.i, data.obs[[g]][i, |
| 1664 | ! |
lavmodel@ov.y.dummy.ov.idx[[g]], |
| 1665 | ! |
drop = FALSE |
| 1666 |
]) |
|
| 1667 |
} |
|
| 1668 | ||
| 1669 | ! |
FS[[g]][i, ] <- eta.i |
| 1670 |
} |
|
| 1671 |
} |
|
| 1672 | ||
| 1673 | ! |
FS |
| 1674 |
} |
|
| 1675 | ||
| 1676 |
# predicted value for response y*_i, conditional on the predicted latent |
|
| 1677 |
# variable scores |
|
| 1678 |
# `measurement part': |
|
| 1679 |
# y*_i = nu + lambda eta_i + K x_i + epsilon_i |
|
| 1680 |
# |
|
| 1681 |
# where eta_i = latent variable value for i (either given or from predict) |
|
| 1682 |
# |
|
| 1683 |
# Two types: 1) nrow(ETA) = nrow(X) (factor scores) |
|
| 1684 |
# 2) nrow(ETA) = 1L (given values) |
|
| 1685 |
# |
|
| 1686 |
# in both cases, we return [nobs x nvar] matrix per group |
|
| 1687 |
lav_predict_yhat <- function(lavobject = NULL, # for convience |
|
| 1688 |
# sub objects |
|
| 1689 |
lavmodel = NULL, lavdata = NULL, |
|
| 1690 |
lavsamplestats = NULL, |
|
| 1691 |
lavimplied = NULL, |
|
| 1692 |
# new data |
|
| 1693 |
data.obs = NULL, eXo = NULL, |
|
| 1694 |
# ETA values |
|
| 1695 |
ETA = NULL, |
|
| 1696 |
# options |
|
| 1697 |
method = "EBM", |
|
| 1698 |
duplicate = FALSE, |
|
| 1699 |
optim.method = "bfgs", |
|
| 1700 |
fsm = FALSE, |
|
| 1701 |
resid.flag = FALSE) {
|
|
| 1702 |
# full object? |
|
| 1703 | 3x |
if (inherits(lavobject, "lavaan")) {
|
| 1704 | 3x |
lavmodel <- lavobject@Model |
| 1705 | 3x |
lavdata <- lavobject@Data |
| 1706 | 3x |
lavsamplestats <- lavobject@SampleStats |
| 1707 | 3x |
lavimplied <- lavobject@implied |
| 1708 |
} else {
|
|
| 1709 | ! |
stopifnot( |
| 1710 | ! |
!is.null(lavmodel), !is.null(lavdata), |
| 1711 | ! |
!is.null(lavsamplestats), !is.null(lavimplied) |
| 1712 |
) |
|
| 1713 |
} |
|
| 1714 | ||
| 1715 |
# new data? |
|
| 1716 | 3x |
if (is.null(data.obs)) {
|
| 1717 | 3x |
data.obs <- lavdata@X |
| 1718 |
} |
|
| 1719 | 3x |
if (is.null(eXo)) {
|
| 1720 | 3x |
eXo <- lavdata@eXo |
| 1721 |
} |
|
| 1722 | ||
| 1723 |
# do we get values for ETA? If not, use `predict' to get plausible values |
|
| 1724 | 3x |
if (is.null(ETA)) {
|
| 1725 | 3x |
ETA <- lav_predict_eta( |
| 1726 | 3x |
lavobject = NULL, lavmodel = lavmodel, |
| 1727 | 3x |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 1728 | 3x |
lavimplied = lavimplied, |
| 1729 | 3x |
data.obs = data.obs, eXo = eXo, method = method, |
| 1730 | 3x |
optim.method = optim.method, fsm = fsm |
| 1731 |
) |
|
| 1732 | 3x |
FSM <- attr(ETA, "fsm") |
| 1733 |
} else {
|
|
| 1734 |
# matrix |
|
| 1735 | ! |
if (is.matrix(ETA)) { # user-specified?
|
| 1736 | ! |
if (nrow(ETA) == 1L) {
|
| 1737 | ! |
tmp <- matrix(ETA, lavsamplestats@ntotal, length(ETA), |
| 1738 | ! |
byrow = TRUE |
| 1739 |
) |
|
| 1740 | ! |
} else if (nrow(ETA) != lavsamplestats@ntotal) {
|
| 1741 | ! |
lav_msg_stop(gettext("nrow(ETA) != lavsamplestats@ntotal"))
|
| 1742 |
} else {
|
|
| 1743 | ! |
tmp <- ETA |
| 1744 |
} |
|
| 1745 | ! |
ETA <- lapply(1:lavdata@ngroups, function(i) tmp[lavdata@case.idx[[i]], ]) |
| 1746 |
# vector: just 1 row of factor-scores |
|
| 1747 | ! |
} else if (is.numeric(ETA)) {
|
| 1748 |
# convert to matrix |
|
| 1749 | ! |
tmp <- matrix(ETA, lavsamplestats@ntotal, length(ETA), byrow = TRUE) |
| 1750 | ! |
ETA <- lapply(1:lavdata@ngroups, function(i) tmp[lavdata@case.idx[[i]], ]) |
| 1751 | ! |
} else if (is.list(ETA)) {
|
| 1752 | ! |
stopifnot(lavdata@ngroups == length(ETA)) |
| 1753 |
} |
|
| 1754 |
} |
|
| 1755 | ||
| 1756 | 3x |
YHAT <- lav_model_yhat( |
| 1757 | 3x |
lavmodel = lavmodel, GLIST = NULL, |
| 1758 | 3x |
lavsamplestats = lavsamplestats, eXo = eXo, |
| 1759 | 3x |
nobs = lapply(data.obs, NROW), |
| 1760 | 3x |
ETA = ETA, duplicate = duplicate |
| 1761 |
) |
|
| 1762 | ||
| 1763 |
# if conditional.x, paste eXo |
|
| 1764 | 3x |
if (lavmodel@categorical && !is.null(eXo)) {
|
| 1765 | ! |
YHAT <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 1766 | ! |
ret <- cbind(YHAT[[g]], eXo[[g]]) |
| 1767 | ! |
ret |
| 1768 |
}) |
|
| 1769 |
} |
|
| 1770 | ||
| 1771 |
# residuals? compute y - yhat |
|
| 1772 | 3x |
if (resid.flag) {
|
| 1773 | ! |
RES <- lapply(seq_len(lavdata@ngroups), function(g) {
|
| 1774 | ! |
ret <- data.obs[[g]] - YHAT[[g]] |
| 1775 | ! |
ret |
| 1776 |
}) |
|
| 1777 |
} else {
|
|
| 1778 | 3x |
RES <- YHAT |
| 1779 |
} |
|
| 1780 | ||
| 1781 |
# fsm? |
|
| 1782 | 3x |
if (fsm) {
|
| 1783 | ! |
attr(RES, "fsm") <- FSM |
| 1784 |
} |
|
| 1785 | ||
| 1786 | 3x |
RES |
| 1787 |
} |
|
| 1788 | ||
| 1789 |
# conditional density y -- assuming independence!! |
|
| 1790 |
# f(y_i | eta_i, x_i) for EACH item |
|
| 1791 |
# |
|
| 1792 |
lav_predict_fy <- function(lavobject = NULL, # for convience |
|
| 1793 |
# sub objects |
|
| 1794 |
lavmodel = NULL, lavdata = NULL, |
|
| 1795 |
lavsamplestats = NULL, |
|
| 1796 |
lavimplied = NULL, |
|
| 1797 |
# new data |
|
| 1798 |
data.obs = NULL, eXo = NULL, |
|
| 1799 |
# ETA values |
|
| 1800 |
ETA = NULL, |
|
| 1801 |
# options |
|
| 1802 |
method = "EBM", |
|
| 1803 |
log. = FALSE, |
|
| 1804 |
optim.method = "bfgs") {
|
|
| 1805 |
# full object? |
|
| 1806 | ! |
if (inherits(lavobject, "lavaan")) {
|
| 1807 | ! |
lavmodel <- lavobject@Model |
| 1808 | ! |
lavdata <- lavobject@Data |
| 1809 | ! |
lavsamplestats <- lavobject@SampleStats |
| 1810 | ! |
lavimplied <- lavobject@implied |
| 1811 |
} else {
|
|
| 1812 | ! |
stopifnot( |
| 1813 | ! |
!is.null(lavmodel), !is.null(lavdata), |
| 1814 | ! |
!is.null(lavsamplestats), !is.null(lavimplied) |
| 1815 |
) |
|
| 1816 |
} |
|
| 1817 | ||
| 1818 |
# new data? |
|
| 1819 | ! |
if (is.null(data.obs)) {
|
| 1820 | ! |
data.obs <- lavdata@X |
| 1821 |
} |
|
| 1822 | ! |
if (is.null(eXo)) {
|
| 1823 | ! |
eXo <- lavdata@eXo |
| 1824 |
} |
|
| 1825 | ||
| 1826 |
# we need the YHATs (per group) |
|
| 1827 | ! |
YHAT <- lav_predict_yhat( |
| 1828 | ! |
lavobject = NULL, lavmodel = lavmodel, |
| 1829 | ! |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 1830 | ! |
lavimplied = lavimplied, |
| 1831 | ! |
data.obs = data.obs, eXo = eXo, ETA = ETA, method = method, |
| 1832 | ! |
duplicate = FALSE, optim.method = optim.method |
| 1833 |
) |
|
| 1834 | ||
| 1835 | ! |
THETA <- lav_model_theta(lavmodel = lavmodel) |
| 1836 | ! |
TH <- lav_model_th(lavmodel = lavmodel, delta = FALSE) |
| 1837 | ||
| 1838 | ! |
FY <- vector("list", length = lavdata@ngroups)
|
| 1839 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 1840 | ! |
FY[[g]] <- lav_predict_fy_internal( |
| 1841 | ! |
X = data.obs[[g]], yhat = YHAT[[g]], |
| 1842 | ! |
TH = TH[[g]], THETA = THETA[[g]], |
| 1843 | ! |
num.idx = lavmodel@num.idx[[g]], |
| 1844 | ! |
th.idx = lavmodel@th.idx[[g]], |
| 1845 | ! |
link = lavmodel@link, log. = log. |
| 1846 |
) |
|
| 1847 |
} |
|
| 1848 | ||
| 1849 | ! |
FY |
| 1850 |
} |
|
| 1851 | ||
| 1852 | ||
| 1853 |
# single group, internal function |
|
| 1854 |
lav_predict_fy_internal <- function(X = NULL, yhat = NULL, |
|
| 1855 |
TH = NULL, THETA = NULL, |
|
| 1856 |
num.idx = NULL, th.idx = NULL, |
|
| 1857 |
link = NULL, log. = FALSE) {
|
|
| 1858 |
# shortcuts |
|
| 1859 | ! |
theta.var <- diag(THETA) |
| 1860 | ||
| 1861 |
# check size YHAT (either 1L or Nobs rows) |
|
| 1862 | ! |
if (!(nrow(yhat) == 1L || nrow(yhat) == nrow(X))) {
|
| 1863 | ! |
lav_msg_stop(gettext("nrow(YHAT[[g]]) not 1L and not nrow(X))"))
|
| 1864 |
} |
|
| 1865 | ||
| 1866 | ! |
FY.group <- matrix(0, nrow(X), ncol(X)) |
| 1867 |
# if(NORMAL) {
|
|
| 1868 |
# if(nrow(yhat) == nrow(X)) {
|
|
| 1869 |
# tmp <- (X - yhat)^2 |
|
| 1870 |
# } else {
|
|
| 1871 |
# tmp <- sweep(X, MARGIN=2, STATS=yhat, FUN="-")^2 |
|
| 1872 |
# } |
|
| 1873 |
# tmp1 <- sweep(tmp, MARGIN=2, theta.var, "/") |
|
| 1874 |
# tmp2 <- exp( -0.5 * tmp1 ) |
|
| 1875 |
# tmp3 <- sweep(tmp2, MARGIN=2, sqrt(2*pi*theta.var), "/") |
|
| 1876 |
# if(log.) {
|
|
| 1877 |
# FY.group <- log(tmp3) |
|
| 1878 |
# } else {
|
|
| 1879 |
# FY.group <- tmp3 |
|
| 1880 |
# } |
|
| 1881 |
# } else {
|
|
| 1882 |
# mixed items |
|
| 1883 | ||
| 1884 | ! |
ord.idx <- unique(th.idx[th.idx > 0L]) |
| 1885 | ||
| 1886 |
# first, NUMERIC variables |
|
| 1887 | ! |
if (length(num.idx) > 0L) {
|
| 1888 | ! |
for (v in num.idx) {
|
| 1889 | ! |
FY.group[, v] <- dnorm(X[, v], |
| 1890 |
# YHAT may change or not per case |
|
| 1891 | ! |
mean = yhat[, v], |
| 1892 | ! |
sd = sqrt(theta.var[v]), |
| 1893 | ! |
log = log. |
| 1894 |
) |
|
| 1895 |
} |
|
| 1896 |
} |
|
| 1897 | ||
| 1898 |
# second, ORDERED variables |
|
| 1899 | ! |
for (v in ord.idx) {
|
| 1900 | ! |
th.y <- TH[th.idx == v] |
| 1901 | ! |
TH.Y <- c(-Inf, th.y, Inf) |
| 1902 | ! |
ncat <- length(th.y) + 1L |
| 1903 | ! |
fy <- numeric(ncat) |
| 1904 | ! |
theta.v <- sqrt(theta.var[v]) |
| 1905 | ! |
yhat.v <- yhat[, v] |
| 1906 | ||
| 1907 |
# two cases: yhat.v is a scalar, or has length = nobs |
|
| 1908 | ! |
fy <- matrix(0, nrow = length(yhat.v), ncol = ncat) |
| 1909 | ||
| 1910 |
# for each category |
|
| 1911 | ! |
for (k in seq_len(ncat)) {
|
| 1912 | ! |
if (link == "probit") {
|
| 1913 | ! |
fy[, k] <- pnorm((TH.Y[k + 1] - yhat.v) / theta.v) - |
| 1914 | ! |
pnorm((TH.Y[k] - yhat.v) / theta.v) |
| 1915 | ! |
} else if (link == "logit") {
|
| 1916 | ! |
fy[, k] <- plogis((TH.Y[k + 1] - yhat.v) / theta.v) - |
| 1917 | ! |
plogis((TH.Y[k] - yhat.v) / theta.v) |
| 1918 |
} else {
|
|
| 1919 | ! |
lav_msg_stop(gettext("link must be probit or logit"))
|
| 1920 |
} |
|
| 1921 |
} |
|
| 1922 | ||
| 1923 |
# underflow |
|
| 1924 | ! |
idx <- which(fy < .Machine$double.eps) |
| 1925 | ! |
if (length(idx) > 0L) {
|
| 1926 | ! |
fy[idx] <- .Machine$double.eps |
| 1927 |
} |
|
| 1928 | ||
| 1929 |
# log? |
|
| 1930 | ! |
if (log.) {
|
| 1931 | ! |
fy <- log(fy) |
| 1932 |
} |
|
| 1933 | ||
| 1934 |
# case-wise expansion/selection |
|
| 1935 | ! |
if (length(yhat.v) == 1L) {
|
| 1936 |
# expand category probabilities for all observations |
|
| 1937 | ! |
FY.group[, v] <- fy[1L, X[, v]] |
| 1938 |
} else {
|
|
| 1939 |
# select correct category probability per observation |
|
| 1940 | ! |
FY.group[, v] <- fy[cbind(seq_len(nrow(fy)), X[, v])] |
| 1941 |
} |
|
| 1942 |
} # ord |
|
| 1943 | ||
| 1944 | ! |
FY.group |
| 1945 |
} |
|
| 1946 | ||
| 1947 | ||
| 1948 | ||
| 1949 |
# conditional density y -- assuming independence!! |
|
| 1950 |
# f(y_i | eta_i, x_i) |
|
| 1951 |
# |
|
| 1952 |
# but for a SINGLE observation y_i (and x_i), for given values of eta_i |
|
| 1953 |
# |
|
| 1954 |
lav_predict_fy_eta.i <- function(lavmodel = NULL, lavdata = NULL, |
|
| 1955 |
lavsamplestats = NULL, |
|
| 1956 |
y.i = NULL, x.i = NULL, |
|
| 1957 |
eta.i = NULL, theta.sd = NULL, g = 1L, |
|
| 1958 |
th = NULL, th.idx = NULL, log = TRUE) {
|
|
| 1959 | ! |
mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0, lavmodel@nmat))[g] |
| 1960 | ! |
MLIST <- lavmodel@GLIST[mm.in.group] |
| 1961 | ||
| 1962 |
# linear predictor for all items |
|
| 1963 | ! |
YHAT <- |
| 1964 | ! |
lav_lisrel_eyetax( |
| 1965 | ! |
MLIST = MLIST, |
| 1966 | ! |
eXo = x.i, |
| 1967 | ! |
ETA = eta.i, |
| 1968 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 1969 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 1970 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 1971 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 1972 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 1973 | ! |
delta = FALSE |
| 1974 |
) |
|
| 1975 | ||
| 1976 |
# P(y_i | eta_i, x_i) for all items |
|
| 1977 | ! |
if (all(lavdata@ov$type == "numeric")) {
|
| 1978 |
# NORMAL case |
|
| 1979 | ! |
FY <- dnorm(y.i, mean = YHAT, sd = theta.sd, log = log) |
| 1980 |
} else {
|
|
| 1981 | ! |
FY <- numeric(lavmodel@nvar[g]) |
| 1982 | ! |
for (v in seq_len(lavmodel@nvar[g])) {
|
| 1983 | ! |
if (lavdata@ov$type[v] == "numeric") {
|
| 1984 |
### FIXME!!! we can do all numeric vars at once!! |
|
| 1985 | ! |
FY[v] <- dnorm(y.i[v], |
| 1986 | ! |
mean = YHAT[v], sd = theta.sd[v], |
| 1987 | ! |
log = log |
| 1988 |
) |
|
| 1989 | ! |
} else if (lavdata@ov$type[v] == "ordered") {
|
| 1990 |
# handle missing value |
|
| 1991 | ! |
if (is.na(y.i[v])) {
|
| 1992 | ! |
FY[v] <- as.numeric(NA) |
| 1993 |
} else {
|
|
| 1994 | ! |
th.y <- th[th.idx == v] |
| 1995 | ! |
TH.Y <- c(-Inf, th.y, Inf) |
| 1996 | ! |
k <- y.i[v] |
| 1997 | ! |
p1 <- pnorm((TH.Y[k + 1] - YHAT[v]) / theta.sd[v]) |
| 1998 | ! |
p2 <- pnorm((TH.Y[k] - YHAT[v]) / theta.sd[v]) |
| 1999 | ! |
prob <- (p1 - p2) |
| 2000 | ! |
if (prob < .Machine$double.eps) {
|
| 2001 | ! |
prob <- .Machine$double.eps |
| 2002 |
} |
|
| 2003 | ! |
if (log) {
|
| 2004 | ! |
FY[v] <- log(prob) |
| 2005 |
} else {
|
|
| 2006 | ! |
FY[v] <- prob |
| 2007 |
} |
|
| 2008 |
} |
|
| 2009 |
} else {
|
|
| 2010 | ! |
lav_msg_stop(gettextf("unknown type: `%1$s' for variable: %2$s",
|
| 2011 | ! |
lavdata@ov$type[v], lavdata@ov$name[v]) |
| 2012 |
) |
|
| 2013 |
} |
|
| 2014 |
} |
|
| 2015 |
} |
|
| 2016 | ||
| 2017 | ! |
FY |
| 2018 |
} |
|
| 2019 | ||
| 2020 |
# compute `transformation' matrix to convert regression factor scores |
|
| 2021 |
# to (Green's) correlation-preserving factor scores |
|
| 2022 |
lav_predict_tmat_green <- function(lavobject = NULL, |
|
| 2023 |
lavmodel = NULL, lavimplied = NULL) {
|
|
| 2024 | ||
| 2025 | ! |
if (!is.null(lavobject)) {
|
| 2026 | ! |
lavmodel <- lavobject@Model |
| 2027 | ! |
lavimplied <- lavobject@implied |
| 2028 |
} |
|
| 2029 | ||
| 2030 | ! |
if (is.null(lavimplied) || length(lavimplied) == 0L) {
|
| 2031 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 2032 |
} |
|
| 2033 | ! |
if (lavmodel@conditional.x) {
|
| 2034 | ! |
lavimplied <- lav_model_implied_cond2uncond(lavimplied) |
| 2035 |
} |
|
| 2036 | ! |
Sigma <- lavimplied$cov |
| 2037 | ! |
VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = FALSE) |
| 2038 | ! |
LAMBDA <- lav_model_lambda(lavmodel, remove.dummy.lv = FALSE) |
| 2039 | ||
| 2040 | ! |
nblocks <- lavmodel@nblocks |
| 2041 | ! |
tmat <- vector("list", length = nblocks)
|
| 2042 | ||
| 2043 |
# compute tmat per block |
|
| 2044 | ! |
for(b in seq_len(nblocks)) {
|
| 2045 | ! |
Sigma.b <- Sigma[[b]] |
| 2046 | ! |
Sigma.b.inv <- solve(Sigma.b) |
| 2047 | ! |
Veta <- VETA[[b]] |
| 2048 | ! |
Veta.sqrt <- lav_matrix_symmetric_sqrt(Veta) |
| 2049 | ! |
Veta32 <- Veta %*% Veta.sqrt |
| 2050 | ! |
Lambda <- LAMBDA[[b]] |
| 2051 | ! |
tmp <- Veta32 %*% t(Lambda) %*% Sigma.b.inv %*% Lambda %*% Veta32 |
| 2052 | ! |
tmp.inv.sqrt <- lav_matrix_symmetric_sqrt(solve(tmp)) |
| 2053 | ! |
tmat[[b]] <- Veta.sqrt %*% tmp.inv.sqrt %*% Veta.sqrt |
| 2054 |
} |
|
| 2055 | ||
| 2056 | ! |
tmat |
| 2057 |
} |
|
| 2058 | ||
| 2059 |
# compute `transformation' matrix to convert Bartlett factor scores |
|
| 2060 |
# to (Krijnen/McDonald) correlation-preserving factor scores |
|
| 2061 |
lav_predict_tmat_det <- function(lavobject = NULL, |
|
| 2062 |
lavmodel = NULL, lavimplied = NULL) {
|
|
| 2063 | ||
| 2064 | ! |
if (!is.null(lavobject)) {
|
| 2065 | ! |
lavmodel <- lavobject@Model |
| 2066 | ! |
lavimplied <- lavobject@implied |
| 2067 |
} |
|
| 2068 | ||
| 2069 | ! |
if (is.null(lavimplied) || length(lavimplied) == 0L) {
|
| 2070 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 2071 |
} |
|
| 2072 | ! |
if (lavmodel@conditional.x) {
|
| 2073 | ! |
lavimplied <- lav_model_implied_cond2uncond(lavimplied) |
| 2074 |
} |
|
| 2075 | ! |
Sigma <- lavimplied$cov |
| 2076 | ! |
VETA <- lav_model_veta(lavmodel = lavmodel, remove.dummy.lv = FALSE) |
| 2077 | ! |
LAMBDA <- lav_model_lambda(lavmodel, remove.dummy.lv = FALSE) |
| 2078 | ||
| 2079 | ! |
nblocks <- lavmodel@nblocks |
| 2080 | ! |
tmat <- vector("list", length = nblocks)
|
| 2081 | ||
| 2082 |
# compute tmat per block |
|
| 2083 | ! |
for(b in seq_len(nblocks)) {
|
| 2084 | ! |
Sigma.b <- Sigma[[b]] |
| 2085 | ! |
Sigma.b.inv <- solve(Sigma.b) |
| 2086 | ! |
Veta <- VETA[[b]] |
| 2087 | ! |
Veta.sqrt <- lav_matrix_symmetric_sqrt(Veta) |
| 2088 | ! |
Veta.inv.sqrt <- lav_matrix_symmetric_sqrt(solve(Veta)) |
| 2089 | ! |
Lambda <- LAMBDA[[b]] |
| 2090 | ! |
tmp <- Veta.sqrt %*% t(Lambda) %*% Sigma.b.inv %*% Lambda %*% Veta.sqrt |
| 2091 | ! |
tmp.sqrt <- lav_matrix_symmetric_sqrt(tmp) |
| 2092 | ! |
tmat[[b]] <- Veta.sqrt %*% tmp.sqrt %*% Veta.inv.sqrt |
| 2093 |
} |
|
| 2094 | ||
| 2095 | ! |
tmat |
| 2096 |
} |
|
| 2097 | ||
| 2098 |
# single block only, for internal use in lav_sam_step1_local() |
|
| 2099 |
lav_predict_tmat_det_internal <- function(Sigma = NULL, Veta = NULL, |
|
| 2100 |
Lambda = NULL) {
|
|
| 2101 | ! |
Sigma.inv <- solve(Sigma) |
| 2102 | ! |
Veta.sqrt <- lav_matrix_symmetric_sqrt(Veta) |
| 2103 | ! |
Veta.inv.sqrt <- lav_matrix_symmetric_sqrt(solve(Veta)) |
| 2104 | ! |
tmp <- Veta.sqrt %*% t(Lambda) %*% Sigma.inv %*% Lambda %*% Veta.sqrt |
| 2105 | ! |
tmp.sqrt <- lav_matrix_symmetric_sqrt(tmp) |
| 2106 | ! |
tmat <- Veta.sqrt %*% tmp.sqrt %*% Veta.inv.sqrt |
| 2107 | ! |
tmat |
| 2108 |
} |
|
| 2109 |
| 1 |
# SAM: a Structural After Measurement approach |
|
| 2 |
# |
|
| 3 |
# Yves Rosseel & Wen-Wei Loh, Feb-May 2019 |
|
| 4 | ||
| 5 |
# local vs global sam |
|
| 6 |
# local sam = alternative for FSR+Croon |
|
| 7 |
# - but no need to compute factor scores or corrections |
|
| 8 |
# global sam = (old) twostep |
|
| 9 |
# - but we can also take a 'local' perspective |
|
| 10 | ||
| 11 |
# restrictions: |
|
| 12 |
# |
|
| 13 |
# local and global: |
|
| 14 |
# - all (measured) latent variables must have indicators that are observed |
|
| 15 |
# update: higher-order measurement models are supported in local SAM (0.6-20) |
|
| 16 |
# local: |
|
| 17 |
# - only if LAMBDA is of full column rank (eg no SRM, no bi-factor, no MTMM) |
|
| 18 |
# - if multiple groups: each group has the same set of latent variables! |
|
| 19 |
# - global approach is used to compute corrected two-step standard errors |
|
| 20 |
# update: se = "local" is truely local, and uses 'Gamma' as an additional |
|
| 21 |
# ingredient; Gamma reflects the sampling variability of the |
|
| 22 |
# sample statistics (VETA and EETA) |
|
| 23 | ||
| 24 |
# YR 12 May 2019 - first version |
|
| 25 |
# YR 22 May 2019 - merge sam/twostep (call it 'local' vs 'global' sam) |
|
| 26 | ||
| 27 |
# YR 27 June 2021 - prepare for `public' release |
|
| 28 |
# - add Fuller (1987) 'lambda' correction if (MSM - MTM) is not |
|
| 29 |
# positive definite |
|
| 30 |
# - se = "none" now works |
|
| 31 |
# - store 'local' information in @internal slot (for printing) |
|
| 32 | ||
| 33 |
# YR 16 Oct 2021 - if an indicator is also a predictor/outcome in the |
|
| 34 |
# structural part, treat it as an observed predictor |
|
| 35 |
# without measurement error in the second step |
|
| 36 |
# (ie, set THETA element to zero) |
|
| 37 | ||
| 38 |
# YR 03 Dec 2022 - allow for sam.method = "fsr" and se = "naive" |
|
| 39 |
# - add alpha.correction= argument (for small sample correction) |
|
| 40 | ||
| 41 |
# YR 21 May 2023 - allow for latent quadratic/interaction terms in the |
|
| 42 |
# structural part (assuming the errors are normal, for now) |
|
| 43 | ||
| 44 |
# YR 25 May 2023 - restructure code into multiple files |
|
| 45 |
# - rename veta.force.pd -> lambda.correction |
|
| 46 |
# - move alpha.correction= argument to local.options |
|
| 47 | ||
| 48 |
# YR 09 Nov 2024 - add se = "bootstrap" |
|
| 49 |
# YR 14 Nov 2024 - add se = "local" |
|
| 50 |
# YR 01 Mar 2025 - allow for higher-order measurement models in local SAM |
|
| 51 |
# YR 25 Mar 2025 - add sam.method = "cFSR" (using correlation-preserving FS) |
|
| 52 |
# YR 15 Apr 2025 - add se = "twostep.robust" |
|
| 53 | ||
| 54 |
# twostep = wrapper for global sam |
|
| 55 |
twostep <- function(model = NULL, data = NULL, cmd = "sem", |
|
| 56 |
mm.list = NULL, mm.args = list(), struc.args = list(), |
|
| 57 |
..., # global options |
|
| 58 |
output = "lavaan") {
|
|
| 59 | ! |
sam( |
| 60 | ! |
model = model, data = data, cmd = cmd, mm.list = mm.list, |
| 61 | ! |
mm.args = mm.args, struc.args = struc.args, |
| 62 | ! |
sam.method = "global", # or global |
| 63 | ! |
..., # global options |
| 64 | ! |
output = output |
| 65 |
) |
|
| 66 |
} |
|
| 67 | ||
| 68 |
# fsr = wrapper for local sam |
|
| 69 |
# TODO |
|
| 70 | ||
| 71 | ||
| 72 |
sam <- function(model = NULL, |
|
| 73 |
data = NULL, |
|
| 74 |
cmd = "sem", |
|
| 75 |
se = "twostep", |
|
| 76 |
mm.list = NULL, |
|
| 77 |
mm.args = list(bounds = "wide.zerovar"), |
|
| 78 |
struc.args = list(estimator = "ML"), |
|
| 79 |
sam.method = "local", # or "global", or "fsr", or "cfsr" |
|
| 80 |
..., # common options |
|
| 81 |
local.options = list( |
|
| 82 |
M.method = "ML", # mapping matrix |
|
| 83 |
lambda.correction = TRUE, |
|
| 84 |
alpha.correction = 0L, # 0 -> (N-1) |
|
| 85 |
twolevel.method = "h1" |
|
| 86 |
), |
|
| 87 |
# h1, anova, mean |
|
| 88 |
global.options = list(), # not used for now |
|
| 89 |
bootstrap = list(R = 1000L, type = "ordinary", |
|
| 90 |
show.progress = FALSE), |
|
| 91 |
output = "lavaan", |
|
| 92 |
bootstrap.args = bootstrap) {
|
|
| 93 |
# "bootstrap" is the new way to specify arguments, replacing bootstrap.args |
|
| 94 | ! |
if (!missing(bootstrap.args)) {
|
| 95 | ! |
lav_msg_warn(gettext( |
| 96 | ! |
"'bootstrap.args' is deprecated; please use 'bootstrap' instead.")) |
| 97 | ! |
bootstrap <- bootstrap.args |
| 98 |
} |
|
| 99 | ||
| 100 |
# check model= argument |
|
| 101 | ! |
has.sam.object.flag <- FALSE |
| 102 | ! |
if (inherits(model, "lavaan") && !is.null(model@internal$sam.method)) {
|
| 103 | ! |
has.sam.object.flag <- TRUE |
| 104 |
} |
|
| 105 | ||
| 106 |
# check sam.method |
|
| 107 | ! |
sam.method <- tolower(sam.method) |
| 108 | ! |
if (!sam.method %in% c("local", "global", "fsr", "cfsr")) {
|
| 109 | ! |
lav_msg_stop(gettextf("unknown option for sam.method: [%s]",
|
| 110 | ! |
"available options are local, global, fsr and cfs.")) |
| 111 |
} |
|
| 112 | ||
| 113 |
# ------------- handling of warn/debug/verbose switches ---------- |
|
| 114 | ! |
dotdotdot <- list(...) |
| 115 | ! |
if( length(dotdotdot) > 0L) {
|
| 116 | ! |
if (!is.null(dotdotdot$debug)) {
|
| 117 | ! |
current.debug <- lav_debug() |
| 118 | ! |
if (lav_debug(dotdotdot$debug)) |
| 119 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 120 | ! |
dotdotdot$debug <- NULL |
| 121 | ! |
if (lav_debug()) {
|
| 122 | ! |
dotdotdot$warn <- TRUE # force warnings if debug |
| 123 | ! |
dotdotdot$verbose <- TRUE # force verbose if debug |
| 124 |
} |
|
| 125 |
} |
|
| 126 | ! |
if (!is.null(dotdotdot$warn)) {
|
| 127 | ! |
current.warn <- lav_warn() |
| 128 | ! |
if (lav_warn(dotdotdot$warn)) |
| 129 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 130 | ! |
dotdotdot$warn <- NULL |
| 131 |
} |
|
| 132 | ! |
if (!is.null(dotdotdot$verbose)) {
|
| 133 | ! |
current.verbose <- lav_verbose() |
| 134 | ! |
if (lav_verbose(dotdotdot$verbose)) |
| 135 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 136 | ! |
dotdotdot$verbose <- NULL |
| 137 |
} |
|
| 138 |
# check for conditional.x= argument |
|
| 139 |
# if (!sam.method == "global" && !is.null(dotdotdot$conditional.x) && |
|
| 140 |
# dotdotdot$conditional.x) {
|
|
| 141 |
# lav_msg_warn(gettext( |
|
| 142 |
# "local sam() does not support conditional.x = TRUE (yet) -> switching to |
|
| 143 |
# conditional.x = FALSE")) |
|
| 144 |
# dotdotdot$conditional.x <- FALSE |
|
| 145 |
# } |
|
| 146 |
# check for orthogonal= argument |
|
| 147 | ! |
if (!is.null(dotdotdot$orthogonal) && |
| 148 | ! |
dotdotdot$orthogonal && |
| 149 | ! |
sam.method != "global") {
|
| 150 | ! |
lav_msg_warn(gettext( |
| 151 | ! |
"local sam does not support orthogonal = TRUE -> switching to |
| 152 | ! |
global sam")) |
| 153 | ! |
sam.method <- "global" |
| 154 |
} |
|
| 155 |
} # length(dotdotdot) > 0L |
|
| 156 | ||
| 157 |
# check output= argument |
|
| 158 | ! |
output <- tolower(output) |
| 159 | ! |
if (output %in% c("list", "list.step1.only", "lavaan")) {
|
| 160 |
# nothing to do |
|
| 161 |
} else {
|
|
| 162 | ! |
lav_msg_stop(gettext("output should be \"list\" or \"lavaan.\""))
|
| 163 |
} |
|
| 164 | ||
| 165 |
# |
|
| 166 | ||
| 167 |
# check se= argument |
|
| 168 | ! |
if (!missing(se)) {
|
| 169 | ! |
se <- tolower(se) |
| 170 |
# aliases |
|
| 171 | ! |
if (se %in% c("two-step", "two_step", "two.step")) {
|
| 172 | ! |
se <- "twostep" |
| 173 | ! |
} else if(se %in% c("two-step-robust", "two-step.robust",
|
| 174 | ! |
"two_step_robust", "two.step.robust", |
| 175 | ! |
"twostep.robust")) {
|
| 176 | ! |
se <- "twostep.robust" |
| 177 |
} |
|
| 178 | ! |
else if (se %in% c("ij", "local")) {
|
| 179 | ! |
se <- "local" |
| 180 |
} |
|
| 181 |
# check if valid |
|
| 182 | ! |
if (!se %in% c("standard", "naive", "twostep", "local", "local.nt",
|
| 183 | ! |
"twostep.robust", "bootstrap", "none")) {
|
| 184 | ! |
lav_msg_stop(gettext( |
| 185 | ! |
"se= argument must be twostep, twostep.robust, bootstrap, or local")) |
| 186 |
} |
|
| 187 |
# check for local |
|
| 188 | ! |
if (se %in% c("local", "local.nt")) {
|
| 189 | ! |
if (!sam.method %in% c("local", "fsr", "cfsr")) { # for now
|
| 190 | ! |
lav_msg_stop(gettext("local se only available if sam.method is local, fsr, or cfsr"))
|
| 191 |
} |
|
| 192 |
} |
|
| 193 |
} |
|
| 194 |
# default is twostep |
|
| 195 | ||
| 196 |
# check for gamma.unbiased |
|
| 197 | ! |
if (is.null(dotdotdot$gamma.unbiased)) {
|
| 198 |
# put in TRUE in dotdotdot # lavaan default is still FALSE |
|
| 199 | ! |
dotdotdot$gamma.unbiased <- TRUE |
| 200 |
} |
|
| 201 | ||
| 202 | ||
| 203 |
############################################### |
|
| 204 |
# STEP 0: process full model, without fitting # |
|
| 205 |
############################################### |
|
| 206 | ! |
if (has.sam.object.flag) {
|
| 207 | ! |
FIT <- model |
| 208 |
# restore options |
|
| 209 | ! |
FIT@Options <- FIT@internal$sam.lavoptions |
| 210 |
# extract other argments from FIT@internal, unless specified as arguments |
|
| 211 | ! |
if (missing(mm.list)){
|
| 212 | ! |
mm.list <- FIT@internal$sam.mm.list |
| 213 |
} |
|
| 214 | ! |
if (missing(mm.args)){
|
| 215 | ! |
mm.args <- FIT@internal$sam.mm.args |
| 216 |
} |
|
| 217 | ! |
if (missing(struc.args)) {
|
| 218 | ! |
struc.args <- FIT@internal$sam.struc.args |
| 219 |
} |
|
| 220 | ! |
if (missing(sam.method)) {
|
| 221 | ! |
sam.method <- FIT@internal$sam.method |
| 222 |
} |
|
| 223 | ! |
if (missing(local.options)) {
|
| 224 | ! |
local.options <- FIT@internal$sam.local.options |
| 225 |
} |
|
| 226 | ! |
if (missing(global.options)) {
|
| 227 | ! |
global.options <- FIT@internal$sam.global.options |
| 228 |
} |
|
| 229 | ! |
if (missing(se)) {
|
| 230 | ! |
se <- FIT@Options$se |
| 231 |
} else {
|
|
| 232 | ! |
FIT@Options$se <- se |
| 233 |
} |
|
| 234 | ! |
if (missing(cmd)) {
|
| 235 | ! |
cmd <- FIT@internal$sam.cmd |
| 236 |
} |
|
| 237 |
# remove @internal slot |
|
| 238 | ! |
FIT@internal <- list() |
| 239 |
} else {
|
|
| 240 | ! |
FIT <- lav_sam_step0( |
| 241 | ! |
cmd = cmd, model = model, data = data, se = se, |
| 242 | ! |
sam.method = sam.method, dotdotdot = dotdotdot |
| 243 |
) |
|
| 244 | ||
| 245 |
# check for data.type == "none" |
|
| 246 | ! |
if (FIT@Data@data.type == "none") {
|
| 247 |
# we are done; perhaps we only wished to create a FIT object? |
|
| 248 | ! |
return(FIT) |
| 249 |
#lav_msg_stop(gettext("no data or sample statistics are provided."))
|
|
| 250 |
} |
|
| 251 | ||
| 252 |
# check if we have categorical data |
|
| 253 | ! |
if (FIT@Model@categorical) {
|
| 254 |
# switch to M.method = "ULS" |
|
| 255 | ! |
local.options[["M.method"]] <- "ULS" |
| 256 |
# if sam.method = "global", force estimator to DWLS in struc par |
|
| 257 | ! |
if (sam.method == "global" && |
| 258 | ! |
!is.null(struc.args[["estimator"]]) && |
| 259 | ! |
struc.args[["estimator"]] == "ML") {
|
| 260 | ! |
struc.args[["estimator"]] <- "DWLS" |
| 261 |
} |
|
| 262 |
} |
|
| 263 | ||
| 264 |
# check if we have latent interactions |
|
| 265 | ! |
lv.interaction.flag <- FALSE |
| 266 | ! |
if (length(unlist(FIT@pta$vnames$lv.interaction)) > 0L) {
|
| 267 | ! |
lv.interaction.flag <- TRUE |
| 268 | ! |
if (!se %in% c("none", "bootstrap")) {
|
| 269 | ! |
se <- "local" |
| 270 | ! |
FIT@Options$se <- se |
| 271 |
} |
|
| 272 |
} |
|
| 273 | ||
| 274 |
# check for multiple groups/blocks |
|
| 275 | ! |
if (FIT@Model@nblocks > 1L && se == "local") {
|
| 276 | ! |
lav_msg_stop(gettext("se = \"local\" not available (yet) if multiple
|
| 277 | ! |
blocks (groups, levels) are involved.")) |
| 278 |
} |
|
| 279 |
} |
|
| 280 | ||
| 281 | ! |
lavoptions <- lavInspect(FIT, "options") |
| 282 | ! |
if (lav_verbose()) {
|
| 283 | ! |
cat("This is sam using sam.method = ", sam.method, ".\n", sep = "")
|
| 284 |
} |
|
| 285 | ||
| 286 |
############################################## |
|
| 287 |
# STEP 1: fit each measurement model (block) # |
|
| 288 |
############################################## |
|
| 289 | ! |
if (lav_verbose()) {
|
| 290 | ! |
cat("Fitting the measurement part:\n")
|
| 291 |
} |
|
| 292 | ! |
STEP1 <- lav_sam_step1( |
| 293 | ! |
cmd = cmd, mm.list = mm.list, mm.args = mm.args, |
| 294 | ! |
FIT = FIT, sam.method = sam.method |
| 295 |
) |
|
| 296 | ||
| 297 |
################################################## |
|
| 298 |
# STEP 1b: compute Var(eta) and E(eta) per block # |
|
| 299 |
# only needed for local approach! # |
|
| 300 |
################################################## |
|
| 301 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 302 |
# default local.options |
|
| 303 | ! |
local.opt <- list( |
| 304 | ! |
M.method = "ML", |
| 305 | ! |
lambda.correction = TRUE, |
| 306 | ! |
alpha.correction = 0L, |
| 307 | ! |
twolevel.method = "h1" |
| 308 |
) |
|
| 309 | ! |
local.options <- modifyList(local.opt, local.options, |
| 310 | ! |
keep.null = FALSE |
| 311 |
) |
|
| 312 | ||
| 313 |
# collect COV/YBAR sample statistics per block from FIT |
|
| 314 | ! |
out <- lav_sam_get_cov_ybar(FIT = FIT, local.options = local.options) |
| 315 | ! |
STEP1$COV <- out$COV |
| 316 | ! |
STEP1$YBAR <- out$YBAR |
| 317 | ||
| 318 |
# compute EETA/VETA |
|
| 319 | ! |
STEP1 <- lav_sam_step1_local( |
| 320 | ! |
STEP1 = STEP1, FIT = FIT, |
| 321 | ! |
sam.method = sam.method, |
| 322 | ! |
local.options = local.options, |
| 323 | ! |
return.cov.iveta2 = (se %in% c("local", "local.nt"))
|
| 324 |
) |
|
| 325 |
} |
|
| 326 | ||
| 327 |
################################################## |
|
| 328 |
# STEP 1c: jacobian of vech(VETA) = f(vech(S)) # |
|
| 329 |
# only needed for local approach! # |
|
| 330 |
# only if se = "local" # |
|
| 331 |
################################################## |
|
| 332 | ! |
if (se %in% c("local", "local.nt")) {
|
| 333 | ! |
Gamma.eta <- vector("list", length = FIT@Data@ngroups)
|
| 334 | ! |
if (lv.interaction.flag) {
|
| 335 | ! |
for (g in seq_len(FIT@Data@ngroups)) { # group or block
|
| 336 |
# initial Gamma.eta |
|
| 337 | ! |
Gamma.eta.init <- STEP1$COV.IVETA2[[g]] |
| 338 |
# compute 'additional variability' due to step1 |
|
| 339 | ! |
Gamma.eta.add <- lav_sam_gamma_add(STEP1 = STEP1, FIT = FIT, group = g) |
| 340 | ! |
Gamma.eta[[g]] <- Gamma.eta.init + Gamma.eta.add |
| 341 |
} |
|
| 342 |
} else {
|
|
| 343 | ! |
JAC <- lav_sam_step1_local_jac(STEP1 = STEP1, FIT = FIT) |
| 344 | ! |
if (se == "local") {
|
| 345 | ! |
Gamma <- FIT@SampleStats@NACOV |
| 346 | ! |
} else if (se == "local.nt") {
|
| 347 | ! |
Gamma <- lav_object_gamma(lavobject = FIT, ADF = FALSE) |
| 348 |
} |
|
| 349 | ||
| 350 | ! |
for (g in seq_len(FIT@Data@ngroups)) {
|
| 351 | ! |
Gamma.eta[[g]] <- JAC[[g]] %*% Gamma[[g]] %*% t(JAC[[g]]) |
| 352 |
} |
|
| 353 | ! |
STEP1$JAC <- JAC |
| 354 |
} # no lv-interaction |
|
| 355 | ! |
STEP1$Gamma.eta <- Gamma.eta |
| 356 |
} |
|
| 357 | ||
| 358 | ! |
if (output == "list.step1.only") {
|
| 359 |
# stop here, return interim results |
|
| 360 | ! |
return(STEP1) |
| 361 |
} |
|
| 362 | ||
| 363 |
#################################### |
|
| 364 |
# STEP 2: estimate structural part # |
|
| 365 |
#################################### |
|
| 366 | ||
| 367 | ! |
STEP2 <- lav_sam_step2( |
| 368 | ! |
STEP1 = STEP1, FIT = FIT, |
| 369 | ! |
sam.method = sam.method, struc.args = struc.args |
| 370 |
) |
|
| 371 | ||
| 372 |
# make sure step1.free.idx and step2.free.idx are disjoint |
|
| 373 | ! |
both.idx <- which(STEP1$step1.free.idx %in% STEP2$step2.free.idx) |
| 374 | ! |
if (length(both.idx) > 0L) {
|
| 375 | ! |
STEP1$step1.free.idx <- STEP1$step1.free.idx[-both.idx] |
| 376 |
# STEP1$Sigma.11[both.idx,] <- 0 |
|
| 377 |
# STEP1$Sigma.11[,both.idx] <- 0 |
|
| 378 | ! |
if (!is.null(STEP1$Sigma.11)) { # maybe se = "none"...
|
| 379 | ! |
STEP1$Sigma.11 <- STEP1$Sigma.11[-both.idx, -both.idx] |
| 380 |
} |
|
| 381 |
} |
|
| 382 | ||
| 383 | ! |
if (output == "list" && lavoptions$se == "none") {
|
| 384 | ! |
return(c(STEP1, STEP2)) |
| 385 |
} |
|
| 386 | ||
| 387 |
################################################################ |
|
| 388 |
# Step 3: assemble results in a 'dummy' JOINT model for output # |
|
| 389 |
################################################################ |
|
| 390 | ! |
if (lav_verbose()) {
|
| 391 | ! |
cat("Creating JOINT lavaan object ... ")
|
| 392 |
} |
|
| 393 | ! |
JOINT <- lav_sam_step3_joint( |
| 394 | ! |
FIT = FIT, PT = STEP2$PT, |
| 395 | ! |
sam.method = sam.method |
| 396 |
) |
|
| 397 |
# fill information from FIT.PA |
|
| 398 | ! |
JOINT@Options$optim.method <- STEP2$FIT.PA@Options$optim.method |
| 399 | ! |
JOINT@Model@estimator <- FIT@Options$estimator # could be DWLS! |
| 400 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 401 | ! |
JOINT@optim <- STEP2$FIT.PA@optim |
| 402 | ! |
JOINT@test <- STEP2$FIT.PA@test |
| 403 |
} |
|
| 404 |
# fill in vcov/se information from step 1 |
|
| 405 | ! |
if (!lavoptions$se %in% c("none", "bootstrap")) {
|
| 406 | ! |
JOINT@Options$se <- lavoptions$se # naive/twostep/none/local/bootstrap |
| 407 | ! |
if (JOINT@Model@ceq.simple.only) {
|
| 408 | ! |
VCOV.ALL <- matrix( |
| 409 | ! |
0, JOINT@Model@nx.unco, |
| 410 | ! |
JOINT@Model@nx.unco |
| 411 |
) |
|
| 412 |
} else {
|
|
| 413 | ! |
VCOV.ALL <- matrix( |
| 414 | ! |
0, JOINT@Model@nx.free, |
| 415 | ! |
JOINT@Model@nx.free |
| 416 |
) |
|
| 417 |
} |
|
| 418 | ! |
VCOV.ALL[STEP1$step1.free.idx, STEP1$step1.free.idx] <- STEP1$Sigma.11 |
| 419 | ! |
JOINT@vcov <- list( |
| 420 | ! |
se = lavoptions$se, |
| 421 | ! |
information = lavoptions$information[1], |
| 422 | ! |
vcov = VCOV.ALL |
| 423 |
) |
|
| 424 |
# no need to fill @ParTable$se, as step1 SE values should already |
|
| 425 |
# be in place |
|
| 426 |
} |
|
| 427 | ||
| 428 | ! |
if (lav_verbose()) {
|
| 429 | ! |
cat("done.\n")
|
| 430 |
} |
|
| 431 | ||
| 432 |
############################################## |
|
| 433 |
# Step 4: compute standard errors for step 2 # |
|
| 434 |
############################################## |
|
| 435 | ||
| 436 | ! |
if (lavoptions$se == "bootstrap") {
|
| 437 | ! |
if (lav_verbose()) {
|
| 438 | ! |
cat("computing VCOV for se = bootstrap ...")
|
| 439 |
} |
|
| 440 |
# construct temporary sam object, so that lav_bootstrap_internal() can |
|
| 441 |
# use it |
|
| 442 | ! |
SAM <- lav_sam_table( |
| 443 | ! |
JOINT = JOINT, STEP1 = STEP1, |
| 444 | ! |
FIT.PA = STEP2$FIT.PA, |
| 445 | ! |
cmd = cmd, lavoptions = FIT@Options, |
| 446 | ! |
mm.args = mm.args, |
| 447 | ! |
struc.args = struc.args, |
| 448 | ! |
sam.method = sam.method, |
| 449 | ! |
local.options = local.options, |
| 450 | ! |
global.options = global.options |
| 451 |
) |
|
| 452 | ! |
sam_object <- JOINT |
| 453 | ! |
sam_object@internal <- SAM |
| 454 | ! |
default.args <- list(R = 1000L, type = "ordinary", |
| 455 | ! |
show.progress = FALSE, |
| 456 | ! |
check.post = TRUE, keep.idx = FALSE) |
| 457 | ! |
this.args <- modifyList(default.args, bootstrap) |
| 458 | ! |
COEF <- lav_bootstrap_internal(object = sam_object, |
| 459 | ! |
R = this.args$R, show.progress = this.args$show.progress, |
| 460 | ! |
type = this.args$type, FUN = "coef", |
| 461 | ! |
check.post = this.args$check.post, keep.idx = this.args$keep.idx) |
| 462 | ! |
COEF.orig <- COEF |
| 463 | ! |
error.idx <- attr(COEF, "error.idx") |
| 464 | ! |
nfailed <- length(error.idx) # zero if NULL |
| 465 | ! |
if (nfailed > 0L) {
|
| 466 | ! |
lav_msg_warn(gettextf( |
| 467 | ! |
"%s bootstrap runs failed or did not converge.", nfailed)) |
| 468 |
} |
|
| 469 | ! |
notok <- length(attr(COEF, "nonadmissible")) # zero if NULL |
| 470 | ! |
if (notok > 0L) {
|
| 471 | ! |
lav_msg_warn(gettextf( |
| 472 | ! |
"%s bootstrap runs resulted in nonadmissible solutions.", notok)) |
| 473 |
} |
|
| 474 | ! |
if (length(error.idx) > 0L) {
|
| 475 |
# new in 0.6-13: we must still remove them! |
|
| 476 | ! |
COEF <- COEF[-error.idx, , drop = FALSE] |
| 477 |
# this also drops the attributes |
|
| 478 |
} |
|
| 479 | ! |
nboot <- nrow(COEF) |
| 480 | ! |
VarCov <- cov(COEF) * (nboot - 1) / nboot |
| 481 | ! |
JOINT@boot$coef <- COEF.orig |
| 482 | ! |
JOINT@Options$bootstrap <- this.args$R |
| 483 | ! |
VCOV <- list(se = "bootstrap", VCOV = VarCov) |
| 484 | ||
| 485 | ! |
if (lav_verbose()) {
|
| 486 | ! |
cat("done.\n")
|
| 487 |
} |
|
| 488 | ||
| 489 |
# analytic twostep/standard/naive/local |
|
| 490 |
} else {
|
|
| 491 | ! |
VCOV <- lav_sam_step2_se( |
| 492 | ! |
FIT = FIT, JOINT = JOINT, STEP1 = STEP1, |
| 493 | ! |
STEP2 = STEP2, local.options = local.options |
| 494 |
) |
|
| 495 |
} |
|
| 496 | ||
| 497 |
# fill in twostep standard errors |
|
| 498 | ! |
if (lavoptions$se != "none") {
|
| 499 | ! |
PT <- JOINT@ParTable |
| 500 | ! |
JOINT@Options$se <- VCOV$se |
| 501 | ! |
JOINT@vcov$se <- VCOV$se |
| 502 | ! |
if (lavoptions$se == "bootstrap") {
|
| 503 | ! |
JOINT@vcov$vcov <- VCOV$VCOV |
| 504 |
} else {
|
|
| 505 | ! |
JOINT@vcov$vcov[STEP2$step2.free.idx, STEP2$step2.free.idx] <- VCOV$VCOV |
| 506 |
} |
|
| 507 | ! |
PT$se <- lav_model_vcov_se( |
| 508 | ! |
lavmodel = JOINT@Model, |
| 509 | ! |
lavpartable = PT, |
| 510 | ! |
VCOV = JOINT@vcov$vcov |
| 511 |
) |
|
| 512 | ! |
JOINT@ParTable <- PT |
| 513 |
} |
|
| 514 | ||
| 515 | ||
| 516 | ||
| 517 |
################## |
|
| 518 |
# Step 5: Output # |
|
| 519 |
################## |
|
| 520 | ||
| 521 |
# assemble pieces to assemble final lavaan object |
|
| 522 | ! |
if (output == "lavaan") {
|
| 523 | ! |
if (lav_verbose()) {
|
| 524 | ! |
cat("Assembling results for output ... ")
|
| 525 |
} |
|
| 526 | ! |
SAM <- lav_sam_table( |
| 527 | ! |
JOINT = JOINT, STEP1 = STEP1, |
| 528 | ! |
FIT.PA = STEP2$FIT.PA, |
| 529 | ! |
cmd = cmd, lavoptions = FIT@Options, |
| 530 | ! |
mm.args = mm.args, |
| 531 | ! |
struc.args = struc.args, |
| 532 | ! |
sam.method = sam.method, |
| 533 | ! |
local.options = local.options, |
| 534 | ! |
global.options = global.options |
| 535 |
) |
|
| 536 | ! |
res <- JOINT |
| 537 | ! |
res@internal <- SAM |
| 538 | ! |
if (lav_verbose()) {
|
| 539 | ! |
cat("done.\n")
|
| 540 |
} |
|
| 541 |
} else {
|
|
| 542 | ! |
res <- c(STEP1, STEP2, VCOV) |
| 543 |
} |
|
| 544 | ||
| 545 | ! |
if (lav_verbose()) {
|
| 546 | ! |
cat("End of sam.\n")
|
| 547 |
} |
|
| 548 | ||
| 549 | ! |
res |
| 550 |
} |
| 1 |
# lav_partable_names |
|
| 2 |
# |
|
| 3 |
# YR. 29 june 2013 |
|
| 4 |
# - as separate file; used to be in utils-user.R |
|
| 5 |
# - lav_partable_names (aka 'vnames') allows multiple options in 'type' |
|
| 6 |
# returning them all as a list (or just a vector if only 1 type is needed) |
|
| 7 | ||
| 8 |
# public version |
|
| 9 |
lav_object_vnames <- function(object, type = "ov", ...) { # nolint
|
|
| 10 | 609x |
if (inherits(object, "lavaan") || inherits(object, "lavaanList")) {
|
| 11 |
# check object |
|
| 12 | 111x |
object <- lav_object_check_version(object) |
| 13 | 111x |
partable <- object@ParTable |
| 14 | 498x |
} else if (inherits(object, "list") || |
| 15 | 498x |
inherits(object, "data.frame")) {
|
| 16 | 498x |
partable <- object |
| 17 | ! |
} else if (inherits(object, "character")) {
|
| 18 |
# just a model string? |
|
| 19 | ! |
partable <- lavParseModelString(object) |
| 20 |
} |
|
| 21 | 609x |
lav_partable_vnames(partable, type = type, ...) |
| 22 |
} |
|
| 23 |
lavNames <- lav_object_vnames # synonym #nolint |
|
| 24 | ||
| 25 |
# return variable names in a partable |
|
| 26 |
# - the 'type' argument determines the status of the variable: observed, |
|
| 27 |
# latent, endo/exo/...; default = "ov", but most used is type = "all" |
|
| 28 |
# LDW 30/1/24: there is no default and most used is a single type: "all" is |
|
| 29 |
# rarely used in other code |
|
| 30 |
# - the 'group' argument either selects a single group (if group is an integer) |
|
| 31 |
# or returns a list per group |
|
| 32 |
# - the 'level' argument either selects a single level (if level is an integer) |
|
| 33 |
# or returns a list per level |
|
| 34 |
# LDW 30/1/24: 'level' argument not explicitly tested !? |
|
| 35 |
# - the 'block' argument either selects a single block (if block is an integer) |
|
| 36 |
# or returns a list per block |
|
| 37 |
# LDW 30/1/24: 'block' argument not explicitly tested !? |
|
| 38 |
# LDW 29/2/24: ov.order = "data" via attribute "ovda" |
|
| 39 |
# - YR 11/02/25: add type = "lv.ho" for higher-order latent variables |
|
| 40 |
lav_partable_vnames <- function(partable, type = NULL, ..., # nolint |
|
| 41 |
force.warn = FALSE, ov.x.fatal = FALSE) {
|
|
| 42 |
# This function derives the names of some types of variable (as specified |
|
| 43 |
# in type) from a 'partable'. The 'warn' parameter needs no explanation. |
|
| 44 |
# The ov.x.fatal parameter implies, when set to TRUE, that the function |
|
| 45 |
# issues a 'stop' when there are exogenious variables present in variance/ |
|
| 46 |
# covariance or intercept formulas. |
|
| 47 |
# The call of this function can also contain extra parameters (...) which |
|
| 48 |
# have to be the name(s) of blockvariable(s) to be used to select names. |
|
| 49 |
# If more than 1 blockvariable given, all must be satisfied to select! |
|
| 50 |
# The 'partable' must be a list with minimum members lhs, op, rhs. |
|
| 51 |
# Other members of 'partable' used (if present): block, ustart, free, exo, |
|
| 52 |
# user, efa, rv, 'blockname' |
|
| 53 |
# If the 'partable' contains an attribute vnames and the type is not "*", |
|
| 54 |
# the 'type' elements of this attribute are used. |
|
| 55 | ||
| 56 |
# ----- lav_partable_vnames ---- common ---------------------------------- |
|
| 57 |
# sanity check |
|
| 58 | 15721x |
stopifnot(is.list(partable), !missing(type)) |
| 59 |
# this is a special fuunction where the default is to suppress warnings, |
|
| 60 |
# overwritten if parameter force.warn TRUE (used in lav_partable function) |
|
| 61 | 15721x |
current.warn <- lav_warn() |
| 62 | 15721x |
if (force.warn) {
|
| 63 | ! |
if (lav_warn(TRUE)) on.exit(lav_warn(current.warn)) |
| 64 |
} else {
|
|
| 65 | 15123x |
if (lav_warn(FALSE)) on.exit(lav_warn(current.warn)) |
| 66 |
} |
|
| 67 |
# check for empty table |
|
| 68 | 15721x |
if (length(partable$lhs) == 0) {
|
| 69 | ! |
return(character(0L)) |
| 70 |
} |
|
| 71 |
# dotdotdot |
|
| 72 | 15721x |
dotdotdot <- list(...) |
| 73 | 15721x |
type.list <- c( |
| 74 | 15721x |
"ov", # observed variables (ov) |
| 75 | 15721x |
"ov.x", # (pure) exogenous observed variables |
| 76 | 15721x |
"ov.nox", # non-exogenous observed variables |
| 77 | 15721x |
"ov.model", # modeled observed variables (joint vs cond) |
| 78 | 15721x |
"ov.y", # (pure) endogenous variables (dependent only) |
| 79 | 15721x |
"ov.num", # numeric observed variables |
| 80 | 15721x |
"ov.ord", # ordinal observed variables |
| 81 | 15721x |
"ov.ind", # observed indicators of latent variables |
| 82 | 15721x |
"ov.cind", # observed indicators of composites (new in 0.6-20) |
| 83 | 15721x |
"ov.orphan", # lonely observed intercepts/variances |
| 84 | 15721x |
"ov.interaction", # interaction terms (with colon) |
| 85 | 15721x |
"ov.efa", # indicators involved in efa |
| 86 | ||
| 87 | 15721x |
"th", # thresholds ordinal only |
| 88 | 15721x |
"th.mean", # thresholds ordinal + numeric variables |
| 89 | ||
| 90 | 15721x |
"lv", # latent variables |
| 91 | 15721x |
"lv.regular", # latent variables (defined by =~ only) |
| 92 | 15721x |
"lv.formative", # latent variables (defined by <~ only) (old style) |
| 93 | 15721x |
"lv.composite", # latent variables (defined by <~ only) (new style) |
| 94 | 15721x |
"lv.x", # (pure) exogenous variables |
| 95 | 15721x |
"lv.y", # (pure) endogenous variables |
| 96 | 15721x |
"lv.nox", # non-exogenous latent variables |
| 97 | 15721x |
"lv.nonnormal", # latent variables with non-normal indicators |
| 98 | 15721x |
"lv.interaction", # interaction terms |
| 99 | 15721x |
"lv.efa", # latent variables involved in efa |
| 100 | 15721x |
"lv.rv", # random slopes, random variables |
| 101 | 15721x |
"lv.ind", # latent indicators (higher-order cfa) |
| 102 | 15721x |
"lv.ho", # higher-order latent variables |
| 103 | 15721x |
"lv.marker", # marker indicator per lv |
| 104 | ||
| 105 | 15721x |
"eqs.y", # y's in regression |
| 106 | 15721x |
"eqs.x" # x's in regression |
| 107 |
) |
|
| 108 | 15721x |
if (type[1L] != "all" && type[1L] != "*" && !all(type %in% type.list)) {
|
| 109 | ! |
wrongtypes <- type[!(type %in% type.list)] |
| 110 | ! |
lav_msg_stop(sprintf( |
| 111 | ! |
ngettext(length(wrongtypes), |
| 112 | ! |
"type = %s is not a valid option", |
| 113 | ! |
"type = %s are not valid options"), |
| 114 | ! |
lav_msg_view(wrongtypes, "none", FALSE))) |
| 115 |
} |
|
| 116 | 15721x |
return.value <- NULL |
| 117 | 15721x |
if (type[1L] != "*" && !is.null(attr(partable, "vnames"))) {
|
| 118 |
# ----- lav_partable_vnames ---- cached data -------------------------- |
|
| 119 |
# uncomment/comment following line to enable/disable trace |
|
| 120 |
# lav_trace(paste("cached:", paste(type, collapse = ",")))
|
|
| 121 | ||
| 122 | 13945x |
if (type[1L] == "all") {
|
| 123 | ! |
return.value <- attr(partable, "vnames") |
| 124 |
} else {
|
|
| 125 | 13945x |
return.value <- attr(partable, "vnames")[type] |
| 126 |
} |
|
| 127 |
} |
|
| 128 |
# ----- lav_partable_vnames ---- common ---------------------------------- |
|
| 129 | 15721x |
if (type[1L] == "all" || type[1L] == "*") {
|
| 130 | 901x |
type <- type.list |
| 131 |
} |
|
| 132 |
# ALWAYS need `block' column -- create one if missing |
|
| 133 | 15721x |
if (is.null(partable$block)) {
|
| 134 | 336x |
partable$block <- rep(1L, length(partable$lhs)) |
| 135 |
} |
|
| 136 |
# per default, use full partable |
|
| 137 | 15721x |
block.select <- lav_partable_block_values(partable) |
| 138 |
# check for ... selection argument(s) |
|
| 139 | 15721x |
ndotdotdot <- length(dotdotdot) |
| 140 | 15721x |
if (ndotdotdot > 0L) {
|
| 141 | 11854x |
dot.names <- names(dotdotdot) |
| 142 | 11854x |
row.select <- rep(TRUE, length(partable$lhs)) |
| 143 | 11854x |
for (dot in seq_len(ndotdotdot)) {
|
| 144 |
# selection variable? |
|
| 145 | 11862x |
block.var <- dot.names[dot] |
| 146 | 11862x |
block.val <- dotdotdot[[block.var]] |
| 147 |
# do we have this 'block.var' in partable? |
|
| 148 | 11862x |
if (is.null(partable[[block.var]])) {
|
| 149 |
# for historical reasons, treat "group = 1" special |
|
| 150 | ! |
if (block.var == "group" && block.val == 1L) {
|
| 151 | ! |
partable$group <- rep(1L, length(partable$lhs)) |
| 152 |
# remove block == 0 |
|
| 153 | ! |
idx <- which(partable$block == 0L) |
| 154 | ! |
if (length(idx) > 0L) {
|
| 155 | ! |
partable$group[idx] <- 0L |
| 156 |
} |
|
| 157 | ! |
row.select <- (row.select & |
| 158 | ! |
partable[[block.var]] %in% block.val) |
| 159 |
} else {
|
|
| 160 | ! |
lav_msg_stop(gettextf( |
| 161 | ! |
"selection variable '%s' not found in the parameter table.", |
| 162 | ! |
block.var)) |
| 163 |
} |
|
| 164 |
} else {
|
|
| 165 | 11862x |
if (!all(block.val %in% partable[[block.var]])) {
|
| 166 | ! |
lav_msg_stop(gettextf( |
| 167 | ! |
"%1$s column does not contain value `%2$s'", block.var, block.val)) |
| 168 |
} |
|
| 169 | 11862x |
row.select <- (row.select & |
| 170 | 11862x |
!partable$op %in% c("==", "<", ">", ":=") &
|
| 171 | 11862x |
partable[[block.var]] %in% block.val) |
| 172 |
} |
|
| 173 |
} # dot |
|
| 174 | 11854x |
block.select <- unique(partable$block[row.select]) |
| 175 | 11854x |
if (length(block.select) == 0L) {
|
| 176 | ! |
lav_msg_warn(gettext("no blocks selected."))
|
| 177 |
} |
|
| 178 |
} |
|
| 179 | 15721x |
if (is.null(return.value)) {
|
| 180 |
# ----- lav_partable_vnames ---- no cache ------------------------ |
|
| 181 | ||
| 182 |
# uncomment/comment following line to enable/disable trace |
|
| 183 |
# lav_trace(paste("computed:", paste(type, collapse = ",")))
|
|
| 184 | ||
| 185 |
# random slope names, if any (new in 0.6-7) |
|
| 186 | 1776x |
if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L)) {
|
| 187 | ! |
rv.names <- unique(partable$rv[nchar(partable$rv) > 0L]) |
| 188 |
} else {
|
|
| 189 | 1776x |
rv.names <- character(0L) |
| 190 |
} |
|
| 191 | ||
| 192 |
# output: list per block |
|
| 193 | 1776x |
return.value <- lapply(type, function(x) {
|
| 194 | 27905x |
vector("list", length = length(block.select))
|
| 195 |
}) |
|
| 196 | 1776x |
names(return.value) <- type |
| 197 | ||
| 198 | 1776x |
for (b in block.select) {
|
| 199 |
# indices for this block |
|
| 200 | 2037x |
block.ind <- partable$block == b |
| 201 | ||
| 202 |
# always compute lv.names |
|
| 203 | 2037x |
lv.names <- unique(partable$lhs[block.ind & |
| 204 | 2037x |
(partable$op == "=~" | partable$op == "<~")]) |
| 205 |
# including random slope names |
|
| 206 | 2037x |
lv.names2 <- unique(c(lv.names, rv.names)) |
| 207 | ||
| 208 |
# determine lv interactions |
|
| 209 | 2037x |
int.names <- unique(partable$rhs[block.ind & |
| 210 | 2037x |
grepl(":", partable$rhs, fixed = TRUE)])
|
| 211 | 2037x |
n.int <- length(int.names) |
| 212 | 2037x |
if (n.int > 0L) {
|
| 213 | ! |
ok.idx <- logical(n.int) |
| 214 | ! |
for (iv in seq_len(n.int)) {
|
| 215 | ! |
tmp.names <- strsplit(int.names[iv], ":", fixed = TRUE)[[1L]] |
| 216 |
# three scenario's: |
|
| 217 |
# - both variables are latent (ok) |
|
| 218 |
# - both variables are observed (ignore) |
|
| 219 |
# - only one latent (warn??) -> upgrade observed to latent |
|
| 220 |
# thus if at least one is in lv.names, we treat it as a |
|
| 221 |
# latent interaction |
|
| 222 | ! |
if (any(tmp.names %in% lv.names)) {
|
| 223 | ! |
ok.idx[iv] <- TRUE |
| 224 |
} |
|
| 225 |
} |
|
| 226 | ! |
lv.interaction <- int.names[ok.idx] |
| 227 | ! |
lv.names <- c(lv.names, lv.interaction) |
| 228 | ! |
lv.names2 <- c(lv.names2, lv.interaction) |
| 229 |
} else {
|
|
| 230 | 2037x |
lv.interaction <- character(0L) |
| 231 |
} |
|
| 232 | 2037x |
if (length(type) == 1L) {
|
| 233 |
# ----- lav_partable_vnames ---- no cache ----- 1 type ----------- |
|
| 234 |
# store lv |
|
| 235 | 1019x |
if ("lv" == type) {
|
| 236 |
# check if FLAT for random slopes |
|
| 237 |
# if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L) && |
|
| 238 |
# !is.null(partable$block)) {
|
|
| 239 |
# return.value$lv[[b]] <- lv.names2 |
|
| 240 |
# } else {
|
|
| 241 |
# here, they will be 'defined' at level 2 as regular =~ lvs |
|
| 242 | 151x |
return.value$lv[[b]] <- lv.names |
| 243 |
# } |
|
| 244 | 151x |
next |
| 245 |
} |
|
| 246 | ||
| 247 |
# regular latent variables ONLY (ie defined by =~ only) |
|
| 248 | 868x |
if ("lv.regular" == type) {
|
| 249 | 42x |
out <- unique(partable$lhs[block.ind & |
| 250 | 42x |
partable$op == "=~" & |
| 251 | 42x |
partable$lhs != partable$rhs & # no phantom |
| 252 | 42x |
!partable$lhs %in% rv.names]) |
| 253 | 42x |
return.value$lv.regular[[b]] <- out |
| 254 | 42x |
next |
| 255 |
} |
|
| 256 | ||
| 257 |
# interaction terms involving latent variables (only) |
|
| 258 | 826x |
if ("lv.interaction" == type) {
|
| 259 | 24x |
return.value$lv.interaction[[b]] <- lv.interaction |
| 260 | 24x |
next |
| 261 |
} |
|
| 262 | ||
| 263 |
# formative latent variables: phantom lv + zero residual |
|
| 264 | 802x |
if ("lv.formative" == type) {
|
| 265 | ! |
out <- unique(partable$lhs[block.ind & |
| 266 | ! |
partable$lhs == partable$rhs & |
| 267 | ! |
partable$op == "=~"]) |
| 268 | ! |
rm.idx <- integer(0L) |
| 269 | ! |
for (i in seq_len(length(out))) {
|
| 270 | ! |
var.idx <- which(block.ind & |
| 271 | ! |
partable$op == "~~" & |
| 272 | ! |
partable$lhs == out[i] & |
| 273 | ! |
partable$lhs == partable$rhs) |
| 274 | ! |
if (length(var.idx) == 0L) {
|
| 275 | ! |
next |
| 276 |
} |
|
| 277 | ! |
if (!is.null(partable$mod.idx) && !is.null(partable$fixed)) {
|
| 278 | ! |
if (partable$fixed[var.idx] != "0") {
|
| 279 | ! |
rm.idx <- c(rm.idx, i) |
| 280 |
} |
|
| 281 | ! |
} else if (!is.null(partable$free) && !is.null(partable$ustart)) {
|
| 282 | ! |
if (partable$free[var.idx] > 0L || |
| 283 | ! |
partable$ustart[var.idx] != 0) {
|
| 284 | ! |
rm.idx <- c(rm.idx, i) |
| 285 |
} |
|
| 286 |
} |
|
| 287 |
} |
|
| 288 | ! |
if (length(rm.idx) > 0L) {
|
| 289 | ! |
out <- out[-rm.idx] |
| 290 |
} |
|
| 291 | ! |
return.value$lv.formative[[b]] <- out |
| 292 | ! |
next |
| 293 |
} |
|
| 294 | ||
| 295 |
# composites defined by "<~" |
|
| 296 | 802x |
if ("lv.composite" == type) {
|
| 297 | 24x |
out <- unique(partable$lhs[block.ind & |
| 298 | 24x |
partable$op == "<~"]) |
| 299 | 24x |
return.value$lv.composite[[b]] <- out |
| 300 | 24x |
next |
| 301 |
} |
|
| 302 | ||
| 303 |
# lv's involved in efa |
|
| 304 | 778x |
if (any(type == c("lv.efa", "ov.efa"))) {
|
| 305 | 24x |
if (is.null(partable$efa)) {
|
| 306 | ! |
out <- character(0L) |
| 307 |
} else {
|
|
| 308 | 24x |
set.names <- lav_partable_efa_values(partable) |
| 309 | 24x |
out <- unique(partable$lhs[partable$op == "=~" & |
| 310 | 24x |
block.ind & |
| 311 | 24x |
partable$efa %in% set.names]) |
| 312 |
} |
|
| 313 | ! |
if (type == "ov.efa") ov_efa <- out |
| 314 | 24x |
if (type == "lv.efa") {
|
| 315 | 24x |
return.value$lv.efa[[b]] <- out |
| 316 | 24x |
next |
| 317 |
} |
|
| 318 |
} |
|
| 319 | ||
| 320 |
# lv's that are random slopes |
|
| 321 | 754x |
if ("lv.rv" == type) {
|
| 322 | ! |
if (is.null(partable$rv)) {
|
| 323 | ! |
out <- character(0L) |
| 324 |
} else {
|
|
| 325 | ! |
out <- unique(partable$lhs[partable$op == "=~" & |
| 326 | ! |
block.ind & |
| 327 | ! |
partable$lhs %in% rv.names]) |
| 328 |
} |
|
| 329 | ! |
return.value$lv.rv[[b]] <- out |
| 330 | ! |
next |
| 331 |
} |
|
| 332 | ||
| 333 |
# lv's that are indicators of a higher-order factor |
|
| 334 | 754x |
if ("lv.ind" == type) {
|
| 335 | 87x |
out <- unique(partable$rhs[block.ind & |
| 336 | 87x |
partable$op == "=~" & |
| 337 | 87x |
partable$rhs %in% lv.names & |
| 338 | 87x |
partable$lhs != partable$rhs]) # no phantom lv's |
| 339 | 87x |
return.value$lv.ind[[b]] <- out |
| 340 | 87x |
next |
| 341 |
} |
|
| 342 | ||
| 343 |
# higher-order latent variables |
|
| 344 | 667x |
if ("lv.ho" == type) {
|
| 345 | ! |
out.ind <- unique(partable$rhs[block.ind & |
| 346 | ! |
partable$op == "=~" & |
| 347 | ! |
partable$rhs %in% lv.names & |
| 348 | ! |
partable$lhs != partable$rhs]) # no phantom lv's |
| 349 | ! |
out <- unique(partable$lhs[block.ind & |
| 350 | ! |
partable$op == "=~" & |
| 351 | ! |
partable$lhs %in% lv.names & |
| 352 | ! |
partable$rhs %in% out.ind]) |
| 353 | ! |
return.value$lv.ho[[b]] <- out |
| 354 | ! |
next |
| 355 |
} |
|
| 356 | ||
| 357 |
# eqs.y |
|
| 358 | 667x |
if (!(any(type == c("lv", "lv.regular")))) {
|
| 359 | 667x |
eqs.y <- unique(partable$lhs[block.ind & |
| 360 | 667x |
partable$op == "~"]) |
| 361 |
} |
|
| 362 | ||
| 363 |
# store eqs.y |
|
| 364 | 667x |
if ("eqs.y" == type) {
|
| 365 | 87x |
return.value$eqs.y[[b]] <- eqs.y |
| 366 | 87x |
next |
| 367 |
} |
|
| 368 | ||
| 369 |
# eqs.x |
|
| 370 | 580x |
if (!(any(type == c("lv", "lv.regular", "lv.x")))) {
|
| 371 | 556x |
eqs.x <- unique(partable$rhs[block.ind & |
| 372 | 556x |
(partable$op == "~" | |
| 373 | 556x |
partable$op == "<~")]) |
| 374 |
} |
|
| 375 | ||
| 376 |
# store eqs.x |
|
| 377 | 580x |
if ("eqs.x" == type) {
|
| 378 | ! |
return.value$eqs.x[[b]] <- eqs.x |
| 379 | ! |
next |
| 380 |
} |
|
| 381 | ||
| 382 |
# v.ind -- indicators of latent variables |
|
| 383 | 580x |
if (!(any(type == c("lv", "lv.regular")))) {
|
| 384 | 580x |
v.ind <- unique(partable$rhs[block.ind & |
| 385 | 580x |
partable$op == "=~"]) |
| 386 |
} |
|
| 387 | ||
| 388 |
# v.cind -- indicators of composites |
|
| 389 | 580x |
if (!(any(type == c("lv", "lv.regular")))) {
|
| 390 | 580x |
v.cind <- unique(partable$rhs[block.ind & |
| 391 | 580x |
partable$op == "<~"]) |
| 392 |
} |
|
| 393 | ||
| 394 |
# ov.* |
|
| 395 | 580x |
if (!(any(type == c("lv", "lv.regular", "lv.x", "lv.y")))) {
|
| 396 |
# 1. indicators, which are not latent variables themselves |
|
| 397 | 532x |
ov.ind <- v.ind[!v.ind %in% lv.names2] |
| 398 |
# 1b. indicator of composites |
|
| 399 | 532x |
ov.cind <- v.cind[!v.cind %in% lv.names2] |
| 400 |
# 2. dependent ov's |
|
| 401 | 532x |
ov.y <- eqs.y[!eqs.y %in% c(lv.names2, ov.ind, ov.cind)] |
| 402 |
# 3. independent ov's |
|
| 403 | 532x |
if (lav_partable_nlevels(partable) > 1L && b > 1L) {
|
| 404 |
# NEW in 0.6-8: if an 'x' was an 'y' in a previous level, |
|
| 405 |
# treat it as 'y' |
|
| 406 | 73x |
tmp.eqs.y <- unique(partable$lhs[partable$op == "~"]) # all blocks |
| 407 | 73x |
ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, tmp.eqs.y)] |
| 408 |
} else {
|
|
| 409 | 459x |
ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, ov.y)] |
| 410 |
} |
|
| 411 |
# new in 0.6-12: if we have interaction terms in ov.x, check |
|
| 412 |
# if some terms are in eqs.y; if so, remove the interaction term |
|
| 413 |
# from ov.x |
|
| 414 | 532x |
int.idx <- which(grepl(":", ov.x, fixed = TRUE))
|
| 415 | 532x |
bad.idx <- integer(0L) |
| 416 | 532x |
for (iv in int.idx) {
|
| 417 | ! |
tmp.names <- strsplit(ov.x[iv], ":", fixed = TRUE)[[1L]] |
| 418 | ! |
if (any(tmp.names %in% eqs.y)) {
|
| 419 | ! |
bad.idx <- c(bad.idx, iv) |
| 420 |
} |
|
| 421 |
} |
|
| 422 | 532x |
if (length(bad.idx) > 0L) {
|
| 423 | ! |
ov.y <- unique(c(ov.y, ov.x[bad.idx])) |
| 424 |
# it may be removed later, but needed to construct ov.names |
|
| 425 | ! |
ov.x <- ov.x[-bad.idx] |
| 426 |
} |
|
| 427 |
} |
|
| 428 | ||
| 429 |
# observed variables |
|
| 430 |
# easy approach would be: everything that is not in lv.names, |
|
| 431 |
# but the main purpose here is to 'order' the observed variables |
|
| 432 |
# according to 'type' (indicators, ov.y, ov.x, orphans) |
|
| 433 | 580x |
if (!(any(type == c("lv", "lv.regular", "lv.x", "lv.y")))) {
|
| 434 |
# 4. orphaned covariances |
|
| 435 | 532x |
ov.cov <- c( |
| 436 | 532x |
partable$lhs[block.ind & |
| 437 | 532x |
partable$op == "~~" & |
| 438 | 532x |
!partable$lhs %in% lv.names2], |
| 439 | 532x |
partable$rhs[block.ind & |
| 440 | 532x |
partable$op == "~~" & |
| 441 | 532x |
!partable$rhs %in% lv.names2] |
| 442 |
) |
|
| 443 |
# 5. orphaned intercepts/thresholds |
|
| 444 | 532x |
ov.int <- partable$lhs[block.ind & |
| 445 | 532x |
(partable$op == "~1" | |
| 446 | 532x |
partable$op == "|") & |
| 447 | 532x |
!partable$lhs %in% lv.names2] |
| 448 | ||
| 449 | 532x |
ov.tmp <- c(ov.ind, ov.cind, ov.y, ov.x) |
| 450 | 532x |
ov.extra <- unique(c(ov.cov, ov.int)) # must be in this order! |
| 451 |
# so that |
|
| 452 |
# lav_partable_independence |
|
| 453 |
# retains the same order |
|
| 454 | 532x |
ov.names <- c(ov.tmp, ov.extra[!ov.extra %in% ov.tmp]) |
| 455 |
} |
|
| 456 | ||
| 457 |
# store ov? |
|
| 458 | 580x |
if ("ov" == type) {
|
| 459 | 169x |
return.value$ov[[b]] <- ov.names |
| 460 | 169x |
next |
| 461 |
} |
|
| 462 | ||
| 463 | 411x |
if ("ov.ind" == type) {
|
| 464 | 87x |
return.value$ov.ind[[b]] <- ov.ind |
| 465 | 87x |
next |
| 466 |
} |
|
| 467 | ||
| 468 | 324x |
if ("ov.cind" == type) {
|
| 469 | 24x |
return.value$ov.cind[[b]] <- ov.cind |
| 470 | 24x |
next |
| 471 |
} |
|
| 472 | ||
| 473 | 300x |
if ("ov.interaction" == type) {
|
| 474 | ! |
ov.int.names <- ov.names[grepl(":", ov.names, fixed = TRUE)]
|
| 475 | ! |
n.int <- length(ov.int.names) |
| 476 | ! |
if (n.int > 0L) {
|
| 477 | ! |
ov.names.noint <- ov.names[!ov.names %in% ov.int.names] |
| 478 | ||
| 479 | ! |
ok.idx <- logical(n.int) |
| 480 | ! |
for (iv in seq_len(n.int)) {
|
| 481 | ! |
tmp.names <- strsplit(ov.int.names[iv], ":", fixed = TRUE)[[1L]] |
| 482 | ||
| 483 |
# two scenario's: |
|
| 484 |
# - both variables are in ov.names.noint (ok) |
|
| 485 |
# - at least one variables is NOT in ov.names.noint (ignore) |
|
| 486 | ! |
if (all(tmp.names %in% ov.names.noint)) {
|
| 487 | ! |
ok.idx[iv] <- TRUE |
| 488 |
} |
|
| 489 |
} |
|
| 490 | ! |
ov.interaction <- ov.int.names[ok.idx] |
| 491 |
} else {
|
|
| 492 | ! |
ov.interaction <- character(0L) |
| 493 |
} |
|
| 494 | ||
| 495 | ! |
return.value$ov.interaction[[b]] <- ov.interaction |
| 496 | ! |
next |
| 497 |
} |
|
| 498 | ||
| 499 | 300x |
if ("ov.efa" == type) {
|
| 500 | ! |
ov.efa <- partable$rhs[partable$op == "=~" & |
| 501 | ! |
block.ind & |
| 502 | ! |
partable$rhs %in% ov.ind & |
| 503 | ! |
partable$lhs %in% ov_efa] |
| 504 | ! |
return.value$ov.efa[[b]] <- unique(ov.efa) |
| 505 | ! |
next |
| 506 |
} |
|
| 507 | ||
| 508 | ||
| 509 |
# exogenous `x' covariates |
|
| 510 | 300x |
if (any(type == c( |
| 511 | 300x |
"ov.x", "ov.nox", "ov.model", |
| 512 | 300x |
"th.mean", "lv.nonnormal" |
| 513 |
))) {
|
|
| 514 |
# correction: is any of these ov.names.x mentioned as a variance, |
|
| 515 |
# covariance, or intercept? |
|
| 516 |
# this should trigger a warning in lav_model_partable() |
|
| 517 | 51x |
if (is.null(partable$user)) { # FLAT!
|
| 518 | 48x |
partable$user <- rep(1L, length(partable$lhs)) |
| 519 |
} |
|
| 520 | 51x |
vars <- c( |
| 521 | 51x |
partable$lhs[block.ind & |
| 522 | 51x |
partable$op == "~1" & |
| 523 | 51x |
partable$user == 1], |
| 524 | 51x |
partable$lhs[block.ind & |
| 525 | 51x |
partable$op == "~~" & |
| 526 | 51x |
partable$user == 1], |
| 527 | 51x |
partable$rhs[block.ind & |
| 528 | 51x |
partable$op == "~~" & |
| 529 | 51x |
partable$user == 1] |
| 530 |
) |
|
| 531 | 51x |
idx.no.x <- which(ov.x %in% vars) |
| 532 | 51x |
if (length(idx.no.x)) {
|
| 533 | ! |
if (ov.x.fatal) {
|
| 534 | ! |
lav_msg_stop(gettextf( |
| 535 | ! |
"model syntax contains variance/covariance/intercept formulas |
| 536 | ! |
involving (an) exogenous variable(s): [%s]; Please remove them |
| 537 | ! |
and try again.", lav_msg_view(ov.x[idx.no.x], "none"))) |
| 538 |
} |
|
| 539 | ! |
lav_msg_warn(gettextf( |
| 540 | ! |
"model syntax contains variance/covariance/intercept formulas |
| 541 | ! |
involving (an) exogenous variable(s): [%s]; these variables will |
| 542 | ! |
now be treated as random introducing additional free parameters. |
| 543 | ! |
If you wish to treat those variables as fixed, remove these |
| 544 | ! |
formulas from the model syntax. Otherwise, consider adding the |
| 545 | ! |
fixed.x = FALSE option.", lav_msg_view(ov.x[idx.no.x], "none"))) |
| 546 | ! |
ov.x <- ov.x[-idx.no.x] |
| 547 |
} |
|
| 548 | 51x |
ov.tmp.x <- ov.x |
| 549 | ||
| 550 |
# extra |
|
| 551 | 51x |
if (!is.null(partable$exo)) {
|
| 552 | 3x |
ov.cov <- c( |
| 553 | 3x |
partable$lhs[block.ind & |
| 554 | 3x |
partable$op == "~~" & |
| 555 | 3x |
partable$exo == 1L], |
| 556 | 3x |
partable$rhs[block.ind & |
| 557 | 3x |
partable$op == "~~" & |
| 558 | 3x |
partable$exo == 1L] |
| 559 |
) |
|
| 560 | 3x |
ov.int <- partable$lhs[block.ind & |
| 561 | 3x |
partable$op == "~1" & |
| 562 | 3x |
partable$exo == 1L] |
| 563 | 3x |
ov.extra <- unique(c(ov.cov, ov.int)) |
| 564 | 3x |
ov.tmp.x <- c(ov.tmp.x, ov.extra[!ov.extra %in% ov.tmp.x]) |
| 565 |
} |
|
| 566 | ||
| 567 | 51x |
ov.names.x <- ov.tmp.x |
| 568 |
} |
|
| 569 | ||
| 570 |
# store ov.x? |
|
| 571 | 300x |
if ("ov.x" == type) {
|
| 572 | 25x |
return.value$ov.x[[b]] <- ov.names.x |
| 573 | 25x |
next |
| 574 |
} |
|
| 575 | ||
| 576 |
# story ov.orphan? |
|
| 577 | 275x |
if ("ov.orphan" == type) {
|
| 578 | ! |
return.value$ov.orphan[[b]] <- ov.extra |
| 579 | ! |
next |
| 580 |
} |
|
| 581 | ||
| 582 |
# ov's withouth ov.x |
|
| 583 | 275x |
if (any(type == c( |
| 584 | 275x |
"ov.nox", "ov.model", |
| 585 | 275x |
"th.mean", "lv.nonnormal" |
| 586 |
))) {
|
|
| 587 | 26x |
ov.names.nox <- ov.names[!ov.names %in% ov.names.x] |
| 588 |
} |
|
| 589 | ||
| 590 |
# store ov.nox |
|
| 591 | 275x |
if ("ov.nox" == type) {
|
| 592 | 26x |
return.value$ov.nox[[b]] <- ov.names.nox |
| 593 | 26x |
next |
| 594 |
} |
|
| 595 | ||
| 596 |
# store ov.model |
|
| 597 | 249x |
if ("ov.model" == type) {
|
| 598 |
# if no conditional.x, this is just ov |
|
| 599 |
# else, this is ov.nox |
|
| 600 | ! |
if (any(block.ind & partable$op == "~" & |
| 601 | ! |
partable$exo == 1L)) {
|
| 602 | ! |
return.value$ov.model[[b]] <- ov.names.nox |
| 603 |
} else {
|
|
| 604 | ! |
return.value$ov.model[[b]] <- ov.names |
| 605 |
} |
|
| 606 | ! |
next |
| 607 |
} |
|
| 608 | ||
| 609 |
# ov's strictly ordered |
|
| 610 | 249x |
if (any(type == c( |
| 611 | 249x |
"ov.ord", "th", "th.mean", |
| 612 | 249x |
"ov.num", "lv.nonnormal" |
| 613 |
))) {
|
|
| 614 | 177x |
tmp <- unique(partable$lhs[block.ind & |
| 615 | 177x |
partable$op == "|"]) |
| 616 | 177x |
ord.names <- ov.names[ov.names %in% tmp] |
| 617 |
} |
|
| 618 | ||
| 619 | 249x |
if ("ov.ord" == type) {
|
| 620 | 177x |
return.value$ov.ord[[b]] <- ord.names |
| 621 | 177x |
next |
| 622 |
} |
|
| 623 | ||
| 624 |
# ov's strictly numeric |
|
| 625 | 72x |
if (any(type == c("ov.num", "lv.nonnormal"))) {
|
| 626 | ! |
ov.num <- ov.names[!ov.names %in% ord.names] |
| 627 |
} |
|
| 628 | ||
| 629 | 72x |
if ("ov.num" == type) {
|
| 630 | ! |
return.value$ov.num[[b]] <- ov.num |
| 631 | ! |
next |
| 632 |
} |
|
| 633 | ||
| 634 |
# nonnormal lv's |
|
| 635 | 72x |
if ("lv.nonnormal" == type) {
|
| 636 |
# regular lv's |
|
| 637 | ! |
lv.reg <- unique(partable$lhs[block.ind & |
| 638 | ! |
partable$op == "=~" & |
| 639 | ! |
partable$lhs != partable$rhs]) |
| 640 | ! |
if (length(lv.reg) > 0L) {
|
| 641 | ! |
out <- unlist(lapply(lv.reg, function(x) {
|
| 642 |
# get indicators for this lv |
|
| 643 | ! |
tmp.ind <- unique(partable$rhs[block.ind & |
| 644 | ! |
partable$op == "=~" & |
| 645 | ! |
partable$lhs == x]) |
| 646 | ! |
if (!all(tmp.ind %in% ov.num)) {
|
| 647 | ! |
return(x) |
| 648 |
} else {
|
|
| 649 | ! |
return(character(0)) |
| 650 |
} |
|
| 651 | ! |
}), use.names = FALSE) |
| 652 | ! |
return.value$lv.nonnormal[[b]] <- out |
| 653 |
} else {
|
|
| 654 | ! |
return.value$lv.nonnormal[[b]] <- character(0) |
| 655 |
} |
|
| 656 | ! |
next |
| 657 |
} |
|
| 658 | ||
| 659 | 72x |
if (any(c("th", "th.mean") == type)) {
|
| 660 | ! |
tmp.th.lhs <- partable$lhs[block.ind & |
| 661 | ! |
partable$op == "|"] |
| 662 | ! |
tmp.th.rhs <- partable$rhs[block.ind & |
| 663 | ! |
partable$op == "|"] |
| 664 |
} |
|
| 665 | ||
| 666 |
# threshold |
|
| 667 | 72x |
if ("th" == type) {
|
| 668 | ! |
if (length(ord.names) > 0L) {
|
| 669 |
# return in the right order (following ord.names!) |
|
| 670 | ! |
out <- unlist(lapply(ord.names, function(x) {
|
| 671 | ! |
idx <- which(x == tmp.th.lhs) |
| 672 | ! |
tmp.th <- unique(paste(tmp.th.lhs[idx], "|", |
| 673 | ! |
tmp.th.rhs[idx], |
| 674 | ! |
sep = "" |
| 675 |
)) |
|
| 676 |
# make sure the th's are in increasing order |
|
| 677 |
# sort(tmp.th) |
|
| 678 |
# NO!, don't do that; t10 will be before t2 |
|
| 679 |
# fixed in 0.6-1 (bug report from Myrsini) |
|
| 680 |
# in 0.6-12, we do this anyway like this: |
|
| 681 | ||
| 682 |
# get var name |
|
| 683 | ! |
tmp.th1 <- sapply( |
| 684 | ! |
strsplit(tmp.th, split = "\\|t"), |
| 685 | ! |
"[[", 1 |
| 686 |
) |
|
| 687 |
# get number, and sort |
|
| 688 | ! |
tmp.th2 <- as.character(sort(as.integer(sapply( |
| 689 | ! |
strsplit(tmp.th, split = "\\|t"), "[[", 2 |
| 690 |
)))) |
|
| 691 |
# paste back togehter in the right order |
|
| 692 | ! |
paste(tmp.th1, tmp.th2, sep = "|t") |
| 693 | ! |
}), use.names = FALSE) |
| 694 |
} else {
|
|
| 695 | ! |
out <- character(0L) |
| 696 |
} |
|
| 697 | ! |
return.value$th[[b]] <- out |
| 698 | ! |
next |
| 699 |
} |
|
| 700 | ||
| 701 |
# thresholds and mean/intercepts of numeric variables |
|
| 702 | 72x |
if ("th.mean" == type) {
|
| 703 |
# if fixed.x -> use ov.names.nox |
|
| 704 |
# else -> use ov.names |
|
| 705 | ! |
if (is.null(partable$exo) || all(partable$exo == 0L)) {
|
| 706 | ! |
tmp.ov.names <- ov.names |
| 707 |
} else {
|
|
| 708 | ! |
tmp.ov.names <- ov.names.nox |
| 709 |
} |
|
| 710 | ! |
if (length(tmp.ov.names) > 0L) {
|
| 711 |
# return in the right order (following ov.names.nox!) |
|
| 712 | ! |
out <- unlist(lapply(tmp.ov.names, function(x) {
|
| 713 | ! |
if (x %in% ord.names) {
|
| 714 | ! |
idx <- which(x == tmp.th.lhs) |
| 715 | ! |
tmp.th <- unique( |
| 716 | ! |
paste(tmp.th.lhs[idx], "|", |
| 717 | ! |
tmp.th.rhs[idx], |
| 718 | ! |
sep = "" |
| 719 |
), |
|
| 720 | ! |
use.names = FALSE |
| 721 |
) |
|
| 722 |
# make sure the th's are in increasing order |
|
| 723 |
# get var name |
|
| 724 | ! |
tmp.th1 <- sapply( |
| 725 | ! |
strsplit(tmp.th, split = "\\|t"), |
| 726 | ! |
"[[", 1 |
| 727 |
) |
|
| 728 |
# get number, and sort |
|
| 729 | ! |
tmp.th2 <- as.character(sort(as.integer(sapply( |
| 730 | ! |
strsplit(tmp.th, split = "\\|t"), "[[", 2 |
| 731 |
)))) |
|
| 732 |
# paste back togehter in the right order |
|
| 733 | ! |
paste(tmp.th1, tmp.th2, sep = "|t") |
| 734 |
} else {
|
|
| 735 | ! |
x |
| 736 |
} |
|
| 737 |
})) |
|
| 738 |
} else {
|
|
| 739 | ! |
out <- character(0L) |
| 740 |
} |
|
| 741 | ! |
return.value$th.mean[[b]] <- out |
| 742 | ! |
next |
| 743 |
} |
|
| 744 | ||
| 745 |
# exogenous lv's |
|
| 746 | 72x |
if (any(c("lv.x", "lv.nox") == type)) {
|
| 747 | 24x |
tmp <- lv.names[!lv.names %in% c(v.ind, eqs.y)] |
| 748 | 24x |
lv.names.x <- lv.names[lv.names %in% tmp] |
| 749 |
} |
|
| 750 | ||
| 751 | 72x |
if ("lv.x" == type) {
|
| 752 | 24x |
return.value$lv.x[[b]] <- lv.names.x |
| 753 | 24x |
next |
| 754 |
} |
|
| 755 | ||
| 756 |
# dependent ov (but not also indicator or x) |
|
| 757 | 48x |
if ("ov.y" == type) {
|
| 758 | 24x |
tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x, lv.names)] |
| 759 | 24x |
return.value$ov.y[[b]] <- ov.names[ov.names %in% tmp] |
| 760 | 24x |
next |
| 761 |
} |
|
| 762 | ||
| 763 |
# dependent lv (but not also indicator or x) |
|
| 764 | 24x |
if ("lv.y" == type) {
|
| 765 | 24x |
tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x) & |
| 766 | 24x |
eqs.y %in% lv.names] |
| 767 | 24x |
return.value$lv.y[[b]] <- lv.names[lv.names %in% tmp] |
| 768 | 24x |
next |
| 769 |
} |
|
| 770 | ||
| 771 |
# non-exogenous latent variables |
|
| 772 | ! |
if ("lv.nox" == type) {
|
| 773 | ! |
return.value$lv.nox[[b]] <- lv.names[!lv.names %in% lv.names.x] |
| 774 | ! |
next |
| 775 |
} |
|
| 776 | ||
| 777 |
# marker indicator (if any) for each lv |
|
| 778 | ! |
if ("lv.marker" == type) {
|
| 779 |
# default: "" per lv |
|
| 780 | ! |
out <- character(length(lv.names)) |
| 781 | ! |
names(out) <- lv.names |
| 782 | ! |
for (l in seq_len(length(lv.names))) {
|
| 783 | ! |
this.lv.name <- lv.names[l] |
| 784 |
# try to see if we can find a 'marker' indicator for this factor |
|
| 785 |
# here defined as: has fixed-to-one factor loading |
|
| 786 | ! |
marker.idx <- which(block.ind & |
| 787 | ! |
partable$op == "=~" & |
| 788 | ! |
partable$lhs == this.lv.name & |
| 789 | ! |
partable$rhs %in% v.ind & |
| 790 | ! |
partable$ustart == 1L & |
| 791 | ! |
partable$free == 0L) |
| 792 | ! |
if (length(marker.idx) > 0L) {
|
| 793 |
# we may have multiple potential markers |
|
| 794 | ! |
potential.markers <- partable$rhs[marker.idx] |
| 795 | ! |
valid.markers <- character(0L) |
| 796 | ! |
for (m in seq_along(potential.markers)) {
|
| 797 | ! |
this.marker.idx <- marker.idx[m] |
| 798 |
# check if 'other' loadings are fixed to zero |
|
| 799 | ! |
other.idx <- which(block.ind & |
| 800 | ! |
partable$op == "=~" & |
| 801 | ! |
partable$lhs != this.lv.name & |
| 802 | ! |
partable$rhs == partable$rhs[this.marker.idx] & |
| 803 | ! |
partable$free == 0L) |
| 804 | ! |
if (length(other.idx) == 0L) {
|
| 805 |
# simple structure, or one factor |
|
| 806 | ! |
valid.markers <- c(valid.markers, |
| 807 | ! |
partable$rhs[this.marker.idx]) |
| 808 | ! |
} else if (all(partable$ustart[other.idx] == 0)) {
|
| 809 | ! |
valid.markers <- c(valid.markers, |
| 810 | ! |
partable$rhs[this.marker.idx]) |
| 811 |
} |
|
| 812 |
} |
|
| 813 | ! |
if (length(valid.markers) > 0L) {
|
| 814 | ! |
out[l] <- valid.markers[1L] # pick the first one |
| 815 |
} |
|
| 816 |
} |
|
| 817 |
} # l |
|
| 818 | ! |
return.value$lv.marker[[b]] <- out |
| 819 |
} |
|
| 820 |
} else {
|
|
| 821 |
# ----- lav_partable_vnames ---- no cache ----- more than 1 type ------ |
|
| 822 |
# store lv |
|
| 823 | 1018x |
if (any("lv" == type)) {
|
| 824 |
# check if FLAT for random slopes |
|
| 825 |
# if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L) && |
|
| 826 |
# !is.null(partable$block)) {
|
|
| 827 |
# return.value$lv[[b]] <- lv.names2 |
|
| 828 |
# } else {
|
|
| 829 |
# here, they will be 'defined' at level 2 as regular =~ lvs |
|
| 830 | 1018x |
return.value$lv[[b]] <- lv.names |
| 831 |
# } |
|
| 832 |
} |
|
| 833 | ||
| 834 |
# regular latent variables ONLY (ie defined by =~ only) |
|
| 835 | 1018x |
if (any("lv.regular" == type)) {
|
| 836 | 1018x |
out <- unique(partable$lhs[block.ind & |
| 837 | 1018x |
partable$op == "=~" & |
| 838 | 1018x |
partable$lhs != partable$rhs & # no phantom |
| 839 | 1018x |
!partable$lhs %in% rv.names]) |
| 840 | 1018x |
return.value$lv.regular[[b]] <- out |
| 841 |
} |
|
| 842 | ||
| 843 | ||
| 844 |
# interaction terms involving latent variables (only) |
|
| 845 | 1018x |
if (any("lv.interaction" == type)) {
|
| 846 | 1018x |
return.value$lv.interaction[[b]] <- lv.interaction |
| 847 |
} |
|
| 848 | ||
| 849 |
# formative latent variables: phantom lv + zero residual |
|
| 850 | 1018x |
if (any("lv.formative" == type)) {
|
| 851 | 1018x |
out <- unique(partable$lhs[block.ind & |
| 852 | 1018x |
partable$lhs == partable$rhs & |
| 853 | 1018x |
partable$op == "=~"]) |
| 854 | 1018x |
rm.idx <- integer(0L) |
| 855 | 1018x |
for (i in seq_len(length(out))) {
|
| 856 | ! |
var.idx <- which(block.ind & |
| 857 | ! |
partable$op == "~~" & |
| 858 | ! |
partable$lhs == out[i] & |
| 859 | ! |
partable$lhs == partable$rhs) |
| 860 | ! |
if (length(var.idx) == 0L) {
|
| 861 | ! |
next |
| 862 |
} |
|
| 863 | ! |
if (!is.null(partable$mod.idx) && !is.null(partable$fixed)) {
|
| 864 | ! |
if (partable$fixed[var.idx] != "0") {
|
| 865 | ! |
rm.idx <- c(rm.idx, i) |
| 866 |
} |
|
| 867 | ! |
} else if (!is.null(partable$free) && !is.null(partable$ustart)) {
|
| 868 | ! |
if (partable$free[var.idx] > 0L || |
| 869 | ! |
partable$ustart[var.idx] != 0) {
|
| 870 | ! |
rm.idx <- c(rm.idx, i) |
| 871 |
} |
|
| 872 |
} |
|
| 873 |
} |
|
| 874 | 1018x |
if (length(rm.idx) > 0L) {
|
| 875 | ! |
out <- out[-rm.idx] |
| 876 |
} |
|
| 877 | 1018x |
return.value$lv.formative[[b]] <- out |
| 878 |
} |
|
| 879 | ||
| 880 |
# composite latent variables (ie defined by <~) |
|
| 881 | 1018x |
if (any("lv.composite" == type)) {
|
| 882 | 1018x |
out <- unique(partable$lhs[block.ind & |
| 883 | 1018x |
partable$op == "<~"]) |
| 884 | 1018x |
return.value$lv.composite[[b]] <- out |
| 885 |
} |
|
| 886 | ||
| 887 |
# lv's involved in efa |
|
| 888 | 1018x |
if (any(type %in% c("lv.efa", "ov.efa"))) {
|
| 889 | 1018x |
if (is.null(partable$efa)) {
|
| 890 | 949x |
out <- character(0L) |
| 891 |
} else {
|
|
| 892 | 69x |
set.names <- lav_partable_efa_values(partable) |
| 893 | 69x |
out <- unique(partable$lhs[partable$op == "=~" & |
| 894 | 69x |
block.ind & |
| 895 | 69x |
partable$efa %in% set.names]) |
| 896 |
} |
|
| 897 | 1018x |
if (any(type == "ov.efa")) ov_efa <- out |
| 898 | 1018x |
if (any(type == "lv.efa")) return.value$lv.efa[[b]] <- out |
| 899 |
} |
|
| 900 | ||
| 901 |
# lv's that are random slopes |
|
| 902 | 1018x |
if (any("lv.rv" == type)) {
|
| 903 | 1018x |
if (is.null(partable$rv)) {
|
| 904 | 973x |
out <- character(0L) |
| 905 |
} else {
|
|
| 906 | 45x |
out <- unique(partable$lhs[partable$op == "=~" & |
| 907 | 45x |
block.ind & |
| 908 | 45x |
partable$lhs %in% rv.names]) |
| 909 |
} |
|
| 910 | 1018x |
return.value$lv.rv[[b]] <- out |
| 911 |
} |
|
| 912 | ||
| 913 |
# lv's that are indicators of a higher-order factor |
|
| 914 | 1018x |
if (any("lv.ind" == type)) {
|
| 915 | 1018x |
out <- unique(partable$rhs[block.ind & |
| 916 | 1018x |
partable$op == "=~" & |
| 917 | 1018x |
partable$rhs %in% lv.names & |
| 918 | 1018x |
partable$lhs != partable$rhs]) # no phantom lv's |
| 919 | 1018x |
return.value$lv.ind[[b]] <- out |
| 920 |
} |
|
| 921 | ||
| 922 |
# higher-order latent variables |
|
| 923 | 1018x |
if (any("lv.ho" == type)) {
|
| 924 | 1018x |
out.ind <- unique(partable$rhs[block.ind & |
| 925 | 1018x |
partable$op == "=~" & |
| 926 | 1018x |
partable$rhs %in% lv.names & |
| 927 | 1018x |
partable$lhs != partable$rhs]) # no phantom lv's |
| 928 | 1018x |
out <- unique(partable$lhs[block.ind & |
| 929 | 1018x |
partable$op == "=~" & |
| 930 | 1018x |
partable$lhs %in% lv.names & |
| 931 | 1018x |
partable$rhs %in% out.ind]) |
| 932 | 1018x |
return.value$lv.ho[[b]] <- out |
| 933 |
} |
|
| 934 | ||
| 935 |
# eqs.y |
|
| 936 | 1018x |
eqs.y <- unique(partable$lhs[block.ind & |
| 937 | 1018x |
partable$op == "~"]) |
| 938 | ||
| 939 |
# store eqs.y |
|
| 940 | 1018x |
if (any("eqs.y" == type)) {
|
| 941 | 1018x |
return.value$eqs.y[[b]] <- eqs.y |
| 942 |
} |
|
| 943 | ||
| 944 |
# eqs.x |
|
| 945 | 1018x |
eqs.x <- unique(partable$rhs[block.ind & |
| 946 | 1018x |
(partable$op == "~" | |
| 947 | 1018x |
partable$op == "<~")]) |
| 948 | ||
| 949 |
# store eqs.x |
|
| 950 | 1018x |
if (any("eqs.x" == type)) {
|
| 951 | 1018x |
return.value$eqs.x[[b]] <- eqs.x |
| 952 |
} |
|
| 953 | ||
| 954 |
# v.ind -- indicators of latent variables |
|
| 955 | 1018x |
v.ind <- unique(partable$rhs[block.ind & |
| 956 | 1018x |
partable$op == "=~"]) |
| 957 | ||
| 958 |
# v.cind -- indicators of composites |
|
| 959 | 1018x |
v.cind <- unique(partable$rhs[block.ind & |
| 960 | 1018x |
partable$op == "<~"]) |
| 961 | ||
| 962 | ||
| 963 |
# ov.* |
|
| 964 |
# 1. indicators, which are not latent variables themselves |
|
| 965 | 1018x |
ov.ind <- v.ind[!v.ind %in% lv.names2] |
| 966 |
# 1a. indicators of composites |
|
| 967 | 1018x |
ov.cind <- v.cind[!v.cind %in% lv.names2] |
| 968 |
# 2. dependent ov's |
|
| 969 | 1018x |
ov.y <- eqs.y[!eqs.y %in% c(lv.names2, ov.ind, ov.cind)] |
| 970 |
# 3. independent ov's |
|
| 971 | 1018x |
if (lav_partable_nlevels(partable) > 1L && b > 1L) {
|
| 972 |
# NEW in 0.6-8: if an 'x' was an 'y' in a previous level, |
|
| 973 |
# treat it as 'y' |
|
| 974 | 90x |
tmp.eqs.y <- unique(partable$lhs[partable$op == "~"]) # all blocks |
| 975 | 90x |
ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, tmp.eqs.y)] |
| 976 |
} else {
|
|
| 977 | 928x |
ov.x <- eqs.x[!eqs.x %in% c(lv.names2, ov.ind, ov.cind, ov.y)] |
| 978 |
} |
|
| 979 |
# new in 0.6-12: if we have interaction terms in ov.x, check |
|
| 980 |
# if some terms are in eqs.y; if so, remove the interaction term |
|
| 981 |
# from ov.x |
|
| 982 | 1018x |
int.idx <- which(grepl(":", ov.x, fixed = TRUE))
|
| 983 | 1018x |
bad.idx <- integer(0L) |
| 984 | 1018x |
for (iv in int.idx) {
|
| 985 | ! |
tmp.names <- strsplit(ov.x[iv], ":", fixed = TRUE)[[1L]] |
| 986 | ! |
if (any(tmp.names %in% eqs.y)) {
|
| 987 | ! |
bad.idx <- c(bad.idx, iv) |
| 988 |
} |
|
| 989 |
} |
|
| 990 | 1018x |
if (length(bad.idx) > 0L) {
|
| 991 | ! |
ov.y <- unique(c(ov.y, ov.x[bad.idx])) |
| 992 |
# it may be removed later, but needed to construct ov.names |
|
| 993 | ! |
ov.x <- ov.x[-bad.idx] |
| 994 |
} |
|
| 995 | ||
| 996 |
# observed variables |
|
| 997 |
# easy approach would be: everything that is not in lv.names, |
|
| 998 |
# but the main purpose here is to 'order' the observed variables |
|
| 999 |
# according to 'type' (indicators, ov.y, ov.x, orphans) |
|
| 1000 | ||
| 1001 |
# 4. orphaned covariances |
|
| 1002 | 1018x |
ov.cov <- c( |
| 1003 | 1018x |
partable$lhs[block.ind & |
| 1004 | 1018x |
partable$op == "~~" & |
| 1005 | 1018x |
!partable$lhs %in% lv.names2], |
| 1006 | 1018x |
partable$rhs[block.ind & |
| 1007 | 1018x |
partable$op == "~~" & |
| 1008 | 1018x |
!partable$rhs %in% lv.names2] |
| 1009 |
) |
|
| 1010 |
# 5. orphaned intercepts/thresholds |
|
| 1011 | 1018x |
ov.int <- partable$lhs[block.ind & |
| 1012 | 1018x |
(partable$op == "~1" | |
| 1013 | 1018x |
partable$op == "|") & |
| 1014 | 1018x |
!partable$lhs %in% lv.names2] |
| 1015 | ||
| 1016 | 1018x |
ov.tmp <- c(ov.ind, ov.cind, ov.y, ov.x) |
| 1017 | 1018x |
ov.extra <- unique(c(ov.cov, ov.int)) # must be in this order! |
| 1018 |
# so that |
|
| 1019 |
# lav_partable_independence |
|
| 1020 |
# retains the same order |
|
| 1021 | 1018x |
ov.names <- c(ov.tmp, ov.extra[!ov.extra %in% ov.tmp]) |
| 1022 | ||
| 1023 |
# store ov? |
|
| 1024 | 1018x |
if (any("ov" == type)) {
|
| 1025 | 1018x |
return.value$ov[[b]] <- ov.names |
| 1026 |
} |
|
| 1027 | ||
| 1028 | 1018x |
if (any("ov.ind" == type)) {
|
| 1029 | 1018x |
return.value$ov.ind[[b]] <- ov.ind |
| 1030 |
} |
|
| 1031 | ||
| 1032 | 1018x |
if (any("ov.cind" == type)) {
|
| 1033 | 1018x |
return.value$ov.cind[[b]] <- ov.cind |
| 1034 |
} |
|
| 1035 | ||
| 1036 | 1018x |
if (any("ov.interaction" == type)) {
|
| 1037 | 1018x |
ov.int.names <- ov.names[grepl(":", ov.names, fixed = TRUE)]
|
| 1038 | 1018x |
n.int <- length(ov.int.names) |
| 1039 | 1018x |
if (n.int > 0L) {
|
| 1040 | ! |
ov.names.noint <- ov.names[!ov.names %in% ov.int.names] |
| 1041 | ||
| 1042 | ! |
ok.idx <- logical(n.int) |
| 1043 | ! |
for (iv in seq_len(n.int)) {
|
| 1044 | ! |
tmp.names <- strsplit(ov.int.names[iv], ":", fixed = TRUE)[[1L]] |
| 1045 | ||
| 1046 |
# two scenario's: |
|
| 1047 |
# - both variables are in ov.names.noint (ok) |
|
| 1048 |
# - at least one variables is NOT in ov.names.noint (ignore) |
|
| 1049 | ! |
if (all(tmp.names %in% ov.names.noint)) {
|
| 1050 | ! |
ok.idx[iv] <- TRUE |
| 1051 |
} |
|
| 1052 |
} |
|
| 1053 | ! |
ov.interaction <- ov.int.names[ok.idx] |
| 1054 |
} else {
|
|
| 1055 | 1018x |
ov.interaction <- character(0L) |
| 1056 |
} |
|
| 1057 | ||
| 1058 | 1018x |
return.value$ov.interaction[[b]] <- ov.interaction |
| 1059 |
} |
|
| 1060 | ||
| 1061 | 1018x |
if (any("ov.efa" == type)) {
|
| 1062 | 1018x |
ov.efa <- partable$rhs[partable$op == "=~" & |
| 1063 | 1018x |
block.ind & |
| 1064 | 1018x |
partable$rhs %in% ov.ind & |
| 1065 | 1018x |
partable$lhs %in% ov_efa] |
| 1066 | 1018x |
return.value$ov.efa[[b]] <- unique(ov.efa) |
| 1067 |
} |
|
| 1068 | ||
| 1069 | ||
| 1070 |
# exogenous `x' covariates |
|
| 1071 | 1018x |
if (any(type %in% c( |
| 1072 | 1018x |
"ov.x", "ov.nox", "ov.model", |
| 1073 | 1018x |
"th.mean", "lv.nonnormal" |
| 1074 |
))) {
|
|
| 1075 |
# correction: is any of these ov.names.x mentioned as a variance, |
|
| 1076 |
# covariance, or intercept? |
|
| 1077 |
# this should trigger a warning in lav_model_partable() |
|
| 1078 | 1018x |
if (is.null(partable$user)) { # FLAT!
|
| 1079 | 45x |
partable$user <- rep(1L, length(partable$lhs)) |
| 1080 |
} |
|
| 1081 | 1018x |
vars <- c( |
| 1082 | 1018x |
partable$lhs[block.ind & |
| 1083 | 1018x |
partable$op == "~1" & |
| 1084 | 1018x |
partable$user == 1], |
| 1085 | 1018x |
partable$lhs[block.ind & |
| 1086 | 1018x |
partable$op == "~~" & |
| 1087 | 1018x |
partable$user == 1], |
| 1088 | 1018x |
partable$rhs[block.ind & |
| 1089 | 1018x |
partable$op == "~~" & |
| 1090 | 1018x |
partable$user == 1] |
| 1091 |
) |
|
| 1092 | 1018x |
idx.no.x <- which(ov.x %in% vars) |
| 1093 | 1018x |
if (length(idx.no.x)) {
|
| 1094 | 14x |
if (ov.x.fatal) {
|
| 1095 | ! |
lav_msg_stop(gettextf( |
| 1096 | ! |
"model syntax contains variance/covariance/intercept formulas |
| 1097 | ! |
involving (an) exogenous variable(s): [%s]; Please remove them |
| 1098 | ! |
and try again.", lav_msg_view(ov.x[idx.no.x], "none"))) |
| 1099 |
} |
|
| 1100 | 14x |
lav_msg_warn(gettextf( |
| 1101 | 14x |
"model syntax contains variance/covariance/intercept formulas |
| 1102 | 14x |
involving (an) exogenous variable(s): [%s]; these variables will |
| 1103 | 14x |
now be treated as random introducing additional free parameters. |
| 1104 | 14x |
If you wish to treat those variables as fixed, remove these |
| 1105 | 14x |
formulas from the model syntax. Otherwise, consider adding the |
| 1106 | 14x |
fixed.x = FALSE option.", lav_msg_view(ov.x[idx.no.x], "none"))) |
| 1107 | 14x |
ov.x <- ov.x[-idx.no.x] |
| 1108 |
} |
|
| 1109 | 1018x |
ov.tmp.x <- ov.x |
| 1110 | ||
| 1111 |
# extra |
|
| 1112 | 1018x |
if (!is.null(partable$exo)) {
|
| 1113 | 973x |
ov.cov <- c( |
| 1114 | 973x |
partable$lhs[block.ind & |
| 1115 | 973x |
partable$op == "~~" & |
| 1116 | 973x |
partable$exo == 1L], |
| 1117 | 973x |
partable$rhs[block.ind & |
| 1118 | 973x |
partable$op == "~~" & |
| 1119 | 973x |
partable$exo == 1L] |
| 1120 |
) |
|
| 1121 | 973x |
ov.int <- partable$lhs[block.ind & |
| 1122 | 973x |
partable$op == "~1" & |
| 1123 | 973x |
partable$exo == 1L] |
| 1124 | 973x |
ov.extra <- unique(c(ov.cov, ov.int)) |
| 1125 | 973x |
ov.tmp.x <- c(ov.tmp.x, ov.extra[!ov.extra %in% ov.tmp.x]) |
| 1126 |
} |
|
| 1127 | ||
| 1128 | 1018x |
ov.names.x <- ov.tmp.x |
| 1129 |
} |
|
| 1130 | ||
| 1131 |
# store ov.x? |
|
| 1132 | 1018x |
if (any("ov.x" == type)) {
|
| 1133 | 1018x |
return.value$ov.x[[b]] <- ov.names.x |
| 1134 |
} |
|
| 1135 | ||
| 1136 |
# story ov.orphan? |
|
| 1137 | 1018x |
if (any("ov.orphan" == type)) {
|
| 1138 | 1018x |
return.value$ov.orphan[[b]] <- ov.extra |
| 1139 |
} |
|
| 1140 | ||
| 1141 |
# ov's withouth ov.x |
|
| 1142 | 1018x |
if (any(type %in% c( |
| 1143 | 1018x |
"ov.nox", "ov.model", |
| 1144 | 1018x |
"th.mean", "lv.nonnormal" |
| 1145 |
))) {
|
|
| 1146 | 1018x |
ov.names.nox <- ov.names[!ov.names %in% ov.names.x] |
| 1147 |
} |
|
| 1148 | ||
| 1149 |
# store ov.nox |
|
| 1150 | 1018x |
if (any("ov.nox" == type)) {
|
| 1151 | 1018x |
return.value$ov.nox[[b]] <- ov.names.nox |
| 1152 |
} |
|
| 1153 | ||
| 1154 |
# store ov.model |
|
| 1155 | 1018x |
if (any("ov.model" == type)) {
|
| 1156 |
# if no conditional.x, this is just ov |
|
| 1157 |
# else, this is ov.nox |
|
| 1158 | 1018x |
if (any(block.ind & partable$op == "~" & |
| 1159 | 1018x |
partable$exo == 1L)) {
|
| 1160 | 23x |
return.value$ov.model[[b]] <- ov.names.nox |
| 1161 |
} else {
|
|
| 1162 | 995x |
return.value$ov.model[[b]] <- ov.names |
| 1163 |
} |
|
| 1164 |
} |
|
| 1165 | ||
| 1166 |
# ov's strictly ordered |
|
| 1167 | 1018x |
if (any(type %in% c( |
| 1168 | 1018x |
"ov.ord", "th", "th.mean", |
| 1169 | 1018x |
"ov.num", "lv.nonnormal" |
| 1170 |
))) {
|
|
| 1171 | 1018x |
tmp <- unique(partable$lhs[block.ind & |
| 1172 | 1018x |
partable$op == "|"]) |
| 1173 | 1018x |
ord.names <- ov.names[ov.names %in% tmp] |
| 1174 |
} |
|
| 1175 | ||
| 1176 | 1018x |
if (any("ov.ord" == type)) {
|
| 1177 | 1018x |
return.value$ov.ord[[b]] <- ord.names |
| 1178 |
} |
|
| 1179 | ||
| 1180 |
# ov's strictly numeric |
|
| 1181 | 1018x |
if (any(type %in% c("ov.num", "lv.nonnormal"))) {
|
| 1182 | 1018x |
ov.num <- ov.names[!ov.names %in% ord.names] |
| 1183 |
} |
|
| 1184 | ||
| 1185 | 1018x |
if (any("ov.num" == type)) {
|
| 1186 | 1018x |
return.value$ov.num[[b]] <- ov.num |
| 1187 |
} |
|
| 1188 | ||
| 1189 |
# nonnormal lv's |
|
| 1190 | 1018x |
if (any("lv.nonnormal" == type)) {
|
| 1191 |
# regular lv's |
|
| 1192 | 1018x |
lv.reg <- unique(partable$lhs[block.ind & |
| 1193 | 1018x |
partable$op == "=~" & |
| 1194 | 1018x |
partable$lhs != partable$rhs]) |
| 1195 | 1018x |
if (length(lv.reg) > 0L) {
|
| 1196 | 263x |
out <- unlist(lapply(lv.reg, function(x) {
|
| 1197 |
# get indicators for this lv |
|
| 1198 | 894x |
tmp.ind <- unique(partable$rhs[block.ind & |
| 1199 | 894x |
partable$op == "=~" & |
| 1200 | 894x |
partable$lhs == x]) |
| 1201 | 894x |
if (!all(tmp.ind %in% ov.num)) {
|
| 1202 | 243x |
return(x) |
| 1203 |
} else {
|
|
| 1204 | 651x |
return(character(0)) |
| 1205 |
} |
|
| 1206 | 263x |
}), use.names = FALSE) |
| 1207 | 263x |
return.value$lv.nonnormal[[b]] <- out |
| 1208 |
} else {
|
|
| 1209 | 755x |
return.value$lv.nonnormal[[b]] <- character(0) |
| 1210 |
} |
|
| 1211 |
} |
|
| 1212 | ||
| 1213 | 1018x |
if (any(c("th", "th.mean") %in% type)) {
|
| 1214 | 1018x |
tmp.th.lhs <- partable$lhs[block.ind & |
| 1215 | 1018x |
partable$op == "|"] |
| 1216 | 1018x |
tmp.th.rhs <- partable$rhs[block.ind & |
| 1217 | 1018x |
partable$op == "|"] |
| 1218 |
} |
|
| 1219 | ||
| 1220 |
# threshold |
|
| 1221 | 1018x |
if (any("th" == type)) {
|
| 1222 | 1018x |
if (length(ord.names) > 0L) {
|
| 1223 |
# return in the right order (following ord.names!) |
|
| 1224 | 23x |
out <- unlist(lapply(ord.names, function(x) {
|
| 1225 | 92x |
idx <- which(x == tmp.th.lhs) |
| 1226 | 92x |
tmp.th <- unique(paste(tmp.th.lhs[idx], "|", |
| 1227 | 92x |
tmp.th.rhs[idx], |
| 1228 | 92x |
sep = "" |
| 1229 |
)) |
|
| 1230 |
# make sure the th's are in increasing order |
|
| 1231 |
# sort(tmp.th) |
|
| 1232 |
# NO!, don't do that; t10 will be before t2 |
|
| 1233 |
# fixed in 0.6-1 (bug report from Myrsini) |
|
| 1234 |
# in 0.6-12, we do this anyway like this: |
|
| 1235 | ||
| 1236 |
# get var name |
|
| 1237 | 92x |
tmp.th1 <- sapply( |
| 1238 | 92x |
strsplit(tmp.th, split = "\\|t"), |
| 1239 | 92x |
"[[", 1 |
| 1240 |
) |
|
| 1241 |
# get number, and sort |
|
| 1242 | 92x |
tmp.th2 <- as.character(sort(as.integer(sapply( |
| 1243 | 92x |
strsplit(tmp.th, split = "\\|t"), "[[", 2 |
| 1244 |
)))) |
|
| 1245 |
# paste back togehter in the right order |
|
| 1246 | 92x |
paste(tmp.th1, tmp.th2, sep = "|t") |
| 1247 | 23x |
}), use.names = FALSE) |
| 1248 |
} else {
|
|
| 1249 | 995x |
out <- character(0L) |
| 1250 |
} |
|
| 1251 | 1018x |
return.value$th[[b]] <- out |
| 1252 |
} |
|
| 1253 | ||
| 1254 |
# thresholds and mean/intercepts of numeric variables |
|
| 1255 | 1018x |
if (any("th.mean" == type)) {
|
| 1256 |
# if fixed.x -> use ov.names.nox |
|
| 1257 |
# else -> use ov.names |
|
| 1258 | 1018x |
if (is.null(partable$exo) || all(partable$exo == 0L)) {
|
| 1259 | 629x |
tmp.ov.names <- ov.names |
| 1260 |
} else {
|
|
| 1261 | 389x |
tmp.ov.names <- ov.names.nox |
| 1262 |
} |
|
| 1263 | 1018x |
if (length(tmp.ov.names) > 0L) {
|
| 1264 |
# return in the right order (following ov.names.nox!) |
|
| 1265 | 1018x |
out <- unlist(lapply(tmp.ov.names, function(x) {
|
| 1266 | 5873x |
if (x %in% ord.names) {
|
| 1267 | 92x |
idx <- which(x == tmp.th.lhs) |
| 1268 | 92x |
tmp.th <- unique(paste(tmp.th.lhs[idx], "|", |
| 1269 | 92x |
tmp.th.rhs[idx], |
| 1270 | 92x |
sep = "" |
| 1271 |
)) |
|
| 1272 |
# make sure the th's are in increasing order |
|
| 1273 |
# get var name |
|
| 1274 | 92x |
tmp.th1 <- sapply( |
| 1275 | 92x |
strsplit(tmp.th, split = "\\|t"), |
| 1276 | 92x |
"[[", 1 |
| 1277 |
) |
|
| 1278 |
# get number, and sort |
|
| 1279 | 92x |
tmp.th2 <- as.character(sort(as.integer(sapply( |
| 1280 | 92x |
strsplit(tmp.th, split = "\\|t"), "[[", 2 |
| 1281 |
)))) |
|
| 1282 |
# paste back togehter in the right order |
|
| 1283 | 92x |
paste(tmp.th1, tmp.th2, sep = "|t") |
| 1284 |
} else {
|
|
| 1285 | 5781x |
x |
| 1286 |
} |
|
| 1287 | 1018x |
}), use.names = FALSE) |
| 1288 |
} else {
|
|
| 1289 | ! |
out <- character(0L) |
| 1290 |
} |
|
| 1291 | 1018x |
return.value$th.mean[[b]] <- out |
| 1292 |
} |
|
| 1293 | ||
| 1294 |
# exogenous lv's |
|
| 1295 | 1018x |
if (any(c("lv.x", "lv.nox") %in% type)) {
|
| 1296 | 1018x |
tmp <- lv.names[!lv.names %in% c(v.ind, eqs.y)] |
| 1297 | 1018x |
lv.names.x <- lv.names[lv.names %in% tmp] |
| 1298 |
} |
|
| 1299 | ||
| 1300 | 1018x |
if (any("lv.x" == type)) {
|
| 1301 | 1018x |
return.value$lv.x[[b]] <- lv.names.x |
| 1302 |
} |
|
| 1303 | ||
| 1304 |
# dependent ov (but not also indicator or x) |
|
| 1305 | 1018x |
if (any("ov.y" == type)) {
|
| 1306 | 1018x |
tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x, lv.names)] |
| 1307 | 1018x |
return.value$ov.y[[b]] <- ov.names[ov.names %in% tmp] |
| 1308 |
} |
|
| 1309 | ||
| 1310 |
# dependent lv (but not also indicator or x) |
|
| 1311 | 1018x |
if (any("lv.y" == type)) {
|
| 1312 | 1018x |
tmp <- eqs.y[!eqs.y %in% c(v.ind, eqs.x) & |
| 1313 | 1018x |
eqs.y %in% lv.names] |
| 1314 | 1018x |
return.value$lv.y[[b]] <- lv.names[lv.names %in% tmp] |
| 1315 |
} |
|
| 1316 | ||
| 1317 |
# non-exogenous latent variables |
|
| 1318 | 1018x |
if (any("lv.nox" == type)) {
|
| 1319 | 1018x |
return.value$lv.nox[[b]] <- lv.names[!lv.names %in% lv.names.x] |
| 1320 |
} |
|
| 1321 | ||
| 1322 |
# marker indicator (if any) for each lv |
|
| 1323 | 1018x |
if (any("lv.marker" == type)) {
|
| 1324 |
# default: "" per lv |
|
| 1325 | 1018x |
out <- character(length(lv.names)) |
| 1326 | 1018x |
names(out) <- lv.names |
| 1327 | 1018x |
for (l in seq_len(length(lv.names))) {
|
| 1328 | 894x |
this.lv.name <- lv.names[l] |
| 1329 |
# try to see if we can find a 'marker' indicator for this factor |
|
| 1330 |
# here defined as: has a fixed-to-one factor loading |
|
| 1331 | 894x |
marker.idx <- which(block.ind & |
| 1332 | 894x |
partable$op == "=~" & |
| 1333 | 894x |
partable$lhs == this.lv.name & |
| 1334 | 894x |
partable$rhs %in% v.ind & |
| 1335 | 894x |
partable$ustart == 1L & |
| 1336 | 894x |
partable$free == 0L) |
| 1337 | 894x |
if (length(marker.idx) > 0L) {
|
| 1338 |
# we may have multiple potential markers |
|
| 1339 | 661x |
potential.markers <- partable$rhs[marker.idx] |
| 1340 | 661x |
valid.markers <- character(0L) |
| 1341 | 661x |
for (m in seq_along(potential.markers)) {
|
| 1342 | 743x |
this.marker.idx <- marker.idx[m] |
| 1343 |
# check if 'other' loadings are fixed to zero |
|
| 1344 | 743x |
other.idx <- which(block.ind & |
| 1345 | 743x |
partable$op == "=~" & |
| 1346 | 743x |
partable$lhs != this.lv.name & |
| 1347 | 743x |
partable$rhs == partable$rhs[this.marker.idx] & |
| 1348 | 743x |
partable$free == 0L) |
| 1349 | 743x |
if (length(other.idx) == 0L) {
|
| 1350 |
# simple structure, or one factor |
|
| 1351 | 727x |
valid.markers <- c(valid.markers, |
| 1352 | 727x |
partable$rhs[this.marker.idx]) |
| 1353 | 16x |
} else if (all(partable$ustart[other.idx] == 0)) {
|
| 1354 | 16x |
valid.markers <- c(valid.markers, |
| 1355 | 16x |
partable$rhs[this.marker.idx]) |
| 1356 |
} |
|
| 1357 |
} |
|
| 1358 | 661x |
if (length(valid.markers) > 0L) {
|
| 1359 | 661x |
out[l] <- valid.markers[1L] # pick the first one |
| 1360 |
} |
|
| 1361 |
} |
|
| 1362 |
} # l |
|
| 1363 | 1018x |
return.value$lv.marker[[b]] <- out |
| 1364 |
} |
|
| 1365 |
} |
|
| 1366 |
} # b |
|
| 1367 | ||
| 1368 |
# ----- lav_partable_vnames ---- no cache ------------------------ |
|
| 1369 |
# new in 0.6-14: if 'da' operator, change order! (for ov.order = "data") |
|
| 1370 |
# now via attribute "ovda" |
|
| 1371 | 1776x |
ov.names.data <- attr(partable, "ovda") |
| 1372 | 1776x |
if (!is.null(ov.names.data)) {
|
| 1373 | 19x |
return.value <- lapply(return.value, function(x) {
|
| 1374 | 338x |
for (b in seq_len(length(x))) {
|
| 1375 | 612x |
m <- match(x[[b]], ov.names.data) |
| 1376 | 612x |
target.idx <- which(!is.na(m)) |
| 1377 | 612x |
if (length(target.idx) > 1L) {
|
| 1378 | 142x |
x[[b]][target.idx] <- x[[b]][target.idx][order(m[target.idx])] |
| 1379 |
} |
|
| 1380 |
} |
|
| 1381 | 338x |
x |
| 1382 |
}) |
|
| 1383 |
} |
|
| 1384 |
} |
|
| 1385 |
# ----- lav_partable_vnames ---- common ------ 1 type -------- |
|
| 1386 |
# to mimic old behaviour, if length(type) == 1L |
|
| 1387 | 15721x |
if (length(type) == 1L) {
|
| 1388 | 14820x |
return.value <- return.value[[type]] |
| 1389 |
# to mimic old behaviour, if specific block is requested |
|
| 1390 | 14820x |
if (ndotdotdot == 0L) {
|
| 1391 | 2966x |
if (type == "lv.marker") {
|
| 1392 | ! |
return.value <- unlist(return.value) |
| 1393 |
# no unique(), as unique() drops attributes, and reduces |
|
| 1394 |
# c("", "", "") to a single ""
|
|
| 1395 |
# (but, say for 2 groups, you get 2 copies) |
|
| 1396 |
# as this is only for 'display', we leave it like that |
|
| 1397 |
} else {
|
|
| 1398 | 2966x |
return.value <- unique(unlist(return.value)) |
| 1399 |
} |
|
| 1400 | 11854x |
} else if (length(block.select) == 1L) {
|
| 1401 | 11738x |
return.value <- return.value[[block.select]] |
| 1402 |
} else {
|
|
| 1403 | 116x |
return.value <- return.value[block.select] |
| 1404 |
} |
|
| 1405 |
} |
|
| 1406 |
# ----- lav_partable_vnames ---- common ------------------------ |
|
| 1407 | 15721x |
return.value |
| 1408 |
} |
| 1 |
# find ALL (eligible) *model-implied* instrumental variables (no pruning yet) |
|
| 2 |
# |
|
| 3 |
# three algorithms: |
|
| 4 |
# 1) using 'total effects' of errors/disturbances, based on Bollen & Bauer |
|
| 5 |
# (2004) [algorithm = "bb2004"] |
|
| 6 |
# 2) treating errors/disturbances as latent variables (as in the |
|
| 7 |
# comprehensive RAM model); similar to miivs() in MIIVsem package |
|
| 8 |
# [algorithm = "miivsem"] |
|
| 9 |
# 3) using an explicity expression (due to Albert Maydeu-Olivares) for |
|
| 10 |
# cov(u,y) [algorithm = "covuy"] (the default) |
|
| 11 |
# |
|
| 12 |
# YR 29 Dec 2025 - first version (bb2004 + miivsem) |
|
| 13 |
# YR 24 Jan 2025 - covuy algorithm (including higher-order factors) |
|
| 14 | ||
| 15 |
lav_model_find_iv <- function(lavobject = NULL, lavmodel = NULL, |
|
| 16 |
lavpta = NULL, algorithm = "covuy", |
|
| 17 |
output = "list", drop.list.single.group = FALSE) {
|
|
| 18 |
# check output |
|
| 19 | ! |
output <- tolower(output) |
| 20 | ! |
stopifnot(output %in% c("list", "table"))
|
| 21 | ||
| 22 |
# lavobject or components? |
|
| 23 | ! |
if (!is.null(lavobject)) {
|
| 24 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 25 | ! |
lavpta <- lavobject@pta |
| 26 | ! |
lavmodel <- lavobject@Model |
| 27 |
} |
|
| 28 | ||
| 29 |
# sanity checks |
|
| 30 | ! |
nblocks <- lavpta$nblocks |
| 31 | ! |
for (b in seq_len(nblocks)) {
|
| 32 | ! |
lv.idx <- lavpta$vidx$lv.regular[[b]] |
| 33 | ! |
lv.marker <- lavpta$vnames$lv.marker[[b]] |
| 34 | ! |
if (length(lv.idx) > 0L) {
|
| 35 |
# do have 'clear' marker/scaling indicators? |
|
| 36 | ! |
empty.idx <- which(nchar(lv.marker) == 0L) |
| 37 | ! |
if (length(empty.idx) > 0L) {
|
| 38 | ! |
tmp_string <- paste(names(lv.marker)[empty.idx], collapse = " ") |
| 39 | ! |
lav_msg_stop(gettextf("no clear marker/scaling indicator found for
|
| 40 | ! |
factor(s): %s", tmp_string)) |
| 41 |
} |
|
| 42 |
# marker/scaling indicator cannot be a dependent variable in an ~ equation |
|
| 43 | ! |
badmarker.idx <- which(lv.marker %in% lavpta$vnames$eqs.y[[b]]) |
| 44 | ! |
if (length(badmarker.idx) > 0L) {
|
| 45 | ! |
tmp_string <- paste(lv.marker[badmarker.idx], collapse = " ") |
| 46 | ! |
lav_msg_stop(gettextf("marker/scaling indicator cannot be a dependent
|
| 47 | ! |
variable in a regression: %s", tmp_string)) |
| 48 |
} |
|
| 49 |
} |
|
| 50 |
} |
|
| 51 | ||
| 52 | ! |
algorithm <- tolower(algorithm) |
| 53 | ! |
if (algorithm == "bb2004") {
|
| 54 | ! |
iv_list <- lav_model_find_iv_bb2004(lavmodel = lavmodel, lavpta = lavpta) |
| 55 | ! |
} else if (algorithm == "miivsem") {
|
| 56 | ! |
iv_list <- lav_model_find_iv_miivsem(lavmodel = lavmodel, lavpta = lavpta) |
| 57 |
} else {
|
|
| 58 | ! |
iv_list <- lav_model_find_iv_covuy(lavmodel = lavmodel, lavpta = lavpta) |
| 59 |
} |
|
| 60 | ||
| 61 | ! |
if (output == "table") {
|
| 62 | ! |
table <- vector("list", length = nblocks)
|
| 63 | ! |
for (b in seq_len(nblocks)) {
|
| 64 | ! |
eqs <- iv_list[[b]] |
| 65 | ! |
lhs <- sapply(eqs, "[[", "lhs") |
| 66 | ! |
rhs <- sapply(lapply(eqs, "[[", "rhs"), paste, collapse = " + ") |
| 67 | ! |
lhs_new <- sapply(eqs, "[[", "lhs_new") |
| 68 | ! |
rhs_new <- sapply(lapply(eqs, "[[", "rhs_new"), paste, collapse = " + ") |
| 69 | ! |
miiv <- sapply(lapply(eqs, "[[", "miiv"), paste, collapse = ", ") |
| 70 | ! |
table[[b]] <- data.frame( |
| 71 | ! |
lhs = lhs, rhs = rhs, |
| 72 | ! |
lhs_new = lhs_new, rhs_new = rhs_new, miiv = miiv |
| 73 |
) |
|
| 74 | ! |
class(table[[b]]) <- c("lavaan.data.frame", "data.frame")
|
| 75 |
} |
|
| 76 | ! |
out <- table |
| 77 |
} else {
|
|
| 78 | ! |
out <- iv_list |
| 79 |
} |
|
| 80 | ||
| 81 | ! |
if (nblocks == 1L && drop.list.single.group) {
|
| 82 | ! |
out <- out[[1]] |
| 83 |
} |
|
| 84 | ||
| 85 | ! |
out |
| 86 |
} |
|
| 87 | ||
| 88 | ||
| 89 |
# algorithm 1: |
|
| 90 |
# loosely based on Bollen & Bauer (2004), but with support for higher-order |
|
| 91 |
# factors |
|
| 92 |
lav_model_find_iv_bb2004 <- function(lavmodel = NULL, lavpta = NULL) {
|
|
| 93 |
# check representation |
|
| 94 | ! |
if (lavmodel@representation != "LISREL") {
|
| 95 | ! |
lav_msg_stop(gettext( |
| 96 | ! |
"this function only works with LISREL representation", |
| 97 | ! |
" (for now)" |
| 98 |
)) |
|
| 99 |
} |
|
| 100 | ||
| 101 |
# create model matrices with 'user/partable' entries |
|
| 102 | ! |
glist <- lavmodel@GLIST |
| 103 | ! |
for (mm in seq_along(glist)) {
|
| 104 | ! |
dimnames(glist[[mm]]) <- lavmodel@dimNames[[mm]] |
| 105 | ! |
m.idx <- lavmodel@m.user.idx[[mm]] |
| 106 | ! |
x.idx <- lavmodel@x.user.idx[[mm]] |
| 107 | ! |
glist[[mm]][, ] <- 0.0 |
| 108 | ! |
glist[[mm]][m.idx] <- x.idx |
| 109 |
} |
|
| 110 | ||
| 111 |
# number of blocks |
|
| 112 | ! |
nblocks <- lavpta$nblocks |
| 113 | ! |
lambda.idx <- which(names(glist) == "lambda") |
| 114 | ! |
beta.idx <- which(names(glist) == "beta") |
| 115 | ! |
psi.idx <- which(names(glist) == "psi") |
| 116 | ! |
theta.idx <- which(names(glist) == "theta") |
| 117 | ! |
if (lavmodel@meanstructure) {
|
| 118 | ! |
nu.idx <- which(names(glist) == "nu") |
| 119 | ! |
alpha.idx <- which(names(glist) == "alpha") |
| 120 |
} |
|
| 121 | ||
| 122 |
# repeat for every block |
|
| 123 | ! |
iv_list <- vector("list", length = nblocks)
|
| 124 | ! |
for (b in seq_len(nblocks)) {
|
| 125 |
# extract information to create Bollen & Bauer (2004) matrices |
|
| 126 | ! |
ov.names <- lavpta$vnames$ov[[b]] |
| 127 | ! |
nvar <- length(ov.names) |
| 128 | ! |
lv.names <- lavpta$vnames$lv.regular[[b]] |
| 129 | ! |
lv.marker <- lavpta$vnames$lv.marker[[b]] |
| 130 | ! |
lv.marker.orig <- lavpta$vnames$lv.marker[[b]] |
| 131 | ! |
lv.ho <- lavpta$vnames$lv.ho[[b]] |
| 132 | ||
| 133 | ! |
lv.idx <- lavpta$vidx$lv.regular[[b]] |
| 134 | ! |
lv.x.idx <- lavpta$vidx$lv.x[[b]] |
| 135 | ! |
lv.marker.idx <- lavpta$vidx$lv.marker[[b]] |
| 136 | ||
| 137 |
# dummy y? |
|
| 138 | ! |
if (length(lavmodel@ov.y.dummy.ov.idx[[b]]) > 0L) {
|
| 139 | ! |
lv.idx <- c(lv.idx, lavmodel@ov.y.dummy.lv.idx[[b]]) |
| 140 | ! |
lv.marker <- c(lv.marker.orig, ov.names[lavmodel@ov.y.dummy.ov.idx[[b]]]) |
| 141 | ! |
names(lv.marker) <- c( |
| 142 | ! |
names(lv.marker.orig), |
| 143 | ! |
ov.names[lavmodel@ov.y.dummy.ov.idx[[b]]] |
| 144 |
) |
|
| 145 | ! |
lv.marker.idx <- c(lv.marker.idx, lavmodel@ov.y.dummy.ov.idx[[b]]) |
| 146 |
} |
|
| 147 | ||
| 148 |
# keep track of higher order factors |
|
| 149 | ! |
lv.ho.idx <- which(is.na(lv.marker.idx)) # same as lavpta$vidx$lv.ho |
| 150 | ! |
if (length(lv.ho.idx) > 0L) {
|
| 151 | ! |
lv_in_marker <- lv.marker[lv.marker %in% lv.names] |
| 152 | ! |
while (length(lv_in_marker) > 0L) {
|
| 153 | ! |
new_markers <- unname(lv.marker[lv_in_marker]) |
| 154 | ! |
lv.marker[match(lv_in_marker, lv.marker)] <- new_markers |
| 155 | ! |
lv_in_marker <- lv.marker[lv.marker %in% lv.names] |
| 156 |
} |
|
| 157 | ! |
lv.marker.idx <- match(lv.marker, ov.names) |
| 158 |
} |
|
| 159 | ||
| 160 |
# model matrices for this block |
|
| 161 | ! |
lambda <- glist[[lambda.idx[b]]] |
| 162 | ! |
beta <- glist[[beta.idx[b]]] |
| 163 | ! |
theta <- glist[[theta.idx[b]]] |
| 164 | ! |
psi <- glist[[psi.idx[b]]] |
| 165 | ! |
if (lavmodel@meanstructure) {
|
| 166 | ! |
nu <- glist[[nu.idx[b]]] |
| 167 | ! |
alpha <- glist[[alpha.idx[b]]] |
| 168 |
} |
|
| 169 | ! |
if (is.null(beta)) {
|
| 170 | ! |
beta <- matrix(0, ncol(lambda), ncol(lambda)) |
| 171 | ! |
colnames(beta) <- rownames(beta) <- colnames(lambda) |
| 172 |
} |
|
| 173 | ||
| 174 |
# binary model matrices: nonzero = 1, zero = 0 |
|
| 175 | ! |
if (length(lv.idx) == 0L) {
|
| 176 | ! |
lambda_bin <- diag(nrow = ncol(lambda)) |
| 177 |
} else {
|
|
| 178 | ! |
lambda_bin <- (lambda != 0) * 1L |
| 179 |
} |
|
| 180 | ! |
beta_bin <- (beta != 0) * 1L |
| 181 | ! |
ibinv <- solve(diag(nrow(beta_bin)) - beta_bin) |
| 182 | ! |
ibinv_bin <- (ibinv != 0) * 1L |
| 183 | ||
| 184 |
# construct pred |
|
| 185 | ! |
if (length(lv.idx) > 0L) {
|
| 186 | ! |
reg_bin <- rbind(lambda_bin, beta_bin) |
| 187 | ! |
pred_orig <- rbind(lambda, beta) |
| 188 | ! |
if (lavmodel@meanstructure) {
|
| 189 | ! |
int_orig <- rbind(nu, alpha) |
| 190 |
} |
|
| 191 |
} else {
|
|
| 192 | ! |
reg_bin <- beta_bin |
| 193 | ! |
pred_orig <- beta |
| 194 | ! |
if (lavmodel@meanstructure) {
|
| 195 | ! |
int_orig <- alpha |
| 196 |
} |
|
| 197 |
} |
|
| 198 | ! |
pred.idx <- numeric(ncol(reg_bin)) |
| 199 | ! |
if (length(lv.marker.idx) > 0L) {
|
| 200 | ! |
pred.idx[lv.idx] <- lv.marker.idx |
| 201 |
} |
|
| 202 | ! |
if (length(lavmodel@ov.x.dummy.ov.idx[[b]]) > 0L) {
|
| 203 | ! |
pred.idx[lavmodel@ov.x.dummy.lv.idx[[b]]] <- |
| 204 | ! |
lavmodel@ov.x.dummy.ov.idx[[b]] |
| 205 |
} |
|
| 206 | ! |
if (length(lavmodel@ov.y.dummy.ov.idx[[b]]) > 0L) {
|
| 207 | ! |
pred.idx[lavmodel@ov.y.dummy.lv.idx[[b]]] <- |
| 208 | ! |
lavmodel@ov.y.dummy.ov.idx[[b]] |
| 209 |
} |
|
| 210 | ! |
tmp <- t(t(reg_bin) * pred.idx) |
| 211 |
# remove scaling '1' for markers (if any) |
|
| 212 | ! |
if (length(lv.marker.idx) > 0L) {
|
| 213 | ! |
row.idx <- match(lv.marker.orig, rownames(tmp)) |
| 214 | ! |
col.idx <- match(names(lv.marker.orig), colnames(tmp)) |
| 215 | ! |
tmp[cbind(row.idx, col.idx)] <- 0L |
| 216 |
} |
|
| 217 |
# keep only the 'ov' part |
|
| 218 | ! |
pred <- tmp[seq_along(ov.names), , drop = FALSE] |
| 219 |
# replace marker rows, with beta entries of their corresponding lv's |
|
| 220 |
# dummy y + regular lv's |
|
| 221 | ! |
if (length(lv.idx) > 0L && !is.null(beta)) {
|
| 222 | ! |
tmp_lv <- tmp_lv2 <- tmp[length(ov.names) + lv.idx, , drop = FALSE] |
| 223 | ! |
orig_lv <- pred_orig[length(ov.names) + lv.idx, , drop = FALSE] |
| 224 | ! |
if (lavmodel@meanstructure) {
|
| 225 | ! |
int_lv <- int_orig[length(ov.names) + lv.idx, , drop = FALSE] |
| 226 | ! |
tmp_lv2 <- cbind(int_lv, tmp_lv) |
| 227 |
} |
|
| 228 | ||
| 229 |
# tmp[lv.marker.idx, ] <- tmp[length(ov.names) + lv.idx, ] |
|
| 230 |
# careful, lv.marker.idx may contain the same element multiple times! |
|
| 231 | ! |
zerolv.idx <- which(apply(tmp_lv2, 1, function(x) all(x == 0))) |
| 232 | ! |
if (length(zerolv.idx) > 0L) {
|
| 233 | ! |
tmp_lv <- tmp_lv[-zerolv.idx, , drop = FALSE] |
| 234 | ! |
orig_lv <- orig_lv[-zerolv.idx, , drop = FALSE] |
| 235 | ! |
if (lavmodel@meanstructure) {
|
| 236 | ! |
int_lv <- int_lv[-zerolv.idx, , drop = FALSE] |
| 237 |
} |
|
| 238 |
} |
|
| 239 | ! |
r.idx <- match(lv.marker[rownames(tmp_lv)], rownames(pred)) |
| 240 | ! |
pred[r.idx, ] <- tmp_lv |
| 241 | ! |
pred_orig[r.idx, ] <- orig_lv |
| 242 | ! |
rownames(pred_orig)[r.idx] <- rownames(tmp_lv) |
| 243 | ! |
pred_orig <- pred_orig[1:nvar, , drop = FALSE] |
| 244 | ! |
if (lavmodel@meanstructure) {
|
| 245 | ! |
int_orig[r.idx, ] <- int_lv |
| 246 |
# also exogenous ov's! |
|
| 247 | ! |
lv.x.dummy.idx <- lavmodel@ov.x.dummy.lv.idx[[b]] |
| 248 | ! |
if (length(lv.x.dummy.idx) > 0L) {
|
| 249 | ! |
int_orig[lavmodel@ov.x.dummy.ov.idx[[b]],1] <- alpha[lv.x.dummy.idx,1] |
| 250 |
} |
|
| 251 | ! |
rownames(int_orig)[r.idx] <- rownames(int_lv) |
| 252 | ! |
int_orig <- int_orig[1:nvar, , drop = FALSE] |
| 253 |
} |
|
| 254 |
} |
|
| 255 |
# non-zero entries of 'pred' contain the marker idx of the latent |
|
| 256 |
# predictors (and perhaps the dummy ov indices) |
|
| 257 | ||
| 258 |
# construct comp (composite error term) |
|
| 259 |
# - for each dependent: the corresponding element in Theta/Psi (y_res) |
|
| 260 |
# - for each (latent) predictor: the corresponding *marker* element in |
|
| 261 |
# Theta (x_res) |
|
| 262 |
# - for the markers: the disturbance (psi) of the corresponding |
|
| 263 |
# lv's (included in x_res) |
|
| 264 |
# - for higher-order factors: the disturbance (psi) of their 'marker' |
|
| 265 |
# factor |
|
| 266 | ! |
y_res <- diag(theta) |
| 267 | ! |
if (length(lv.marker.idx) > 0L) {
|
| 268 | ! |
x_res <- pred |
| 269 |
# x_res[pred != 0] <- y_res[as.vector(pred[pred != 0])] |
|
| 270 | ! |
x_res[pred != 0] <- y_res[pred] |
| 271 | ! |
x_res[cbind(lv.marker.idx, seq_along(lv.idx))] <- diag(psi)[lv.idx] |
| 272 | ! |
if (length(lv.ho.idx) > 0L) {
|
| 273 |
# higher-order factors: what are their indicators? |
|
| 274 |
# add diag(psi) value in this row |
|
| 275 | ! |
x_res <- t(apply(x_res, 1, function(x) {
|
| 276 | ! |
res <- x |
| 277 | ! |
hof <- x[lv.ho.idx] |
| 278 | ! |
hof_nonzero <- hof[hof != 0] |
| 279 | ! |
if (length(hof_nonzero) > 0L) {
|
| 280 |
# keep going until we only have first-order factors (or ovs) |
|
| 281 | ! |
target <- unname(lv.marker.orig[names(hof_nonzero)]) |
| 282 | ! |
ho_in_target <- target[target %in% lv.ho] |
| 283 | ! |
while (length(ho_in_target) > 0L) {
|
| 284 | ! |
new <- unname(lv.marker.orig[ho_in_target]) |
| 285 | ! |
target <- c(target, new) |
| 286 | ! |
ho_in_target <- new[new %in% lv.ho] |
| 287 |
} |
|
| 288 | ||
| 289 | ! |
if (length(target)) {
|
| 290 | ! |
res[target] <- diag(psi)[target] |
| 291 |
} |
|
| 292 |
} |
|
| 293 | ! |
res |
| 294 |
})) |
|
| 295 |
} |
|
| 296 |
# comp <- cbind(y_res, x_res)[1:nvar, ] |
|
| 297 | ! |
comp <- cbind(y_res, x_res) |
| 298 |
} else {
|
|
| 299 |
# no latent variables |
|
| 300 | ! |
comp <- cbind(y_res) |
| 301 |
} |
|
| 302 | ||
| 303 |
# construct total: total effects of errors/disturbances on |
|
| 304 |
# EACH observed variable in the model |
|
| 305 |
# - direct effect of 'epsilon': diag(theta) |
|
| 306 |
# - total effect of 'disturbance': Lambda %*% (I - Beta)^{-1}
|
|
| 307 | ! |
lv_res <- diag(psi) |
| 308 | ! |
lv_res[lv.x.idx] <- 0 # remove 'total/exo' variances from psi |
| 309 | ! |
y_res <- diag(theta) |
| 310 | ! |
t_res <- t(t(lambda_bin %*% ibinv_bin) * lv_res) |
| 311 | ! |
total <- cbind(y_res, t_res) |
| 312 | ||
| 313 |
# construct piv (potential ivs): |
|
| 314 |
# initial set of potential instruments for each equation, by selecting |
|
| 315 |
# observed variables that are unaffected by the disturbances or |
|
| 316 |
# uniquenesses in that equation |
|
| 317 | ! |
piv <- matrix(1:nvar, nrow = nvar, ncol = nvar, byrow = TRUE) |
| 318 | ! |
colnames(piv) <- rownames(piv) <- ov.names |
| 319 | ! |
for (i in 1:nvar) {
|
| 320 | ! |
res_id <- unique(comp[i, comp[i, ] != 0]) |
| 321 | ! |
tmp <- apply(total, 2, function(x) !x %in% res_id) |
| 322 | ! |
rm.idx <- which(!apply(tmp, 1, all)) |
| 323 | ! |
piv[i, rm.idx] <- 0 |
| 324 |
} |
|
| 325 |
# diagonal must be zero (not needed, but just to be safe) |
|
| 326 | ! |
diag(piv) <- 0 |
| 327 |
# ov.y -> zero column |
|
| 328 | ! |
if (length(lavpta$vidx$ov.y[[b]]) > 0L) {
|
| 329 | ! |
piv[, lavpta$vidx$ov.y[[b]]] <- 0 |
| 330 |
} |
|
| 331 |
# ov.x -> zero row |
|
| 332 | ! |
if (length(lavpta$vidx$ov.x[[b]]) > 0L) {
|
| 333 | ! |
piv[lavpta$vidx$ov.x[[b]], ] <- 0 |
| 334 |
} |
|
| 335 | ||
| 336 | ||
| 337 |
# construct iv |
|
| 338 |
# Starting from piv, remove any potential ivs that are affected by a |
|
| 339 |
# disturbance that correlates with any disturbance in the composite |
|
| 340 |
# disturbance term |
|
| 341 | ! |
iv <- piv |
| 342 | ! |
for (i in 1:nvar) {
|
| 343 |
# check if we need instruments at all |
|
| 344 | ! |
rhs <- pred[i, pred[i, ] != 0, drop = FALSE] |
| 345 | ! |
if (length(rhs) > 0L && all(comp[i, colnames(rhs)] == 0)) {
|
| 346 |
# no instruments needed |
|
| 347 | ! |
iv[i, -rhs] <- 0 |
| 348 |
} else {
|
|
| 349 | ! |
for (p in 1:nvar) {
|
| 350 |
# do check for this iv, if false, set to zero |
|
| 351 | ! |
comp.idx <- which(y_res %in% comp[i, ]) |
| 352 | ! |
total.idx <- which(y_res %in% total[piv[i, p], ]) |
| 353 | ! |
cov_values <- theta[as.matrix(expand.grid(comp.idx, total.idx))] |
| 354 | ! |
if (any(cov_values != 0)) {
|
| 355 | ! |
iv[i, p] <- 0 |
| 356 |
} |
|
| 357 |
} |
|
| 358 |
} # instruments needed |
|
| 359 |
} |
|
| 360 | ||
| 361 |
# add intercepts here |
|
| 362 | ! |
if (lavmodel@meanstructure) {
|
| 363 | ! |
colnames(int_orig) <- "1" |
| 364 | ! |
pred <- cbind(int_orig, pred) |
| 365 | ! |
pred_orig <- cbind(int_orig, pred_orig) |
| 366 | ||
| 367 | ! |
idx <- match(names(lv.marker), rownames(pred)) |
| 368 | ! |
rownames(pred)[idx] <- lv.marker |
| 369 |
} |
|
| 370 | ||
| 371 |
# remove 'empty' rows |
|
| 372 | ! |
empty.idx <- which(apply(pred, 1L, function(x) all(x == 0)) & |
| 373 | ! |
rownames(pred) %in% ov.names) |
| 374 | ! |
if (length(empty.idx) > 0L) {
|
| 375 | ! |
iv <- iv[-empty.idx, , drop = FALSE] |
| 376 | ! |
comp <- comp[-empty.idx, , drop = FALSE] |
| 377 | ! |
pred <- pred[-empty.idx, , drop = FALSE] |
| 378 | ! |
pred_orig <- pred_orig[-empty.idx, , drop = FALSE] |
| 379 | ! |
if (lavmodel@meanstructure) {
|
| 380 | ! |
int_orig <- int_orig[-empty.idx, , drop = FALSE] |
| 381 |
} |
|
| 382 |
} |
|
| 383 |
# replace row/colnames of pred by marker names |
|
| 384 | ! |
idx <- match(names(lv.marker), colnames(pred)) |
| 385 | ! |
colnames(pred)[idx] <- lv.marker |
| 386 | ||
| 387 |
# prepare list |
|
| 388 | ! |
eqs <- vector("list", length = nrow(iv))
|
| 389 | ! |
for (j in seq_along(eqs)) {
|
| 390 | ! |
cet <- colnames(comp)[which(comp[j, ] != 0)] |
| 391 | ! |
x.idx <- which(pred[j, ] != 0) |
| 392 | ! |
ptint <- integer(0L) |
| 393 | ! |
if (lavmodel@meanstructure) {
|
| 394 | ! |
x.idx <- x.idx[-1] |
| 395 | ! |
ptint <- unname(pred_orig[j, 1]) |
| 396 |
} |
|
| 397 | ! |
if (lavmodel@meanstructure && length(x.idx) == 0L) {
|
| 398 | ! |
rhs_new <- "1" |
| 399 | ! |
rhs <- "1" |
| 400 | ! |
miiv <- "1" |
| 401 |
} else {
|
|
| 402 | ! |
rhs_new <- colnames(pred[j, x.idx, drop = FALSE]) |
| 403 | ! |
rhs <- colnames(pred_orig[j, x.idx, drop = FALSE]) |
| 404 | ! |
miiv <- colnames(iv[j, iv[j, ] != 0, drop = FALSE]) |
| 405 |
} |
|
| 406 | ! |
eqs[[j]] <- list( |
| 407 | ! |
lhs_new = rownames(pred)[j], |
| 408 | ! |
rhs_new = rhs_new, |
| 409 | ! |
lhs = rownames(pred_orig)[j], |
| 410 | ! |
rhs = rhs, |
| 411 | ! |
pt = unname(pred_orig[j, x.idx]), |
| 412 | ! |
ptint = ptint, |
| 413 | ! |
cet = cet, |
| 414 | ! |
markers = unique(lv.marker[cet[-1]]), |
| 415 | ! |
miiv = miiv |
| 416 |
) |
|
| 417 |
} |
|
| 418 | ||
| 419 |
# reorder so that ov lhs come first, then lv lhs |
|
| 420 | ! |
lhs <- sapply(eqs, "[[", "lhs") |
| 421 | ! |
ov.idx <- match(ov.names[ov.names %in% lhs], lhs) |
| 422 | ! |
lv.idx <- seq_along(lhs)[-ov.idx] |
| 423 | ! |
eqs <- eqs[c(ov.idx, lv.idx)] |
| 424 | ||
| 425 | ! |
iv_list[[b]] <- eqs |
| 426 |
} # blocks |
|
| 427 | ||
| 428 | ! |
iv_list |
| 429 |
} |
|
| 430 | ||
| 431 |
# algorithm 2: create a model where error/disturbance terms are latent |
|
| 432 |
# variables (a bit like the comprehensive RAM representation) |
|
| 433 |
# and compute 'big_sigma': |
|
| 434 |
# - to identify ov's that are uncorrelated with the errors in |
|
| 435 |
# the composite error term |
|
| 436 |
# - to identify ov's that are correlated with at least one |
|
| 437 |
# marker |
|
| 438 |
# the intersection give the (full list of) miivs |
|
| 439 |
# |
|
| 440 |
# the implementation below is loosely based on (but not identical to) the |
|
| 441 |
# 'miivs()' function from the MIIVsem package |
|
| 442 |
# |
|
| 443 |
lav_model_find_iv_miivsem <- function(lavmodel = NULL, lavpta = NULL) {
|
|
| 444 |
# check representation |
|
| 445 | ! |
if (lavmodel@representation != "LISREL") {
|
| 446 | ! |
lav_msg_stop(gettext( |
| 447 | ! |
"this function only works with LISREL representation", |
| 448 | ! |
" (for now)" |
| 449 |
)) |
|
| 450 |
} |
|
| 451 | ||
| 452 |
# create model matrices with 'user/partable' entries |
|
| 453 | ! |
glist <- lavmodel@GLIST |
| 454 | ! |
for (mm in seq_along(glist)) {
|
| 455 | ! |
dimnames(glist[[mm]]) <- lavmodel@dimNames[[mm]] |
| 456 | ! |
m.idx <- lavmodel@m.user.idx[[mm]] |
| 457 | ! |
x.idx <- lavmodel@x.user.idx[[mm]] |
| 458 | ! |
glist[[mm]][, ] <- 0.0 |
| 459 | ! |
glist[[mm]][m.idx] <- x.idx |
| 460 |
} |
|
| 461 | ! |
lambda.idx <- which(names(glist) == "lambda") |
| 462 | ! |
beta.idx <- which(names(glist) == "beta") |
| 463 | ! |
psi.idx <- which(names(glist) == "psi") |
| 464 | ! |
theta.idx <- which(names(glist) == "theta") |
| 465 | ! |
if (lavmodel@meanstructure) {
|
| 466 | ! |
nu.idx <- which(names(glist) == "nu") |
| 467 | ! |
alpha.idx <- which(names(glist) == "alpha") |
| 468 |
} |
|
| 469 | ||
| 470 |
# nblocks |
|
| 471 | ! |
nblocks <- lavmodel@nblocks |
| 472 | ||
| 473 |
# repeat for every block |
|
| 474 | ! |
iv_list <- vector("list", length = nblocks)
|
| 475 | ! |
for (b in seq_len(nblocks)) {
|
| 476 | ! |
lv.names <- lavpta$vnames$lv.regular[[b]] |
| 477 | ! |
ov.names <- lavpta$vnames$ov[[b]] |
| 478 | ! |
lv.marker <- lavpta$vnames$lv.marker[[b]] |
| 479 | ||
| 480 |
# model matrices for this block |
|
| 481 | ! |
lambda <- glist[[lambda.idx[b]]] |
| 482 | ! |
beta <- glist[[beta.idx[b]]] |
| 483 | ! |
theta <- glist[[theta.idx[b]]] |
| 484 | ! |
psi <- glist[[psi.idx[b]]] |
| 485 | ! |
if (lavmodel@meanstructure) {
|
| 486 | ! |
nu <- glist[[nu.idx[b]]] |
| 487 | ! |
alpha <- glist[[alpha.idx[b]]] |
| 488 |
} |
|
| 489 | ||
| 490 | ||
| 491 |
# 'exogenous' variables (in beta/psi) (including dummy ov's) |
|
| 492 | ! |
if (is.null(beta)) {
|
| 493 | ! |
lv.x.idx <- lavpta$vidx$lv.x[[b]] |
| 494 |
} else {
|
|
| 495 | ! |
lv.x.idx <- which(apply(beta, 1L, function(x) all(x == 0))) |
| 496 |
} |
|
| 497 | ||
| 498 |
# lambda+beta |
|
| 499 | ! |
if (is.null(beta)) {
|
| 500 | ! |
beta <- matrix(0, ncol(lambda), ncol(lambda)) |
| 501 |
} |
|
| 502 | ! |
lambda_beta <- rbind(lambda, beta) |
| 503 | ! |
pred_orig <- lambda_beta |
| 504 | ! |
lambda_beta[lambda_beta != 0] <- as.numeric(NA) |
| 505 |
# add markers |
|
| 506 | ! |
row.idx <- match(lavpta$vnames$lv.marker[[b]], rownames(lambda_beta)) |
| 507 | ! |
col.idx <- match(names(lavpta$vnames$lv.marker[[b]]), colnames(lambda_beta)) |
| 508 | ! |
lambda_beta[cbind(row.idx, col.idx)] <- 1 |
| 509 | ! |
pred <- lambda_beta |
| 510 | ! |
pred_orig_full <- pred_orig |
| 511 | ! |
empty.idx <- which(apply(lambda_beta, 1L, function(x) all(x == 0))) |
| 512 | ! |
if (length(empty.idx) > 0) {
|
| 513 | ! |
lambda_beta <- lambda_beta[-empty.idx, , drop = FALSE] |
| 514 | ! |
pred_orig <- pred_orig[-empty.idx, , drop = FALSE] |
| 515 |
} |
|
| 516 | ||
| 517 |
# error + zero matrix, to create gamma and beta |
|
| 518 | ! |
error_matrix <- diag(nrow = nrow(lambda_beta)) |
| 519 | ! |
rownames(error_matrix) <- rownames(lambda_beta) |
| 520 | ! |
colnames(error_matrix) <- paste("e.", rownames(lambda_beta), sep = "")
|
| 521 | ! |
zero_matrix <- error_matrix * 0 |
| 522 | ! |
colnames(zero_matrix) <- rownames(lambda_beta) |
| 523 | ||
| 524 |
# construct gamma |
|
| 525 | ! |
gamma <- cbind( |
| 526 | ! |
lambda_beta[, lv.x.idx, drop = FALSE], |
| 527 | ! |
error_matrix |
| 528 |
) |
|
| 529 | ! |
gamma_orig <- cbind( |
| 530 | ! |
pred_orig[, lv.x.idx, drop = FALSE], |
| 531 | ! |
error_matrix |
| 532 |
) |
|
| 533 | ||
| 534 |
# construct beta |
|
| 535 | ! |
beta <- beta_orig <- zero_matrix |
| 536 | ! |
tmp <- lambda_beta[, -lv.x.idx, drop = FALSE] |
| 537 | ! |
beta[, colnames(tmp)] <- tmp |
| 538 | ! |
tmp <- pred_orig[, -lv.x.idx, drop = FALSE] |
| 539 | ! |
beta_orig[, colnames(tmp)] <- tmp |
| 540 | ||
| 541 |
# construct Phi |
|
| 542 | ! |
Phi <- lav_matrix_bdiag( |
| 543 | ! |
psi[lv.x.idx, lv.x.idx, drop = FALSE], |
| 544 | ! |
theta, |
| 545 | ! |
psi[-lv.x.idx, -lv.x.idx, drop = FALSE] |
| 546 |
) |
|
| 547 | ! |
empty.idx <- which(apply(Phi, 1L, function(x) all(x == 0))) |
| 548 | ! |
if (length(empty.idx) > 0) {
|
| 549 | ! |
Phi <- Phi[-empty.idx, -empty.idx, drop = FALSE] |
| 550 |
} |
|
| 551 | ! |
colnames(Phi) <- rownames(Phi) <- colnames(gamma) |
| 552 | ! |
Phi[Phi != 0] <- as.numeric(NA) |
| 553 | ||
| 554 | ! |
tmp <- crossprod(gamma) |
| 555 | ! |
tmp[, ] <- 0 |
| 556 | ! |
Beta <- lav_matrix_bdiag(beta, tmp) |
| 557 | ! |
I <- diag(nrow(Beta)) |
| 558 | ! |
diag(tmp) <- 1 |
| 559 | ! |
Gamma <- rbind(gamma, tmp) |
| 560 | ||
| 561 |
# to compute big_sigma, we can replace NA by 1 |
|
| 562 | ! |
Beta[is.na(Beta)] <- 1 |
| 563 | ! |
Gamma[is.na(Gamma)] <- 1 |
| 564 | ! |
Phi[is.na(Phi)] <- 1 |
| 565 | ! |
ib_inv <- solve(I - Beta) |
| 566 | ! |
big_sigma <- ib_inv %*% Gamma %*% Phi %*% t(Gamma) %*% t(ib_inv) |
| 567 | ! |
sigma_ov <- big_sigma[ov.names, , drop = FALSE] # only rows with ov.names |
| 568 | ! |
e_names <- colnames(gamma)[grep("e\\.", colnames(gamma))]
|
| 569 | ||
| 570 | ||
| 571 |
# matrix of all regressions (nothing has been removed yet, here) |
|
| 572 | ! |
gamma_beta <- pred |
| 573 | ! |
gamma_beta_orig <- pred_orig_full |
| 574 | ||
| 575 |
# add intercepts here |
|
| 576 | ! |
if (lavmodel@meanstructure) {
|
| 577 | ! |
int <- rbind(nu, alpha); colnames(int) <- "1" |
| 578 | ! |
int_orig <- int |
| 579 | ! |
int[int != 0] <- as.numeric(NA) |
| 580 | ! |
idx <- match(lv.marker, rownames(int)) |
| 581 | ! |
int[idx, 1] <- 1 |
| 582 | ! |
gamma_beta <- cbind(int, gamma_beta) |
| 583 | ! |
gamma_beta_orig <- cbind(int_orig, gamma_beta_orig) |
| 584 |
} |
|
| 585 | ||
| 586 |
# select only those rows of gamma_beta that have at least one free (NA) |
|
| 587 |
# element |
|
| 588 | ! |
free.idx <- which(apply(is.na(gamma_beta), 1, any)) |
| 589 | ! |
eqs_y_free <- unique(rownames(gamma_beta)[free.idx]) |
| 590 | ! |
eqs <- vector("list", length = length(eqs_y_free))
|
| 591 | ! |
for (j in seq_along(eqs)) {
|
| 592 |
# lhs |
|
| 593 | ! |
eq_lhs <- eq_lhs_orig <- eqs_y_free[j] |
| 594 | ||
| 595 |
# index in gamma_beta |
|
| 596 | ! |
jj <- free.idx[j] |
| 597 | ||
| 598 |
# lhs + rhs |
|
| 599 | ! |
zero.idx <- which(gamma_beta[jj, ] != 0) # fixed or error term |
| 600 | ! |
na.idx <- which(is.na(gamma_beta[jj, ])) # free/NA |
| 601 | ! |
eq_rhs <- eq_rhs_orig <- colnames(gamma_beta)[c(zero.idx, na.idx)] |
| 602 | ! |
pt <- unname(gamma_beta_orig[jj, na.idx]) |
| 603 | ! |
ptint <- integer(0L) |
| 604 | ! |
if (lavmodel@meanstructure) {
|
| 605 | ! |
ptint <- unname(int_orig[jj, 1L]) |
| 606 | ! |
eq_rhs <- eq_rhs[-1] |
| 607 | ! |
eq_rhs_orig <- eq_rhs_orig[-1] |
| 608 |
} |
|
| 609 | ! |
eq_all <- c(eq_lhs, eq_rhs) |
| 610 | ||
| 611 |
# markers + composite error term (cet) |
|
| 612 | ! |
cet <- paste("e.", eq_lhs, sep = "")
|
| 613 | ||
| 614 |
# replace all latent variables by their markers |
|
| 615 | ! |
markers <- character(0L) |
| 616 | ! |
lv_in_eq <- eq_all[eq_all %in% lv.names] |
| 617 | ! |
if (length(lv_in_eq) > 0L) {
|
| 618 | ! |
markers <- unname(lv.marker[lv_in_eq]) |
| 619 |
# replace in eq_all |
|
| 620 | ! |
eq_all[match(lv_in_eq, eq_all)] <- markers |
| 621 |
# add marker errors to composite error term |
|
| 622 | ! |
cet <- c(cet, paste("e.", markers, sep = ""))
|
| 623 |
} |
|
| 624 | ||
| 625 |
# any markers that are still latent? (eg higher-order factors) |
|
| 626 | ! |
if (any(eq_all %in% lv.names)) {
|
| 627 | ! |
lv_in_eq <- eq_all[eq_all %in% lv.names] |
| 628 | ! |
while (length(lv_in_eq) > 0L) {
|
| 629 | ! |
new_markers <- unname(lv.marker[lv_in_eq]) |
| 630 | ! |
eq_all[match(lv_in_eq, eq_all)] <- new_markers |
| 631 | ! |
markers[match(lv_in_eq, markers)] <- new_markers |
| 632 | ! |
cet <- c(cet, paste("e.", new_markers, sep = ""))
|
| 633 | ! |
lv_in_eq <- eq_all[eq_all %in% lv.names] |
| 634 |
} |
|
| 635 |
} |
|
| 636 | ! |
markers <- unique(markers) |
| 637 | ! |
eq_lhs <- eq_all[1] |
| 638 | ! |
eq_rhs <- eq_all[-1] |
| 639 | ||
| 640 | ! |
if (length(eq_rhs) > 0L) {
|
| 641 |
# observed variables that are uncorrelated with all the components of |
|
| 642 |
# the composite error term |
|
| 643 | ! |
ov_uncorrelated_with_cet <- |
| 644 | ! |
ov.names[apply(sigma_ov[, cet, drop = FALSE] == 0, 1L, all)] |
| 645 | ||
| 646 |
# observed variables that have at least one non-zero implied correlation |
|
| 647 |
# with any of the marker indicators (vector i). |
|
| 648 | ! |
ov_correlated_with_markers <- |
| 649 | ! |
ov.names[apply(sigma_ov[, markers, drop = FALSE] != 0, 1, all)] |
| 650 | ||
| 651 |
# valid instruments |
|
| 652 | ! |
miivs <- intersect(ov_uncorrelated_with_cet, ov_correlated_with_markers) |
| 653 |
} else {
|
|
| 654 | ! |
eq_rhs <- "1" |
| 655 | ! |
eq_rhs_orig <- "1" |
| 656 | ! |
miivs <- "1" |
| 657 |
} |
|
| 658 | ||
| 659 | ! |
eqs[[j]] <- list( |
| 660 | ! |
lhs_new = eq_lhs, |
| 661 | ! |
rhs_new = eq_rhs, |
| 662 | ! |
lhs = eq_lhs_orig, |
| 663 | ! |
rhs = eq_rhs_orig, |
| 664 | ! |
pt = pt, |
| 665 | ! |
ptint = ptint, |
| 666 | ! |
cet = cet, |
| 667 | ! |
markers = markers, |
| 668 | ! |
miiv = miivs |
| 669 |
) |
|
| 670 |
} |
|
| 671 | ||
| 672 |
# reorder so that ov lhs come first, then lv lhs |
|
| 673 | ! |
lhs <- sapply(eqs, "[[", "lhs") |
| 674 | ! |
ov.idx <- match(ov.names[ov.names %in% lhs], lhs) |
| 675 | ! |
lv.idx <- seq_along(lhs)[-ov.idx] |
| 676 | ! |
eqs <- eqs[c(ov.idx, lv.idx)] |
| 677 | ||
| 678 | ! |
iv_list[[b]] <- eqs |
| 679 |
} # nblocks |
|
| 680 | ||
| 681 | ||
| 682 | ! |
iv_list |
| 683 |
} |
|
| 684 | ||
| 685 |
# algorithm 3: |
|
| 686 |
# - use random data to create sigma (used to check if predictors are correlated |
|
| 687 |
# with instruments) |
|
| 688 |
# - use an explicit expression to compute cov(u,y), where u_j is the disturbance |
|
| 689 |
# term of an equation (used to verify that instruments are not correlated |
|
| 690 |
# with this disturbance term) |
|
| 691 |
lav_model_find_iv_covuy <- function(lavmodel = NULL, lavpta = NULL) {
|
|
| 692 |
# check representation |
|
| 693 | ! |
if (lavmodel@representation != "LISREL") {
|
| 694 | ! |
lav_msg_stop(gettext( |
| 695 | ! |
"this function only works with LISREL representation", |
| 696 | ! |
" (for now)" |
| 697 |
)) |
|
| 698 |
} |
|
| 699 | ||
| 700 |
# create model matrices with 1) 'user/partable' entries, 2) random entries |
|
| 701 | ! |
glist <- glistr <- lavmodel@GLIST |
| 702 | ! |
glist_names <- names(glist) |
| 703 | ! |
for (mm in seq_along(glist)) {
|
| 704 | ! |
dimnames(glist[[mm]]) <- lavmodel@dimNames[[mm]] |
| 705 | ! |
m.idx <- lavmodel@m.user.idx[[mm]] |
| 706 | ! |
x.idx <- lavmodel@x.user.idx[[mm]] |
| 707 |
# partable entries |
|
| 708 | ! |
glist[[mm]][, ] <- 0.0 |
| 709 | ! |
glist[[mm]][m.idx] <- x.idx |
| 710 |
# random entries (overriding user specified!) |
|
| 711 | ! |
f.idx <- lavmodel@m.free.idx[[mm]] |
| 712 | ! |
glistr[[mm]][f.idx] <- (runif(length(f.idx), min = 0.1, max = 0.5) * |
| 713 | ! |
sign(runif(length(f.idx), min = -1, max = 1))) |
| 714 | ! |
if (glist_names[mm] %in% c("theta", "psi")) {
|
| 715 | ! |
tmp <- glistr[[mm]] |
| 716 |
# make sure diagonal is large enough (but only for nonzero values) |
|
| 717 | ! |
zerodiag.idx <- which(diag(tmp) == 0) |
| 718 | ! |
diag(tmp) <- diag(tmp) + 1.5 |
| 719 | ! |
diag(tmp)[zerodiag.idx] <- 0 |
| 720 |
# make symmetric |
|
| 721 | ! |
glistr[[mm]] <- (tmp + t(tmp)) / 2 |
| 722 |
} |
|
| 723 |
} |
|
| 724 | ||
| 725 |
# generate random sigma per block |
|
| 726 | ! |
sigma <- lav_model_sigma(lavmodel, GLIST = glistr, extra = FALSE) |
| 727 | ! |
sigma_aug <- lav_model_cov_both(lavmodel, GLIST = glistr) |
| 728 | ||
| 729 |
# number of blocks |
|
| 730 | ! |
nblocks <- lavpta$nblocks |
| 731 | ! |
lambda.idx <- which(glist_names == "lambda") |
| 732 | ! |
beta.idx <- which(glist_names == "beta") |
| 733 | ! |
if (lavmodel@meanstructure) {
|
| 734 | ! |
nu.idx <- which(names(glist) == "nu") |
| 735 | ! |
alpha.idx <- which(names(glist) == "alpha") |
| 736 |
} |
|
| 737 | ||
| 738 | ||
| 739 |
# repeat for every block |
|
| 740 | ! |
iv_list <- vector("list", length = nblocks)
|
| 741 | ! |
for (b in seq_len(nblocks)) {
|
| 742 |
# extract information to create Bollen & Bauer (2004) matrices |
|
| 743 | ! |
ov.names <- lavmodel@dimNames[[lambda.idx[b]]][[1]] |
| 744 | ! |
lv.names <- lavmodel@dimNames[[lambda.idx[b]]][[2]] |
| 745 | ! |
both.names <- c(ov.names, lv.names) |
| 746 | ! |
nvar <- length(ov.names) |
| 747 | ! |
nfac <- length(lv.names) |
| 748 | ||
| 749 |
# model matrices for this block |
|
| 750 | ! |
lambda <- glist[[lambda.idx[b]]] |
| 751 | ! |
beta <- glist[[beta.idx[b]]] |
| 752 | ! |
if (is.null(beta)) {
|
| 753 | ! |
beta <- matrix(0, nfac, nfac) |
| 754 |
} |
|
| 755 | ! |
if (lavmodel@meanstructure) {
|
| 756 | ! |
nu <- glist[[nu.idx[b]]] |
| 757 | ! |
alpha <- glist[[alpha.idx[b]]] |
| 758 |
} |
|
| 759 | ||
| 760 |
# sigma + sigma_aug |
|
| 761 | ! |
this_sigma <- sigma[[b]] |
| 762 | ! |
rownames(this_sigma) <- colnames(this_sigma) <- ov.names |
| 763 | ! |
this_sigma_aug <- sigma_aug[[b]] |
| 764 | ! |
rownames(this_sigma_aug) <- colnames(this_sigma_aug) <- both.names |
| 765 | ||
| 766 | ! |
lambdar <- glistr[[lambda.idx[b]]] |
| 767 | ! |
if (is.null(glistr[[beta.idx[b]]])) {
|
| 768 | ! |
betar <- diag(1, nrow = nfac) |
| 769 |
} else {
|
|
| 770 | ! |
betar <- glistr[[beta.idx[b]]] |
| 771 |
} |
|
| 772 | ||
| 773 |
# all markers (including higher-order) |
|
| 774 | ! |
lv.marker <- lv.names |
| 775 | ! |
names(lv.marker) <- lv.names |
| 776 | ! |
lv.marker[match(names(lavpta$vnames$lv.marker[[b]]), lv.names)] <- |
| 777 | ! |
lavpta$vnames$lv.marker[[b]] |
| 778 | ! |
lv.marker.idx <- match(lv.marker, both.names) |
| 779 | ||
| 780 |
# construct cov_u_y |
|
| 781 | ! |
pi_mat <- rbind(lambdar, betar) |
| 782 | ! |
rownames(pi_mat) <- both.names |
| 783 | ! |
colnames(pi_mat) <- lv.names |
| 784 | ! |
pi_mat[lv.marker.idx, ] <- betar |
| 785 | ! |
pi_zero_mat <- matrix(0, nrow = nrow(pi_mat), ncol = nrow(pi_mat)) |
| 786 | ! |
pi_zero_mat[, lv.marker.idx] <- pi_mat |
| 787 | ! |
cov_u_y_aug <- this_sigma_aug - pi_zero_mat %*% this_sigma_aug |
| 788 |
# zap small elements to be exactly zero |
|
| 789 | ! |
cov_u_y_aug[abs(cov_u_y_aug) < 1e-07] <- 0.0 |
| 790 | ||
| 791 | ! |
if (length(lavpta$vnames$lv.ho[[b]]) > 0L) {
|
| 792 |
# 'add' lv marker rows to ov marker rows |
|
| 793 | ! |
ov.marker <- lv.marker |
| 794 | ! |
lv.names.nox <- lv.names[!lv.names %in% ov.names] |
| 795 | ! |
lv_in_marker <- lv_beta <- ov.marker[ov.marker %in% lv.names.nox] |
| 796 | ! |
while (length(lv_in_marker) > 0L) {
|
| 797 | ! |
new_markers <- unname(ov.marker[lv_in_marker]) |
| 798 | ! |
ov.marker[match(lv_in_marker, ov.marker)] <- new_markers |
| 799 | ! |
lv_in_marker <- ov.marker[ov.marker %in% lv.names.nox] |
| 800 |
} |
|
| 801 | ! |
ho.idx <- match(names(lv_beta), both.names) |
| 802 | ! |
target.idx <- match(ov.marker[names(lv_beta)], both.names) |
| 803 | ! |
cov_u_y_aug[target.idx, ] <- |
| 804 | ! |
cov_u_y_aug[target.idx, ] + cov_u_y_aug[ho.idx, ] |
| 805 |
} else {
|
|
| 806 | ! |
ov.marker <- lv.marker |
| 807 |
} |
|
| 808 | ! |
cov_u_y <- cov_u_y_aug[seq_len(nvar), seq_len(nvar)] |
| 809 | ||
| 810 |
# construct pred |
|
| 811 | ! |
pred <- rbind(lambda, beta) |
| 812 | ||
| 813 |
# if meanstructure, add intercepts |
|
| 814 | ! |
if (lavmodel@meanstructure) {
|
| 815 | ! |
int <- rbind(nu, alpha) |
| 816 | ! |
colnames(int) <- "1" # shorter than "intercept" |
| 817 | ! |
pred <- cbind(int, pred) |
| 818 |
} |
|
| 819 | ||
| 820 | ! |
pred_orig <- pred |
| 821 |
# replace col/rownames of pred by marker names |
|
| 822 | ! |
idx <- match(names(ov.marker), colnames(pred)) |
| 823 | ! |
idx <- idx[!is.na(idx)] |
| 824 | ! |
colnames(pred)[idx] <- ov.marker |
| 825 | ! |
idx <- match(names(ov.marker), rownames(pred)) |
| 826 | ! |
idx <- idx[!is.na(idx)] |
| 827 | ! |
rownames(pred)[idx] <- ov.marker |
| 828 | ||
| 829 |
# remove scaling '1' for markers (if any) |
|
| 830 | ! |
if (length(lv.marker.idx) > 0L) {
|
| 831 | ! |
pred[lv.marker.idx, ] <- 0 |
| 832 |
} |
|
| 833 | ||
| 834 |
# remove 'empty' rows |
|
| 835 | ! |
empty.idx <- which(apply(pred, 1L, function(x) all(x == 0))) |
| 836 | ! |
if (length(empty.idx) > 0L) {
|
| 837 | ! |
pred <- pred[-empty.idx, , drop = FALSE] |
| 838 | ! |
pred_orig <- pred_orig[-empty.idx, , drop = FALSE] |
| 839 |
} |
|
| 840 | ||
| 841 |
# prepare list |
|
| 842 | ! |
eqs <- vector("list", length = nrow(pred))
|
| 843 | ! |
for (j in seq_along(eqs)) {
|
| 844 | ! |
lhs <- rownames(pred)[j] |
| 845 | ! |
x.idx <- which(pred[j, ] != 0) |
| 846 | ! |
rhs <- colnames(pred)[x.idx] |
| 847 | ! |
ptint <- integer(0L) |
| 848 | ! |
if (lavmodel@meanstructure && pred[j, 1] != 0) {
|
| 849 | ! |
ptint <- unname(pred_orig[j, 1]) |
| 850 | ! |
rhs <- rhs[-1] |
| 851 | ! |
x.idx <- x.idx[-1] |
| 852 |
} |
|
| 853 | ||
| 854 |
# instruments needed? |
|
| 855 | ! |
iv_flag <- TRUE |
| 856 | ! |
if (lavmodel@meanstructure && length(x.idx) == 0L) {
|
| 857 | ! |
iv_flag <- FALSE |
| 858 | ! |
miiv <- "1" |
| 859 | ! |
} else if (all(cov_u_y[lhs, rhs] == 0)) {
|
| 860 | ! |
iv_flag <- FALSE |
| 861 | ! |
miiv <- rhs |
| 862 |
} else {
|
|
| 863 |
# correlated with at least one predictor |
|
| 864 | ! |
correlated_with_pred <- apply( |
| 865 | ! |
this_sigma[, rhs, drop = FALSE], 1L, |
| 866 | ! |
function(x) any(x != 0) |
| 867 |
) |
|
| 868 |
# instruments should be uncorrelated with the term of the eq (u_j) |
|
| 869 | ! |
uncorrelated_with_u <- cov_u_y[lhs, ] == 0 |
| 870 | ! |
miiv <- ov.names[correlated_with_pred & uncorrelated_with_u] |
| 871 |
} |
|
| 872 | ||
| 873 |
# prepare rhs, rhs_new, pt |
|
| 874 | ! |
if (length(x.idx) == 0) {
|
| 875 | ! |
rhs_new <- "1" |
| 876 | ! |
rhs <- "1" |
| 877 | ! |
pt <- integer(0L) |
| 878 |
} else {
|
|
| 879 | ! |
rhs_new <- colnames(pred[j, x.idx, drop = FALSE]) |
| 880 | ! |
rhs <- colnames(pred_orig[j, x.idx, drop = FALSE]) |
| 881 | ! |
pt <- as.integer(unname(pred_orig[j, x.idx])) |
| 882 |
} |
|
| 883 | ||
| 884 | ! |
eqs[[j]] <- list( |
| 885 | ! |
lhs_new = rownames(pred)[j], |
| 886 | ! |
rhs_new = rhs_new, |
| 887 | ! |
lhs = rownames(pred_orig)[j], |
| 888 | ! |
rhs = rhs, |
| 889 | ! |
pt = pt, |
| 890 | ! |
ptint = ptint, |
| 891 | ! |
iv_flag = iv_flag, |
| 892 | ! |
miiv = miiv |
| 893 |
) |
|
| 894 |
} |
|
| 895 | ||
| 896 |
# reorder so that ov lhs come first, then lv lhs |
|
| 897 | ! |
lhs <- sapply(eqs, "[[", "lhs") |
| 898 | ! |
ov.idx <- match(ov.names[ov.names %in% lhs], lhs) |
| 899 | ! |
lv.idx <- seq_along(lhs)[-ov.idx] |
| 900 | ! |
eqs <- eqs[c(ov.idx, lv.idx)] |
| 901 | ||
| 902 | ! |
iv_list[[b]] <- eqs |
| 903 |
} |
|
| 904 | ||
| 905 | ! |
iv_list |
| 906 |
} |
| 1 |
# This function takes as input a plotinfo structure with two data.frames: |
|
| 2 |
# nodes: id, naam, tiepe, voorkeur, blok |
|
| 3 |
# edges: id, label, van, naar, tiepe |
|
| 4 |
# , parameters to control the placement of nodes and edge labels, a |
|
| 5 |
# switch to indicate whether indicators for which a covariance is explicit in |
|
| 6 |
# the model should be grouped at the same side of the graph and a debug |
|
| 7 |
# switch. |
|
| 8 |
# It returns a plotinfo strucure with modified nodes and edges data.frames and |
|
| 9 |
# an integer mlrij giving the position at which a line should be drawn for |
|
| 10 |
# multilevel models. |
|
| 11 |
# The data.frames have new columns defined as follows: |
|
| 12 |
# nodes: |
|
| 13 |
# rij: index of the row where the node will be placed. |
|
| 14 |
# kolom: ndex of the column where the node will be placed. |
|
| 15 |
# edges |
|
| 16 |
# vananker: character, anchor point for starting node. |
|
| 17 |
# naaranker: character, anchor point for destination node. |
|
| 18 |
# controlpt.kol: real, column position of control point if the |
|
| 19 |
# edge has to be drawn as a quadratic Beziers curve. |
|
| 20 |
# controlpt.row: real, row position of control point if the |
|
| 21 |
# edge has to be drawn as a quadratic Beziers curve. |
|
| 22 |
# labelbelow: logical, TRUE if label has to be positioned under |
|
| 23 |
# the line, initalized FALSE. |
|
| 24 |
# |
|
| 25 |
lav_plotinfo_positions <- function( |
|
| 26 |
plotinfo, |
|
| 27 |
placenodes = NULL, |
|
| 28 |
edgelabelsbelow = NULL, |
|
| 29 |
group.covar.indicators = FALSE, |
|
| 30 |
debug = FALSE |
|
| 31 |
) {
|
|
| 32 |
# add new columns to nodes and edges data.frames |
|
| 33 | ! |
nodes <- plotinfo$nodes |
| 34 | ! |
nodes$rij <- NA_integer_ |
| 35 | ! |
nodes$kolom <- NA_integer_ |
| 36 | ! |
edges <- plotinfo$edges |
| 37 | ! |
edges$vananker <- NA_character_ |
| 38 | ! |
edges$naaranker <- NA_character_ |
| 39 | ! |
edges$controlpt.kol <- NA_real_ |
| 40 | ! |
edges$controlpt.rij <- NA_real_ |
| 41 | ! |
edges$labelbelow <- FALSE |
| 42 |
# if only one node, place it at (1, 1) and return |
|
| 43 | ! |
if (length(nodes$rij) == 1L) {
|
| 44 |
# Only 1 node, e.g. model = 'x ~~ x' |
|
| 45 | ! |
nodes$rij[1L] <- 1L |
| 46 | ! |
nodes$kolom[1L] <- 1L |
| 47 | ! |
return(list( |
| 48 | ! |
nodes = nodes, |
| 49 | ! |
edges = edges, |
| 50 | ! |
mlrij = 0L |
| 51 |
)) |
|
| 52 |
} |
|
| 53 |
# if there are multiple levels, split the plotinfo in two and call function |
|
| 54 |
# lav_plotinfo_positions_one separately for the two levels and combine the |
|
| 55 |
# results |
|
| 56 | ! |
if (any(nodes$blok > 0L)) {
|
| 57 |
# Multilevel, only level:1 and level:2 accepted |
|
| 58 | ! |
nodes1 <- nodes[nodes$blok >= 2L, ] |
| 59 | ! |
edges1 <- edges[edges$van %in% nodes1$id, ] |
| 60 | ! |
edges1$van <- match(edges1$van, nodes1$id) |
| 61 | ! |
edges1$naar <- match(edges1$naar, nodes1$id) |
| 62 | ! |
nodes1$id <- seq_along(nodes1$tiepe) |
| 63 | ! |
nodes1$blok <- 0L |
| 64 | ! |
nodes2 <- nodes[nodes$blok == 1L, ] |
| 65 | ! |
edges2 <- edges[edges$van %in% nodes2$id, ] |
| 66 | ! |
edges2$van <- match(edges2$van, nodes2$id) |
| 67 | ! |
edges2$naar <- match(edges2$naar, nodes2$id) |
| 68 | ! |
nodes2$id <- seq_along(nodes2$tiepe) |
| 69 | ! |
nodes2$blok <- 0L |
| 70 | ! |
result1 <- lav_plotinfo_positions_one( |
| 71 | ! |
list(nodes = nodes1, edges = edges1), |
| 72 | ! |
placenodes, |
| 73 | ! |
edgelabelsbelow, |
| 74 | ! |
group.covar.indicators, |
| 75 | ! |
debug |
| 76 |
) |
|
| 77 | ! |
result2 <- lav_plotinfo_positions_one( |
| 78 | ! |
list(nodes = nodes2, edges = edges2), |
| 79 | ! |
placenodes, |
| 80 | ! |
edgelabelsbelow, |
| 81 | ! |
group.covar.indicators, |
| 82 | ! |
debug |
| 83 |
) |
|
| 84 | ! |
rijen1 <- max(result1$nodes$rij) |
| 85 | ! |
result2$nodes$rij <- result2$nodes$rij + rijen1 + 1L |
| 86 | ! |
result2$edges$controlpt.rij <- result2$edges$controlpt.rij + rijen1 + 1L |
| 87 | ! |
result1$nodes$blok <- 2L |
| 88 | ! |
result2$nodes$blok <- 1L |
| 89 | ! |
result2$nodes$id <- result2$nodes$id + length(result1$nodes) |
| 90 | ! |
result2$edges$van <- result2$edges$van + length(result1$nodes) |
| 91 | ! |
result2$edges$naar <- result2$edges$naar + length(result1$nodes) |
| 92 | ! |
nodes <- rbind(result1$nodes, result2$nodes) |
| 93 | ! |
edges <- rbind(result1$edges, result2$edges) |
| 94 | ! |
return(list( |
| 95 | ! |
nodes = nodes, |
| 96 | ! |
edges = edges, |
| 97 | ! |
mlrij = rijen1 + 1L |
| 98 |
)) |
|
| 99 |
} |
|
| 100 |
# if there is only one level, call function lav_plotinfo_positions_one |
|
| 101 | ! |
plotinfo <- list(nodes = nodes, edges = edges) |
| 102 | ! |
lav_plotinfo_positions_one( |
| 103 | ! |
plotinfo, |
| 104 | ! |
placenodes, |
| 105 | ! |
edgelabelsbelow, |
| 106 | ! |
group.covar.indicators, |
| 107 | ! |
debug |
| 108 |
) |
|
| 109 |
} |
|
| 110 | ||
| 111 |
# This function computes the positions for the nodes and the anchors and |
|
| 112 |
# control points for the edges in the diagram for a single level. |
|
| 113 |
lav_plotinfo_positions_one <- function( |
|
| 114 |
plotinfo, |
|
| 115 |
placenodes, |
|
| 116 |
edgelabelsbelow, |
|
| 117 |
group.covar.indicators, |
|
| 118 |
debug |
|
| 119 |
) {
|
|
| 120 | ! |
nods <- plotinfo$nodes |
| 121 | ! |
edgs <- plotinfo$edges |
| 122 |
# assign groupnumbers to the nodes, i.e. partition the nodes in groups |
|
| 123 |
# which belong together, e.g. indicators and the corresponding latent |
|
| 124 |
# variable |
|
| 125 | ! |
nods <- lav_plotinfo_nodes_groups(plotinfo, group.covar.indicators) |
| 126 | ! |
plotinfo <- list(nodes = nods, edges = edgs) |
| 127 |
# compute the information for the groups |
|
| 128 | ! |
groups <- lav_plotinfo_groups(plotinfo) |
| 129 |
# order the groups in a matrix via topological sorting |
|
| 130 | ! |
groups <- lav_groups_order(groups, plotinfo) |
| 131 |
# debug <- TRUE |
|
| 132 | ! |
if (debug) {
|
| 133 | ! |
cat("debug start\nnodes\n")
|
| 134 | ! |
nods1 <- within(nods, {
|
| 135 | ! |
rm(blok, rij, kolom) |
| 136 |
}) |
|
| 137 | ! |
print(nods1) |
| 138 | ! |
cat("edges\n")
|
| 139 | ! |
edgs1 <- within(edgs, {
|
| 140 | ! |
rm(vananker, naaranker, controlpt.kol, controlpt.rij) |
| 141 |
}) |
|
| 142 | ! |
print(edgs1) |
| 143 | ! |
rm(edgs1, nods1) |
| 144 | ! |
cat("matrix with groups after ordening\n")
|
| 145 | ! |
print(lav_groups_matrix(groups)) |
| 146 | ! |
cat("debug end\n")
|
| 147 |
} |
|
| 148 | ! |
for (g in seq_along(groups)) {
|
| 149 | ! |
group <- groups[[g]] |
| 150 | ! |
group <- lav_group_order(group, plotinfo) |
| 151 | ! |
if (debug && group$nb.nodes > 1L) {
|
| 152 | ! |
plot(group$offsets.lin, -group$offsets.out, |
| 153 | ! |
pch = 16, xlim = c(0, 1 + max(group$offsets.lin)), |
| 154 | ! |
axes = FALSE, main = paste("Group", g))
|
| 155 | ! |
arrows(0.5, 0, 0.5, -max(group$offsets.out), col = "blue") |
| 156 | ! |
text(0.6, -0.6, "out", col = "blue") |
| 157 | ! |
text(group$offsets.lin + 0.2, -group$offsets.out, |
| 158 | ! |
nods$naam[group$nodes.id]) |
| 159 |
} |
|
| 160 | ! |
groups[[g]] <- group |
| 161 |
} |
|
| 162 | ! |
width <- sapply(groups, function(g) g$width.height[1L]) |
| 163 | ! |
height <- sapply(groups, function(g) g$width.height[2L]) |
| 164 | ! |
columns <- sapply(groups, function(g) g$matrixrowcol[2L]) |
| 165 | ! |
rows <- sapply(groups, function(g) g$matrixrowcol[1L]) |
| 166 | ! |
colnums <- sort(unique(columns)) |
| 167 | ! |
rownums <- sort(unique(rows)) |
| 168 | ! |
colwidths <- sapply(colnums, function(i) max(width[columns == i])) |
| 169 | ! |
rowheights <- sapply(rownums, function(i) max(height[rows == i])) |
| 170 | ! |
for (g in groups) {
|
| 171 | ! |
thisrow <- g$matrixrowcol[1L] |
| 172 | ! |
thiscol <- g$matrixrowcol[2L] |
| 173 | ! |
gtop <- 1L |
| 174 | ! |
if (thisrow > 1L) gtop <- gtop + cumsum(rowheights)[thisrow - 1L] |
| 175 | ! |
gleft <- 1L |
| 176 | ! |
if (thiscol > 1L) gleft <- gleft + cumsum(colwidths)[thiscol - 1L] |
| 177 | ! |
for (n in seq_along(g$nodes.id)) {
|
| 178 | ! |
k <- which(nods$id == g$nodes.id[n]) |
| 179 | ! |
if (g$loc == "l" || g$loc == "?") {
|
| 180 | ! |
nods$rij[k] <- gtop + g$offsets.lin[n] |
| 181 | ! |
nods$kolom[k] <- gleft + colwidths[g$matrixrowcol[2L]] - |
| 182 | ! |
g$offsets.out[n] - 1L |
| 183 | ! |
} else if (g$loc == "r") {
|
| 184 | ! |
nods$rij[k] <- gtop + g$offsets.lin[n] |
| 185 | ! |
nods$kolom[k] <- gleft + g$offsets.out[n] |
| 186 | ! |
} else if (g$loc == "t") {
|
| 187 | ! |
nods$rij[k] <- gtop + rowheights[1] - g$offsets.out[n] - 1L |
| 188 | ! |
nods$kolom[k] <- gleft + g$offsets.lin[n] |
| 189 | ! |
} else if (g$loc == "b") {
|
| 190 | ! |
nods$rij[k] <- gtop + g$offsets.out[n] |
| 191 | ! |
nods$kolom[k] <- gleft + g$offsets.lin[n] |
| 192 |
} |
|
| 193 |
} |
|
| 194 |
} |
|
| 195 |
# compress graph by joining adjacent rows without common column-elements and |
|
| 196 |
# adjacent columns without common row-elements |
|
| 197 | ! |
maxrow <- max(nods$rij) |
| 198 | ! |
maxcol <- max(nods$kolom) |
| 199 | ! |
for (j in seq(maxrow - 1L, 1L, -1L)) {
|
| 200 | ! |
col1 <- nods$kolom[nods$rij == j] |
| 201 | ! |
col2 <- nods$kolom[nods$rij == j + 1L] |
| 202 | ! |
if (all(is.na(match(col1, col2)))) {
|
| 203 | ! |
dimins <- which(nods$rij > j) |
| 204 | ! |
nods$rij[dimins] <- nods$rij[dimins] - 1L |
| 205 |
} |
|
| 206 |
} |
|
| 207 | ! |
for (j in seq(maxcol - 1L, 1L, -1L)) {
|
| 208 | ! |
col1 <- nods$rij[nods$kolom == j] |
| 209 | ! |
col2 <- nods$rij[nods$kolom == j + 1L] |
| 210 | ! |
if (all(is.na(match(col1, col2)))) {
|
| 211 | ! |
dimins <- which(nods$kolom > j) |
| 212 | ! |
nods$kolom[dimins] <- nods$kolom[dimins] - 1L |
| 213 |
} |
|
| 214 |
} |
|
| 215 |
# check for debug |
|
| 216 | ! |
if (debug) {
|
| 217 | ! |
plot(nods$kolom, -nods$rij, |
| 218 | ! |
pch = 16, xlim = c(0, 1 + max(nods$kolom)), axes = FALSE, |
| 219 | ! |
main = "Absolute positions nodes") |
| 220 | ! |
text(nods$kolom + 0.3, -nods$rij, nods$naam) |
| 221 |
} |
|
| 222 |
#### place nodes demanded by user ? #### |
|
| 223 | ! |
if (!is.null(placenodes)) {
|
| 224 | ! |
for (nn in names(placenodes)) {
|
| 225 | ! |
w <- which(nods$naam == nn) |
| 226 | ! |
if (length(w) == 0) {
|
| 227 | ! |
lav_msg_warn(gettextf("placenodes: node name %s not found!", nn))
|
| 228 |
} |
|
| 229 | ! |
nods$rij[w] <- placenodes[[nn]][1L] |
| 230 | ! |
nods$kolom[w] <- placenodes[[nn]][2L] |
| 231 |
} |
|
| 232 |
} |
|
| 233 |
#### place anchors #### |
|
| 234 | ! |
groupmaxcol <- max(sapply(groups, function(g) g$matrixrowcol[2L])) |
| 235 | ! |
groupmaxrow <- max(sapply(groups, function(g) g$matrixrowcol[1L])) |
| 236 | ! |
for (j in seq_along(edgs$id)) {
|
| 237 | ! |
thisedge <- edgs[j, ] |
| 238 | ! |
van <- nods[which(nods$id == thisedge$van), ] |
| 239 | ! |
naar <- nods[which(nods$id == thisedge$naar), ] |
| 240 | ! |
vangroup <- groups[[van$group]] |
| 241 | ! |
if (thisedge$tiepe == "=~") { # define latent variable
|
| 242 | ! |
if (vangroup$matrixrowcol[[2L]] == 1L) {
|
| 243 | ! |
thisedge$vananker <- "w" |
| 244 | ! |
thisedge$naaranker <- "e" |
| 245 | ! |
} else if (vangroup$matrixrowcol[[2L]] == groupmaxcol) {
|
| 246 | ! |
thisedge$vananker <- "e" |
| 247 | ! |
thisedge$naaranker <- "w" |
| 248 | ! |
} else if (vangroup$matrixrowcol[[1L]] == 1L) {
|
| 249 | ! |
thisedge$vananker <- "n" |
| 250 | ! |
thisedge$naaranker <- "s" |
| 251 | ! |
} else if (vangroup$matrixrowcol[[1L]] == groupmaxrow) {
|
| 252 | ! |
thisedge$vananker <- "s" |
| 253 | ! |
thisedge$naaranker <- "n" |
| 254 |
} |
|
| 255 | ! |
} else if (thisedge$tiepe == "<~") { # define composite variable
|
| 256 | ! |
if (vangroup$matrixrowcol[[2L]] == 1L) {
|
| 257 | ! |
thisedge$vananker <- "e" |
| 258 | ! |
thisedge$naaranker <- "w" |
| 259 | ! |
} else if (vangroup$matrixrowcol[[2L]] == groupmaxcol) {
|
| 260 | ! |
thisedge$vananker <- "w" |
| 261 | ! |
thisedge$naaranker <- "e" |
| 262 | ! |
} else if (vangroup$matrixrowcol[[1L]] == 1L) {
|
| 263 | ! |
thisedge$vananker <- "s" |
| 264 | ! |
thisedge$naaranker <- "n" |
| 265 | ! |
} else if (vangroup$matrixrowcol[[1L]] == groupmaxrow) {
|
| 266 | ! |
thisedge$vananker <- "n" |
| 267 | ! |
thisedge$naaranker <- "s" |
| 268 |
} |
|
| 269 | ! |
} else if (thisedge$tiepe == "~." || thisedge$tiepe == "~") {
|
| 270 |
# regression/varlv |
|
| 271 | ! |
if (van$rij == naar$rij) {
|
| 272 | ! |
thisedge$vananker <- if (van$kolom < naar$kolom) "e" else "w" |
| 273 | ! |
thisedge$naaranker <- if (van$kolom < naar$kolom) "w" else "e" |
| 274 | ! |
} else if (van$kolom == naar$kolom) {
|
| 275 | ! |
thisedge$vananker <- if (van$rij < naar$rij) "s" else "n" |
| 276 | ! |
thisedge$naaranker <- if (van$rij < naar$rij) "n" else "s" |
| 277 |
} else {
|
|
| 278 | ! |
thisedge <- lav_plotinfo_anchors(thisedge, van, naar, |
| 279 | ! |
max(nods$kolom), max(nods$rij)) |
| 280 |
} |
|
| 281 | ! |
} else if (thisedge$tiepe == "~~~") { # (remaining) variance
|
| 282 | ! |
thisedge <- lav_plotinfo_anchors(thisedge, van, naar, |
| 283 | ! |
max(nods$kolom), max(nods$rij)) |
| 284 |
} else { # covariance
|
|
| 285 | ! |
thisedge <- lav_plotinfo_anchors(thisedge, van, naar, |
| 286 | ! |
max(nods$kolom), max(nods$rij)) |
| 287 |
} |
|
| 288 | ! |
edgs[j, ] <- thisedge |
| 289 |
} |
|
| 290 |
#### labelsbelow demanded by user ? #### |
|
| 291 | ! |
if (!is.null(edgelabelsbelow)) {
|
| 292 | ! |
for (i in seq_along(edgelabelsbelow)) {
|
| 293 | ! |
n1 <- which(nods$naam == edgelabelsbelow[[i]][1L]) |
| 294 | ! |
if (length(n1) == 0) {
|
| 295 | ! |
lav_msg_warn(gettextf( |
| 296 | ! |
"edgelabelsbelow: node name %s not found!", |
| 297 | ! |
edgelabelsbelow[[i]][1L] |
| 298 |
)) |
|
| 299 |
} |
|
| 300 | ! |
n2 <- which(nods$naam == edgelabelsbelow[[i]][2L]) |
| 301 | ! |
if (length(n2) == 0) {
|
| 302 | ! |
lav_msg_warn(gettextf( |
| 303 | ! |
"edgelabelsbelow: node name %s not found!", |
| 304 | ! |
edgelabelsbelow[[i]][2L] |
| 305 |
)) |
|
| 306 |
} |
|
| 307 | ! |
ed <- which( |
| 308 | ! |
edgs$van == nods$id[n1] & |
| 309 | ! |
edgs$naar == nods$id[n2] |
| 310 |
) |
|
| 311 | ! |
if (length(ed) == 0L) {
|
| 312 | ! |
ed <- which(edgs$naar == nods$id[n1] & edgs$van == nods$id[n2]) |
| 313 |
} |
|
| 314 | ! |
if (length(ed) == 0L) {
|
| 315 | ! |
lav_msg_warn( |
| 316 | ! |
gettextf( |
| 317 | ! |
"edgelabelsbelow: edge %s -- %s not found!", |
| 318 | ! |
nods$naam[n1], |
| 319 | ! |
nods$naam[n2] |
| 320 |
) |
|
| 321 |
) |
|
| 322 |
} |
|
| 323 | ! |
edgs$labelbelow[ed] <- TRUE |
| 324 |
} |
|
| 325 |
} |
|
| 326 |
#### RETURN #### |
|
| 327 | ! |
list(nodes = nods, edges = edgs, mlrij = 0L) |
| 328 |
} |
|
| 329 | ||
| 330 |
lav_plotinfo_nodes_groups <- function(plotinfo, group.covar.indicators) {
|
|
| 331 | ! |
nodes <- plotinfo$nodes |
| 332 | ! |
edges <- plotinfo$edges |
| 333 | ! |
nodes$group <- seq.int(nrow(nodes)) # each node in its own group |
| 334 | ! |
merge_groups <- function(group, i1, i2) { # merge group of i1 into group of i2
|
| 335 | ! |
group[group == group[i1]] <- group[i2] |
| 336 | ! |
group |
| 337 |
} |
|
| 338 | ! |
indicator.ids <- lav_plotinfo_indicator_ids(nodes, edges) |
| 339 |
# process edges to form groups |
|
| 340 | ! |
for (j in seq.int(nrow(edges))) {
|
| 341 | ! |
van.id <- which(nodes$id == edges$van[j]) |
| 342 | ! |
naar.id <- which(nodes$id == edges$naar[j]) |
| 343 | ! |
merge.them <- FALSE |
| 344 | ! |
if (edges$tiepe[j] == "=~") {
|
| 345 | ! |
if (nodes$tiepe[naar.id] != "lv" && nodes$tiepe[naar.id] != "cv") {
|
| 346 | ! |
merge.them <- TRUE |
| 347 |
} |
|
| 348 | ! |
} else if (edges$tiepe[j] == "<~") {
|
| 349 | ! |
if (nodes$tiepe[van.id] != "lv" && nodes$tiepe[van.id] != "cv") {
|
| 350 | ! |
merge.them <- TRUE |
| 351 |
} |
|
| 352 | ! |
} else if (edges$tiepe[j] == "~.") {
|
| 353 | ! |
merge.them <- TRUE |
| 354 | ! |
} else if (edges$tiepe[j] == "~~") {
|
| 355 | ! |
if (group.covar.indicators && |
| 356 | ! |
any(edges$van[j] == indicator.ids) && |
| 357 | ! |
any(edges$naar[j] == indicator.ids) |
| 358 |
) {
|
|
| 359 | ! |
merge.them <- TRUE |
| 360 |
} |
|
| 361 | ! |
} else if (edges$tiepe[j] == "~") {
|
| 362 | ! |
if (nodes$tiepe[van.id] == "varlv") {
|
| 363 | ! |
merge.them <- TRUE |
| 364 |
} |
|
| 365 |
} |
|
| 366 | ! |
if (merge.them) {
|
| 367 | ! |
nodes$group <- merge_groups(nodes$group, naar.id, van.id) |
| 368 |
} |
|
| 369 |
} |
|
| 370 | ! |
nodes$group <- match(nodes$group, unique(nodes$group)) # renumber 1:n |
| 371 | ! |
nodes |
| 372 |
} |
|
| 373 |
lav_plotinfo_indicator_ids <- function(nodes, edges) {
|
|
| 374 |
# compute ids of observed indicators |
|
| 375 | ! |
indicator.ids <- unique(c( |
| 376 | ! |
edges$naar[edges$tiepe == "=~"], |
| 377 | ! |
edges$van[edges$tiepe == "<~"] |
| 378 |
)) |
|
| 379 | ! |
for (i in seq_along(indicator.ids)) {
|
| 380 | ! |
indicator.id <- which(nodes$id == indicator.ids[i]) |
| 381 |
if ( |
|
| 382 | ! |
nodes$tiepe[indicator.id] == "lv" || |
| 383 | ! |
nodes$tiepe[indicator.id] == "cv" |
| 384 |
) {
|
|
| 385 | ! |
indicator.ids[i] <- 0L |
| 386 |
} |
|
| 387 |
} |
|
| 388 | ! |
indicator.ids <- indicator.ids[indicator.ids != 0L] |
| 389 | ! |
indicator.ids |
| 390 |
} |
|
| 391 |
lav_plotinfo_groups <- function(plotinfo) {
|
|
| 392 | ! |
nodes <- plotinfo$nodes |
| 393 | ! |
edges <- plotinfo$edges |
| 394 | ! |
nb.of.groups <- max(nodes$group) |
| 395 | ! |
indicator.ids <- lav_plotinfo_indicator_ids(nodes, edges) |
| 396 | ! |
groups <- lapply(seq_len(nb.of.groups), function(g) {
|
| 397 | ! |
group <- list( |
| 398 | ! |
id = g, |
| 399 | ! |
nodes.id = integer(), |
| 400 | ! |
edges.id = integer(), |
| 401 | ! |
offsets.out = integer(), |
| 402 | ! |
offsets.lin = integer(), |
| 403 | ! |
nb.nodes = integer(), |
| 404 | ! |
nb.indicators = 0L, |
| 405 | ! |
measurement = FALSE, |
| 406 | ! |
loc = "?", |
| 407 | ! |
matrixrowcol = c(0L, 0L), |
| 408 | ! |
width.height = c(1L, 1L), |
| 409 | ! |
indic = "" |
| 410 |
) |
|
| 411 | ! |
group$nodes.id <- which(nodes$group == g) |
| 412 | ! |
group$nodes.id <- nodes$id[group$nodes.id] |
| 413 | ! |
group$edges.id <- which( |
| 414 | ! |
edges$van %in% group$nodes.id & edges$naar %in% group$nodes.id |
| 415 |
) |
|
| 416 | ! |
group$edges.id <- edges$id[group$edges.id] |
| 417 | ! |
group$nb.nodes <- length(group$nodes.id) |
| 418 | ! |
group$nb.indicators <- |
| 419 | ! |
as.integer(sum(nodes$group[nodes$id %in% indicator.ids] == g)) |
| 420 | ! |
group$measurement <- (group$nb.indicators > 0L) |
| 421 | ! |
group |
| 422 |
}) |
|
| 423 | ! |
groups |
| 424 |
} |
|
| 425 |
lav_groups_matrix <- function(groups) {
|
|
| 426 | ! |
maxrow <- 1L |
| 427 | ! |
maxcol <- 1L |
| 428 | ! |
for (group in groups) {
|
| 429 | ! |
rowcol <- group$matrixrowcol |
| 430 | ! |
if (rowcol[1L] > maxrow) {
|
| 431 | ! |
maxrow <- rowcol[1L] |
| 432 |
} |
|
| 433 | ! |
if (rowcol[2L] > maxcol) {
|
| 434 | ! |
maxcol <- rowcol[2L] |
| 435 |
} |
|
| 436 |
} |
|
| 437 | ! |
m <- matrix(0L, nrow = maxrow, ncol = maxcol) |
| 438 | ! |
for (group in groups) {
|
| 439 | ! |
rowcol <- group$matrixrowcol |
| 440 | ! |
m[rowcol[1L], rowcol[2L]] <- group$id |
| 441 |
} |
|
| 442 | ! |
m |
| 443 |
} |
|
| 444 | ||
| 445 |
# internal ordering of a group |
|
| 446 |
lav_group_order <- function(group.object, plotinfo) {
|
|
| 447 | ! |
edges <- plotinfo$edges |
| 448 | ! |
group <- group.object |
| 449 | ! |
group$offsets.out <- rep(0L, group$nb.nodes) |
| 450 | ! |
group$offsets.lin <- rep(0L, group$nb.nodes) |
| 451 | ! |
if (group$nb.nodes > 1L) {
|
| 452 | ! |
defined <- integer() |
| 453 | ! |
definedby <- integer() |
| 454 | ! |
bordernodes <- integer() |
| 455 | ! |
for (j in group$edges.id) {
|
| 456 | ! |
thisedge <- edges[which(edges$id == j), ] |
| 457 | ! |
if (thisedge$tiepe == "~.") {
|
| 458 | ! |
definedby <- c(definedby, thisedge$van) |
| 459 | ! |
defined <- c(defined, thisedge$naar) |
| 460 |
} else {
|
|
| 461 | ! |
if (thisedge$tiepe == "=~") {
|
| 462 | ! |
definedby <- c(definedby, thisedge$naar) |
| 463 | ! |
defined <- c(defined, thisedge$van) |
| 464 | ! |
bordernodes <- c(bordernodes, thisedge$van) |
| 465 | ! |
} else if (thisedge$tiepe == "<~") {
|
| 466 | ! |
definedby <- c(definedby, thisedge$van) |
| 467 | ! |
defined <- c(defined, thisedge$naar) |
| 468 | ! |
bordernodes <- c(bordernodes, thisedge$naar) |
| 469 |
} else { # include nodes not yet present indefined or definedby
|
|
| 470 | ! |
if (!(thisedge$van %in% definedby || thisedge$van %in% defined)) {
|
| 471 | ! |
definedby <- c(definedby, thisedge$van) |
| 472 | ! |
defined <- c(defined, 999L) |
| 473 |
} |
|
| 474 | ! |
if (!(thisedge$naar %in% definedby || thisedge$naar %in% defined)) {
|
| 475 | ! |
definedby <- c(definedby, thisedge$naar) |
| 476 | ! |
defined <- c(defined, 999L) |
| 477 |
} |
|
| 478 |
} |
|
| 479 |
} |
|
| 480 |
} |
|
| 481 | ! |
internaldf <- lav_graph_topological_matrix(defined, definedby, |
| 482 | ! |
bordernodes = bordernodes) |
| 483 | ! |
for (j in seq_along(group$nodes.id)) {
|
| 484 | ! |
group$offsets.lin[j] <- internaldf$rows[internaldf$nodes == |
| 485 | ! |
group$nodes.id[j]] - 1L |
| 486 | ! |
group$offsets.out[j] <- max(internaldf$cols) - |
| 487 | ! |
internaldf$cols[internaldf$nodes == group$nodes.id[j]] |
| 488 |
} |
|
| 489 |
} |
|
| 490 | ! |
if (group$loc == "l" || group$loc == "r" || group$loc == "?") {
|
| 491 | ! |
group$width.height <- c( |
| 492 | ! |
1L + max(group$offsets.out), |
| 493 | ! |
1L + max(group$offsets.lin) |
| 494 |
) |
|
| 495 |
} else {
|
|
| 496 | ! |
group$width.height <- c( |
| 497 | ! |
1L + max(group$offsets.lin), |
| 498 | ! |
1L + max(group$offsets.out) |
| 499 |
) |
|
| 500 |
} |
|
| 501 | ! |
group |
| 502 |
} |
|
| 503 | ||
| 504 |
lav_groups_order <- function(groups, plotinfo) {
|
|
| 505 | ! |
nodes <- plotinfo$nodes |
| 506 | ! |
edges <- plotinfo$edges |
| 507 | ! |
dependencies <- data.frame(defined = integer(0), definedby = integer(0)) |
| 508 | ! |
add_dependency <- function(depends, def, defby) {
|
| 509 | ! |
if (any(depends$defined == def & depends$definedby == defby)) {
|
| 510 | ! |
return(depends) |
| 511 |
} |
|
| 512 | ! |
rbind(depends, data.frame(defined = def, definedby = defby)) |
| 513 |
} |
|
| 514 | ! |
for (j in seq_along(edges$id)) {
|
| 515 | ! |
van.id <- which(nodes$id == edges$van[j]) |
| 516 | ! |
naar.id <- which(nodes$id == edges$naar[j]) |
| 517 | ! |
if (nodes$group[van.id] == nodes$group[naar.id]) {
|
| 518 | ! |
next |
| 519 |
} |
|
| 520 | ! |
if (edges$tiepe[j] == "=~") {
|
| 521 | ! |
if (nodes$tiepe[naar.id] == "lv" || nodes$tiepe[naar.id] == "cv") {
|
| 522 | ! |
dependencies <- add_dependency( |
| 523 | ! |
dependencies, |
| 524 | ! |
nodes$group[van.id], |
| 525 | ! |
nodes$group[naar.id] |
| 526 |
) |
|
| 527 |
} |
|
| 528 | ! |
} else if (edges$tiepe[j] == "<~") {
|
| 529 | ! |
if (nodes$tiepe[van.id] == "lv" || nodes$tiepe[van.id] == "cv") {
|
| 530 | ! |
dependencies <- add_dependency( |
| 531 | ! |
dependencies, |
| 532 | ! |
nodes$group[naar.id], |
| 533 | ! |
nodes$group[van.id] |
| 534 |
) |
|
| 535 |
} |
|
| 536 | ! |
} else if (edges$tiepe[j] == "~") {
|
| 537 | ! |
dependencies <- add_dependency( |
| 538 | ! |
dependencies, |
| 539 | ! |
nodes$group[naar.id], |
| 540 | ! |
nodes$group[van.id] |
| 541 |
) |
|
| 542 |
} |
|
| 543 |
} |
|
| 544 | ! |
bordernodes <- integer(0) |
| 545 | ! |
for (g in groups) {
|
| 546 | ! |
if (g$measurement) bordernodes <- c(bordernodes, g$id) |
| 547 |
} |
|
| 548 | ! |
if (nrow(dependencies) == 0L) {
|
| 549 | ! |
for (g in groups) dependencies <- add_dependency(dependencies, 999, g$id) |
| 550 |
} |
|
| 551 | ! |
groupmatrixdf <- lav_graph_topological_matrix( |
| 552 | ! |
dependencies$defined, |
| 553 | ! |
dependencies$definedby, |
| 554 | ! |
bordernodes = bordernodes, |
| 555 | ! |
warn = TRUE |
| 556 |
) |
|
| 557 | ! |
for (g in seq_along(groups)) {
|
| 558 | ! |
group <- groups[[g]] |
| 559 | ! |
gmcol <- which(groupmatrixdf$nodes == group$id) |
| 560 | ! |
group$matrixrowcol <- as.integer(c( |
| 561 | ! |
groupmatrixdf$rows[gmcol], |
| 562 | ! |
groupmatrixdf$cols[gmcol] |
| 563 |
)) |
|
| 564 | ! |
group$indic <- groupmatrixdf$indic[gmcol] |
| 565 | ! |
groups[[g]] <- group |
| 566 |
} |
|
| 567 | ! |
rm(groupmatrixdf) |
| 568 |
# Set loc = "l" for all measurement groups in first column. |
|
| 569 |
# Set loc = "r" for all measurement groups in last column. |
|
| 570 |
# Set loc = "t" for measurement groups in first row and |
|
| 571 |
# not first or last column. |
|
| 572 |
# Set loc = "b" for measurement groups in another row and |
|
| 573 |
# not first or last column. |
|
| 574 | ! |
group.matrix <- lav_groups_matrix(groups) |
| 575 | ! |
gmcols <- ncol(group.matrix) |
| 576 | ! |
for (g in seq_along(groups)) {
|
| 577 | ! |
group <- groups[[g]] |
| 578 | ! |
if (group$measurement) {
|
| 579 | ! |
if (group$matrixrowcol[2L] == 1L) {
|
| 580 | ! |
group$loc <- "l" |
| 581 | ! |
} else if (group$matrixrowcol[2L] == gmcols) {
|
| 582 | ! |
group$loc <- "r" |
| 583 |
} else {
|
|
| 584 | ! |
if (group$matrixrowcol[1L] == 1L) {
|
| 585 | ! |
group$loc <- "t" |
| 586 |
} else {
|
|
| 587 | ! |
group$loc <- "b" |
| 588 |
} |
|
| 589 |
} |
|
| 590 | ! |
groups[[g]] <- group |
| 591 |
} |
|
| 592 |
} |
|
| 593 | ! |
groups |
| 594 |
} |
|
| 595 | ||
| 596 |
lav_points_normalform <- function(p1, p2) {
|
|
| 597 |
# compute normal form of a line |
|
| 598 |
# the constant in the normal form will always be <= 0 |
|
| 599 | ! |
xy1 <- matrix( |
| 600 | ! |
c( |
| 601 | ! |
p1, 1, p2, 1 |
| 602 |
), |
|
| 603 | ! |
byrow = TRUE, |
| 604 | ! |
ncol = 3 |
| 605 |
) |
|
| 606 | ! |
a <- det(xy1[, 2:3]) |
| 607 | ! |
b <- -det(xy1[, c( |
| 608 | ! |
1L, 3L |
| 609 |
)]) |
|
| 610 | ! |
c <- det(xy1[, 1:2]) |
| 611 | ! |
fac <- 1 / sqrt(a * a + b * b) |
| 612 | ! |
if (c > 0) {
|
| 613 | ! |
fac <- -fac |
| 614 |
} |
|
| 615 | ! |
fac * |
| 616 | ! |
c( |
| 617 | ! |
a, b, c |
| 618 |
) |
|
| 619 |
} |
|
| 620 |
lav_pointslope_normalform <- function(p, slope) {
|
|
| 621 |
# compute normal form of a line defined by intercept a and slope b |
|
| 622 |
# a vertical line is defined by x = a and b = Inf or -Inf |
|
| 623 | ! |
if (is.infinite(slope)) {
|
| 624 | ! |
return(c( |
| 625 | ! |
1, 0, -p[1] |
| 626 |
)) |
|
| 627 |
} |
|
| 628 | ! |
coeffs <- c( |
| 629 | ! |
-slope, 1, slope * p[1] - p[2] |
| 630 |
) / |
|
| 631 | ! |
sqrt(1 + slope^2) |
| 632 | ! |
if (coeffs[3] > 0) {
|
| 633 | ! |
coeffs <- -coeffs |
| 634 |
} |
|
| 635 | ! |
coeffs |
| 636 |
} |
|
| 637 |
lav_lines_intersection <- function(line1, line2) {
|
|
| 638 |
# get the intersection point of two lines for which coefficients of |
|
| 639 |
# equations are given |
|
| 640 | ! |
m <- matrix( |
| 641 | ! |
c( |
| 642 | ! |
line1[1:2], line2[1:2] |
| 643 |
), |
|
| 644 | ! |
byrow = TRUE, |
| 645 | ! |
ncol = 2L |
| 646 |
) |
|
| 647 | ! |
b <- matrix( |
| 648 | ! |
c( |
| 649 | ! |
-line1[3], -line2[3] |
| 650 |
), |
|
| 651 | ! |
ncol = 1L |
| 652 |
) |
|
| 653 | ! |
if (abs(det(m)) < 1e-12) {
|
| 654 | ! |
return(NA_real_) |
| 655 |
} |
|
| 656 | ! |
as.vector(solve(m) %*% b) |
| 657 |
} |
|
| 658 |
lav_edge_bezierscontrolpoint <- function(van, naar, maxrij, maxcol) {
|
|
| 659 | ! |
middelpunt <- c( |
| 660 | ! |
maxrij + 1, maxcol + 1 |
| 661 |
) / |
|
| 662 | ! |
2 |
| 663 | ! |
delta <- sqrt(sum((van - naar)^2)) / |
| 664 | ! |
sqrt(sum( |
| 665 | ! |
c( |
| 666 | ! |
maxrij - 1, maxcol - 1 |
| 667 | ! |
)^2 |
| 668 |
)) |
|
| 669 | ! |
lijn <- lav_points_normalform(van, naar) |
| 670 | ! |
middenlijn <- (van + naar) / 2 |
| 671 | ! |
lijnmidden <- sum( |
| 672 | ! |
lijn * |
| 673 | ! |
c( |
| 674 | ! |
middelpunt, 1 |
| 675 |
) |
|
| 676 |
) |
|
| 677 | ! |
if (lijnmidden > 0) {
|
| 678 | ! |
lijn[3] <- lijn[3] + 0.5 + delta |
| 679 |
} else {
|
|
| 680 | ! |
lijn[3] <- lijn[3] - 0.5 - delta |
| 681 |
} |
|
| 682 | ! |
orthoslope <- lijn[2] / lijn[1] |
| 683 | ! |
loodlijn <- lav_pointslope_normalform(middenlijn, orthoslope) |
| 684 | ! |
lav_lines_intersection(lijn, loodlijn) |
| 685 |
} |
|
| 686 |
lav_edge_bezierscp_corner <- function(van, naar, wvannaar, maxrij, maxcol) {
|
|
| 687 | ! |
dif <- (abs(van[1L] - naar[1L]) + abs(van[2L] - naar[2L]) - 1) / |
| 688 | ! |
(maxrij + maxcol - 2) |
| 689 | ! |
p <- switch(wvannaar, |
| 690 | ! |
ne = , |
| 691 | ! |
en = c( |
| 692 | ! |
1, maxcol |
| 693 |
) + |
|
| 694 | ! |
c( |
| 695 | ! |
-dif, dif |
| 696 |
), |
|
| 697 | ! |
nw = , |
| 698 | ! |
wn = c( |
| 699 | ! |
1, 1 |
| 700 |
) + |
|
| 701 | ! |
c( |
| 702 | ! |
-dif, -dif |
| 703 |
), |
|
| 704 | ! |
se = , |
| 705 | ! |
es = c( |
| 706 | ! |
maxrij, maxcol |
| 707 |
) + |
|
| 708 | ! |
c( |
| 709 | ! |
dif, dif |
| 710 |
), |
|
| 711 | ! |
sw = , |
| 712 | ! |
ws = c( |
| 713 | ! |
maxrij, 1 |
| 714 |
) + |
|
| 715 | ! |
c( |
| 716 | ! |
dif, -dif |
| 717 |
) |
|
| 718 |
) |
|
| 719 | ! |
2 * (p - 0.25 * (van + naar)) |
| 720 |
} |
|
| 721 | ||
| 722 |
lav_plotinfo_anchors <- function(edge, nodevan, nodenaar, maxkol, maxrij) {
|
|
| 723 | ! |
if (edge$tiepe == "~~~") {
|
| 724 | ! |
if (nodevan$kolom == 1L) {
|
| 725 | ! |
edge$vananker <- "w" |
| 726 | ! |
edge$naaranker <- "w" |
| 727 | ! |
} else if (nodevan$kolom == maxkol) {
|
| 728 | ! |
edge$vananker <- "e" |
| 729 | ! |
edge$naaranker <- "e" |
| 730 | ! |
} else if (nodevan$rij == 1L) {
|
| 731 | ! |
edge$vananker <- "n" |
| 732 | ! |
edge$naaranker <- "n" |
| 733 | ! |
} else if (nodevan$rij == maxrij) {
|
| 734 | ! |
edge$vananker <- "s" |
| 735 | ! |
edge$naaranker <- "s" |
| 736 |
} else {
|
|
| 737 | ! |
edge$vananker <- "n" |
| 738 | ! |
edge$naaranker <- "n" |
| 739 |
} |
|
| 740 | ! |
} else if (edge$tiepe == "~~") {
|
| 741 | ! |
thrucorner <- FALSE |
| 742 | ! |
if (edge$tiepe == "~~") {
|
| 743 | ! |
if (nodevan$kolom == nodenaar$kolom) {
|
| 744 | ! |
if (nodevan$kolom < maxkol / 2) {
|
| 745 | ! |
edge$vananker <- edge$naaranker <- "w" |
| 746 |
} else {
|
|
| 747 | ! |
edge$vananker <- edge$naaranker <- "e" |
| 748 |
} |
|
| 749 | ! |
} else if (nodevan$rij == nodenaar$rij) {
|
| 750 | ! |
if (nodevan$rij < maxrij / 2) {
|
| 751 | ! |
edge$vananker <- edge$naaranker <- "n" |
| 752 |
} else {
|
|
| 753 | ! |
edge$vananker <- edge$naaranker <- "s" |
| 754 |
} |
|
| 755 |
} else {
|
|
| 756 | ! |
if (nodevan$rij < nodenaar$rij) {
|
| 757 | ! |
if (nodevan$kolom < nodenaar$kolom) {
|
| 758 | ! |
if (nodevan$kolom == 1L && nodenaar$rij == maxrij) {
|
| 759 | ! |
edge$vananker <- "w" |
| 760 | ! |
edge$naaranker <- "s" |
| 761 | ! |
thrucorner <- TRUE |
| 762 |
} else {
|
|
| 763 | ! |
edge$vananker <- "s" |
| 764 | ! |
edge$naaranker <- "w" |
| 765 |
} |
|
| 766 |
} else {
|
|
| 767 | ! |
if (nodevan$kolom == maxkol && nodenaar$rij == maxrij) {
|
| 768 | ! |
edge$vananker <- "e" |
| 769 | ! |
edge$naaranker <- "s" |
| 770 | ! |
thrucorner = TRUE |
| 771 |
} else {
|
|
| 772 | ! |
edge$vananker <- "s" |
| 773 | ! |
edge$naaranker <- "e" |
| 774 |
} |
|
| 775 |
} |
|
| 776 |
} else {
|
|
| 777 | ! |
if (nodevan$kolom < nodenaar$kolom) {
|
| 778 | ! |
if (nodevan$kolom == 1L && nodenaar$rij == 1L) {
|
| 779 | ! |
edge$vananker <- "w" |
| 780 | ! |
edge$naaranker <- "n" |
| 781 | ! |
thrucorner <- TRUE |
| 782 |
} else {
|
|
| 783 | ! |
edge$vananker <- "n" |
| 784 | ! |
edge$naaranker <- "w" |
| 785 |
} |
|
| 786 |
} else {
|
|
| 787 | ! |
if (nodevan$kolom == maxkol && nodenaar$rij == 1L) {
|
| 788 | ! |
edge$vananker <- "e" |
| 789 | ! |
edge$naaranker <- "n" |
| 790 | ! |
thrucorner <- TRUE |
| 791 |
} else {
|
|
| 792 | ! |
edge$vananker <- "n" |
| 793 | ! |
edge$naaranker <- "e" |
| 794 |
} |
|
| 795 |
} |
|
| 796 |
} |
|
| 797 |
} |
|
| 798 | ! |
if (thrucorner) {
|
| 799 | ! |
bc <- lav_edge_bezierscp_corner( |
| 800 | ! |
c( |
| 801 | ! |
nodevan$rij, nodevan$kolom |
| 802 |
), |
|
| 803 | ! |
c( |
| 804 | ! |
nodenaar$rij, nodenaar$kolom |
| 805 |
), |
|
| 806 | ! |
paste0(edge$vananker, edge$naaranker), |
| 807 | ! |
maxrij, |
| 808 | ! |
maxkol |
| 809 |
) |
|
| 810 |
} else {
|
|
| 811 | ! |
bc <- lav_edge_bezierscontrolpoint( |
| 812 | ! |
c( |
| 813 | ! |
nodevan$rij, nodevan$kolom |
| 814 |
), |
|
| 815 | ! |
c( |
| 816 | ! |
nodenaar$rij, nodenaar$kolom |
| 817 |
), |
|
| 818 | ! |
maxrij, |
| 819 | ! |
maxkol |
| 820 |
) |
|
| 821 |
} |
|
| 822 | ! |
edge$controlpt.rij <- bc[1L] |
| 823 | ! |
edge$controlpt.kol <- bc[2L] |
| 824 |
} |
|
| 825 |
} else {
|
|
| 826 | ! |
breaks <- c( |
| 827 | ! |
-pi - 0.01, |
| 828 | ! |
-7 * pi / 8, |
| 829 | ! |
-5 * pi / 8, |
| 830 | ! |
-3 * pi / 8, |
| 831 | ! |
-pi / 8, |
| 832 | ! |
pi / 8, |
| 833 | ! |
3 * pi / 8, |
| 834 | ! |
5 * pi / 8, |
| 835 | ! |
7 * pi / 8, |
| 836 | ! |
pi + 0.01 |
| 837 |
) |
|
| 838 | ! |
winds <- c("w", "sw", "s", "se", "e", "ne", "n", "nw", "w")
|
| 839 | ! |
hoek <- atan2(nodevan$rij - nodenaar$rij, nodenaar$kolom - nodevan$kolom) |
| 840 | ! |
wind <- cut(hoek, breaks, winds) |
| 841 | ! |
edge$vananker <- as.character(wind) |
| 842 | ! |
if (hoek > 0) {
|
| 843 | ! |
hoek <- hoek - pi |
| 844 |
} else {
|
|
| 845 | ! |
hoek <- hoek + pi |
| 846 |
} |
|
| 847 | ! |
wind <- cut(hoek, breaks, winds) |
| 848 | ! |
edge$naaranker <- as.character(wind) |
| 849 |
} |
|
| 850 | ! |
edge |
| 851 |
} |
| 1 |
# efa related functions |
|
| 2 |
# YR - April 2019 |
|
| 3 |
# |
|
| 4 |
# the lav_model_efa_rotate_x() function was based on a script orginally |
|
| 5 |
# written by Florian Scharf (Muenster University, Germany) |
|
| 6 | ||
| 7 |
# rotate solution |
|
| 8 |
lav_model_efa_rotate <- function(lavmodel = NULL, lavoptions = NULL) {
|
|
| 9 | ||
| 10 |
# sanity check |
|
| 11 | 4x |
if (lavmodel@nefa == 0L || lavoptions$rotation == "none") {
|
| 12 | ! |
return(lavmodel) |
| 13 |
} |
|
| 14 | ||
| 15 |
# save warn and verbos settings |
|
| 16 | 4x |
current.warn <- lav_warn() |
| 17 | 4x |
current.verbose <- lav_verbose() |
| 18 | ||
| 19 |
# extract unrotated parameters from lavmodel |
|
| 20 | 4x |
x.orig <- lav_model_get_parameters(lavmodel, type = "free", extra = FALSE) |
| 21 | ||
| 22 |
# rotate, extract information from 'extra' attribute |
|
| 23 | 4x |
tmp <- lav_model_efa_rotate_x( |
| 24 | 4x |
x = x.orig, lavmodel = lavmodel, |
| 25 | 4x |
lavoptions = lavoptions, extra = TRUE |
| 26 |
) |
|
| 27 | 4x |
extra <- attr(tmp, "extra") |
| 28 | 4x |
attr(tmp, "extra") <- NULL |
| 29 | ||
| 30 | 4x |
out <- list(GLIST = extra$GLIST, H = extra$H, lv.order = extra$lv.order) |
| 31 | ||
| 32 |
# restore warn/verbose settings |
|
| 33 | 4x |
lav_warn(current.warn) |
| 34 | 4x |
lav_verbose(current.verbose) |
| 35 | ||
| 36 | 4x |
out |
| 37 |
} |
|
| 38 | ||
| 39 | ||
| 40 |
# lower-level function, needed for numDeriv |
|
| 41 |
lav_model_efa_rotate_x <- function(x, lavmodel = NULL, lavoptions = NULL, |
|
| 42 |
init.rot = NULL, extra = FALSE, |
|
| 43 |
type = "free") {
|
|
| 44 |
# extract rotation options from lavoptions |
|
| 45 | 4x |
method <- lavoptions$rotation |
| 46 | 4x |
if (method == "none") {
|
| 47 | ! |
return(x) |
| 48 |
} |
|
| 49 | 4x |
ropts <- lavoptions$rotation.args |
| 50 | ||
| 51 |
# place parameters into model matrices |
|
| 52 | 4x |
lavmodel.orig <- lav_model_set_parameters(lavmodel, x = x) |
| 53 | ||
| 54 |
# GLIST |
|
| 55 | 4x |
GLIST <- lavmodel.orig@GLIST |
| 56 | ||
| 57 |
# H per group |
|
| 58 | 4x |
H <- vector("list", lavmodel@ngroups)
|
| 59 | 4x |
ORDER <- vector("list", lavmodel@ngroups)
|
| 60 | ||
| 61 |
# new in 0.6-22 -- three options: |
|
| 62 |
# 1. rotate per group (default) |
|
| 63 |
# 2. group.equal = "loadings": use first lambda matrix only |
|
| 64 |
# 3. rotate all groups together + agreement (eg De Roover & Vermunt, 2019) |
|
| 65 | 4x |
mg.group.equal.flag <- mg.agreement.flag <- FALSE |
| 66 | 4x |
if (lavmodel@ngroups > 1) {
|
| 67 | ! |
if("loadings" %in% lavoptions$group.equal) {
|
| 68 | ! |
mg.group.equal.flag <- TRUE |
| 69 | ! |
} else if (ropts$mg.agreement) {
|
| 70 | ! |
mg.agreement.flag <- TRUE |
| 71 |
} |
|
| 72 |
} |
|
| 73 | ||
| 74 |
# option 1 + 2 (single group or multipgroup + no agreement) |
|
| 75 | 4x |
if (!mg.agreement.flag) {
|
| 76 | 4x |
for (g in seq_len(lavmodel@ngroups)) {
|
| 77 |
# select model matrices for this group |
|
| 78 | 4x |
mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g] |
| 79 | 4x |
MLIST <- GLIST[mm.in.group] |
| 80 | ||
| 81 |
# general rotation matrix (all latent variables) |
|
| 82 | 4x |
H[[g]] <- Hg <- diag(ncol(MLIST$lambda)) |
| 83 | 4x |
lv.order <- seq_len(ncol(MLIST$lambda)) |
| 84 | ||
| 85 |
# reconstruct full LAMBDA (in case of dummy ov's) |
|
| 86 | 4x |
LAMBDA.g <- lav_lisrel_lambda( |
| 87 | 4x |
MLIST = MLIST, |
| 88 | 4x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 89 | 4x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 90 | 4x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 91 | 4x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 92 | 4x |
remove.dummy.lv = TRUE |
| 93 |
) |
|
| 94 |
# reconstruct full THETA (in case of dummy ov's) |
|
| 95 | 4x |
THETA.g <- lav_lisrel_theta( |
| 96 | 4x |
MLIST = MLIST, |
| 97 | 4x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 98 | 4x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 99 | 4x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 100 | 4x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]] |
| 101 |
) |
|
| 102 | ||
| 103 |
# fill in optimal rotation for each set |
|
| 104 | 4x |
for (set in seq_len(lavmodel@nefa)) {
|
| 105 |
# which ov/lv's are involved in this set? |
|
| 106 | 4x |
ov.idx <- lavmodel@ov.efa.idx[[g]][[set]] |
| 107 | 4x |
lv.idx <- lavmodel@lv.efa.idx[[g]][[set]] |
| 108 | ||
| 109 |
# empty set? |
|
| 110 | 4x |
if (length(ov.idx) == 0L) {
|
| 111 | ! |
next |
| 112 |
} |
|
| 113 | ||
| 114 |
# just 1 factor? |
|
| 115 | 4x |
if (length(lv.idx) < 2L) {
|
| 116 |
# new in 0.6-18: reflect if needed |
|
| 117 | 1x |
if (lavoptions$rotation.args$reflect) {
|
| 118 | 1x |
tmp <- LAMBDA.g[ov.idx, lv.idx, drop = TRUE] |
| 119 | 1x |
if (sum(tmp) < 0) {
|
| 120 | 1x |
MLIST$lambda[ov.idx, 1] <- -1 * MLIST$lambda[ov.idx, 1] |
| 121 |
} |
|
| 122 |
} |
|
| 123 | 1x |
next |
| 124 |
} |
|
| 125 | ||
| 126 |
# unrotated 'A' for this set |
|
| 127 | 3x |
A <- LAMBDA.g[ov.idx, lv.idx, drop = FALSE] |
| 128 | ||
| 129 |
# std.ov? we use diagonal of Sigma for this set of ov's only |
|
| 130 | 3x |
if (ropts$std.ov) {
|
| 131 | 3x |
if (mg.group.equal.flag) {
|
| 132 |
# compute mean THETA across groups |
|
| 133 | ! |
theta.idx <- which(names(lavmodel@GLIST) == "theta") |
| 134 | ! |
THETA <- Reduce("+", lavmodel@GLIST[theta.idx]) / lavmodel@ngroups
|
| 135 |
} else {
|
|
| 136 | 3x |
THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE] |
| 137 |
} |
|
| 138 | 3x |
Sigma <- tcrossprod(A) + THETA |
| 139 | 3x |
this.ov.var <- diag(Sigma) |
| 140 |
} else {
|
|
| 141 | ! |
this.ov.var <- NULL |
| 142 |
} |
|
| 143 | ||
| 144 |
# init.rot? |
|
| 145 | 3x |
if (!is.null(init.rot) && lavoptions$rotation.args$jac.init.rot) {
|
| 146 | ! |
init.ROT <- init.rot[[g]][lv.idx, lv.idx, drop = FALSE] |
| 147 | ! |
rstarts <- 0 |
| 148 |
} else {
|
|
| 149 | 3x |
init.ROT <- NULL |
| 150 | 3x |
rstarts <- ropts$rstarts |
| 151 |
} |
|
| 152 |
# set warn and verbose to ropts-values |
|
| 153 | 3x |
current.warn <- lav_warn() |
| 154 | 3x |
current.verbose <- lav_verbose() |
| 155 | 3x |
if (lav_warn(ropts$warn)) |
| 156 | 3x |
on.exit(lav_warn(current.warn), TRUE) |
| 157 | 3x |
if (lav_verbose(ropts$verbose)) |
| 158 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 159 |
# rotate this set |
|
| 160 | 3x |
res <- lav_matrix_rotate( |
| 161 | 3x |
A = A, |
| 162 | 3x |
orthogonal = ropts$orthogonal, |
| 163 | 3x |
method = method, |
| 164 | 3x |
method.args = list( |
| 165 | 3x |
geomin.epsilon = ropts$geomin.epsilon, |
| 166 | 3x |
orthomax.gamma = ropts$orthomax.gamma, |
| 167 | 3x |
cf.gamma = ropts$orthomax.gamma, |
| 168 | 3x |
oblimin.gamma = ropts$oblimin.gamma, |
| 169 | 3x |
promax.kappa = ropts$promax.kappa, |
| 170 | 3x |
target = ropts$target, |
| 171 | 3x |
target.mask = ropts$target.mask |
| 172 |
), |
|
| 173 | 3x |
init.ROT = init.ROT, |
| 174 | 3x |
init.ROT.check = FALSE, |
| 175 | 3x |
rstarts = rstarts, |
| 176 | 3x |
row.weights = ropts$row.weights, |
| 177 | 3x |
std.ov = ropts$std.ov, |
| 178 | 3x |
ov.var = this.ov.var, |
| 179 | 3x |
algorithm = ropts$algorithm, |
| 180 | 3x |
reflect = ropts$reflect, |
| 181 | 3x |
order.lv.by = ropts$order.lv.by, |
| 182 | 3x |
gpa.tol = ropts$gpa.tol, |
| 183 | 3x |
tol = ropts$tol, |
| 184 | 3x |
max.iter = ropts$max.iter, |
| 185 | 3x |
group = g |
| 186 |
) |
|
| 187 | ||
| 188 |
# extract rotation matrix (note, in Asp & Muthen, 2009; this is H') |
|
| 189 |
# note: as of 0.6-6, order.idx has already been applied to ROT, |
|
| 190 |
# so no need to reorder rows/columns after rotation |
|
| 191 | 3x |
H.efa <- res$ROT |
| 192 | ||
| 193 |
# fill in optimal rotation for this set |
|
| 194 | 3x |
Hg[lv.idx, lv.idx] <- H.efa |
| 195 | ||
| 196 |
# keep track of possible re-orderings |
|
| 197 | 3x |
lv.order[lv.idx] <- lv.idx[res$order.idx] |
| 198 |
} # set |
|
| 199 | ||
| 200 |
# rotate all the SEM parameters |
|
| 201 | ||
| 202 |
# 1. lambda |
|
| 203 | 4x |
MLIST$lambda <- t(solve(Hg, t(MLIST$lambda))) |
| 204 | ||
| 205 |
# 2. psi (note: eq 22 Asp & Muthen, 2009: transpose reversed) |
|
| 206 | 4x |
MLIST$psi <- t(Hg) %*% MLIST$psi %*% Hg |
| 207 | ||
| 208 |
# 3. beta |
|
| 209 | 4x |
if (!is.null(MLIST$beta)) {
|
| 210 | ! |
MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta))) |
| 211 |
} |
|
| 212 | ||
| 213 |
# 4. alpha |
|
| 214 | 4x |
if (!is.null(MLIST$alpha)) {
|
| 215 | ! |
MLIST$alpha <- t(Hg) %*% MLIST$alpha |
| 216 |
} |
|
| 217 | ||
| 218 |
# no need for rotation: nu, theta |
|
| 219 | ||
| 220 |
# store rotated matrices in GLIST |
|
| 221 | 4x |
GLIST[mm.in.group] <- MLIST |
| 222 | ||
| 223 |
# store rotation matrix + lv.order |
|
| 224 | 4x |
H[[g]] <- Hg |
| 225 | 4x |
ORDER[[g]] <- lv.order |
| 226 | ||
| 227 |
# check for group.equal |
|
| 228 | 4x |
if (mg.group.equal.flag) {
|
| 229 | ! |
break # only rotation once |
| 230 |
} |
|
| 231 |
} # group |
|
| 232 | ||
| 233 |
# if group.equal = "loadings", take care of the other groups |
|
| 234 | 4x |
if (mg.group.equal.flag) {
|
| 235 | ! |
MLIST1 <- MLIST # first group |
| 236 | ! |
for (g in 2:lavmodel@ngroups) {
|
| 237 | ! |
mm.in.group <- ( seq_len(lavmodel@nmat[g]) + |
| 238 | ! |
cumsum(c(0, lavmodel@nmat))[g] ) |
| 239 | ! |
MLIST <- GLIST[mm.in.group] |
| 240 | ! |
MLIST$lambda <- MLIST1$lambda |
| 241 | ! |
MLIST$psi <- t(Hg) %*% MLIST$psi %*% Hg |
| 242 | ! |
if (!is.null(MLIST$beta)) {
|
| 243 | ! |
MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta))) |
| 244 |
} |
|
| 245 | ! |
if (!is.null(MLIST$alpha)) {
|
| 246 | ! |
MLIST$alpha <- t(Hg) %*% MLIST$alpha |
| 247 |
} |
|
| 248 | ! |
GLIST[mm.in.group] <- MLIST |
| 249 | ! |
H[[g]] <- Hg |
| 250 | ! |
ORDER[[g]] <- lv.order |
| 251 |
} |
|
| 252 |
} |
|
| 253 | ||
| 254 |
# option 3: rotation + agreement |
|
| 255 |
} else {
|
|
| 256 | ! |
lambdaList <- vector("list", length = lavmodel@ngroups)
|
| 257 | ! |
for (g in seq_len(lavmodel@ngroups)) {
|
| 258 |
# select model matrices for this group |
|
| 259 | ! |
mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g] |
| 260 | ! |
MLIST <- GLIST[mm.in.group] |
| 261 | ||
| 262 |
# reconstruct full LAMBDA (in case of dummy ov's) |
|
| 263 | ! |
LAMBDA.g <- lav_lisrel_lambda( |
| 264 | ! |
MLIST = MLIST, |
| 265 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 266 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 267 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 268 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 269 | ! |
remove.dummy.lv = TRUE |
| 270 |
) |
|
| 271 | ||
| 272 | ! |
lambdaList[[g]] <- LAMBDA.g |
| 273 | ||
| 274 |
# prepare H and ORDER |
|
| 275 | ! |
H[[g]] <- diag(ncol(LAMBDA.g)) |
| 276 | ! |
ORDER[[g]] <- seq_len(ncol(LAMBDA.g)) |
| 277 |
} # group |
|
| 278 | ||
| 279 |
# fill in optimal rotation for each set |
|
| 280 | ! |
for (set in seq_len(lavmodel@nefa)) {
|
| 281 |
# which ov/lv's are involved in this set? |
|
| 282 | ! |
ov.idx <- lavmodel@ov.efa.idx[[1]][[set]] # assumed equal across groups! |
| 283 | ! |
lv.idx <- lavmodel@lv.efa.idx[[1]][[set]] # assumed equal across groups! |
| 284 | ||
| 285 |
# empty set? |
|
| 286 | ! |
if (length(ov.idx) == 0L) {
|
| 287 | ! |
next |
| 288 |
} |
|
| 289 | ||
| 290 |
# just 1 factor? |
|
| 291 |
# if (length(lv.idx) < 2L) {
|
|
| 292 |
# # new in 0.6-18: reflect if needed |
|
| 293 |
# if (lavoptions$rotation.args$reflect) {
|
|
| 294 |
# tmp <- LAMBDA.g[ov.idx, lv.idx, drop = TRUE] |
|
| 295 |
# if (sum(tmp) < 0) {
|
|
| 296 |
# MLIST$lambda[ov.idx, 1] <- -1 * MLIST$lambda[ov.idx, 1] |
|
| 297 |
# } |
|
| 298 |
# } |
|
| 299 |
# next |
|
| 300 |
# } |
|
| 301 | ||
| 302 |
# unrotated 'A' for this set |
|
| 303 | ! |
Alist <- lapply(lambdaList, |
| 304 | ! |
function (x) { x[ov.idx, lv.idx, drop = FALSE] })
|
| 305 |
# std.ov? we use diagonal of Sigma for this set of ov's only |
|
| 306 |
# if (ropts$std.ov) {
|
|
| 307 |
# if (mg.group.equal.flag) {
|
|
| 308 |
# # compute mean THETA across groups |
|
| 309 |
# theta.idx <- which(names(lavmodel@GLIST) == "theta") |
|
| 310 |
# THETA <- Reduce("+", lavmodel@GLIST[theta.idx]) / lavmodel@ngroups
|
|
| 311 |
# } else {
|
|
| 312 |
# THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE] |
|
| 313 |
# } |
|
| 314 |
# Sigma <- tcrossprod(A) + THETA |
|
| 315 |
# this.ov.var <- diag(Sigma) |
|
| 316 |
# } else {
|
|
| 317 | ! |
this.ov.var <- NULL |
| 318 |
# } |
|
| 319 | ||
| 320 |
# init.rot? |
|
| 321 | ! |
if (!is.null(init.rot) && lavoptions$rotation.args$jac.init.rot) {
|
| 322 | ! |
init.rotList <- vector("list", length = lavmodel@ngroups)
|
| 323 | ! |
init.rotList[[g]] <- init.rot[[g]][lv.idx, lv.idx, drop = FALSE] |
| 324 | ! |
rstarts <- 0 |
| 325 |
} else {
|
|
| 326 | ! |
init.rotList <- NULL |
| 327 | ! |
rstarts <- ropts$rstarts |
| 328 |
} |
|
| 329 | ||
| 330 |
# set warn and verbose to ropts-values |
|
| 331 | ! |
current.warn <- lav_warn() |
| 332 | ! |
current.verbose <- lav_verbose() |
| 333 | ! |
if (lav_warn(ropts$warn)) |
| 334 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 335 | ! |
if (lav_verbose(ropts$verbose)) |
| 336 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 337 | ! |
if (lav_verbose()) {
|
| 338 | ! |
cat("\n")
|
| 339 |
} |
|
| 340 | ||
| 341 |
# rotate this set |
|
| 342 | ! |
res <- lav_matrix_rotate_mg( |
| 343 | ! |
Alist = Alist, |
| 344 | ! |
orthogonal = ropts$orthogonal, |
| 345 | ! |
method = method, |
| 346 | ! |
method.args = list( |
| 347 | ! |
geomin.epsilon = ropts$geomin.epsilon, |
| 348 | ! |
orthomax.gamma = ropts$orthomax.gamma, |
| 349 | ! |
cf.gamma = ropts$orthomax.gamma, |
| 350 | ! |
oblimin.gamma = ropts$oblimin.gamma, |
| 351 | ! |
promax.kappa = ropts$promax.kappa, |
| 352 | ! |
target = ropts$target, |
| 353 | ! |
target.mask = ropts$target.mask |
| 354 |
), |
|
| 355 | ! |
init.rotList = init.rotList, |
| 356 | ! |
init.ROT.check = FALSE, |
| 357 | ! |
rstarts = rstarts, |
| 358 |
#row.weights = ropts$row.weights, |
|
| 359 |
#std.ov = ropts$std.ov, |
|
| 360 |
#ov.var = this.ov.var, |
|
| 361 | ! |
mg.algorithm = ropts$mg.agreement.algorithm, |
| 362 | ! |
mg.agreement.method = ropts$mg.agreement.method, |
| 363 | ! |
mg.agreement.weight = ropts$mg.agreement.weight, |
| 364 | ! |
reflect = ropts$reflect, |
| 365 | ! |
order.lv.by = ropts$order.lv.by, |
| 366 |
#gpa.tol = ropts$gpa.tol, |
|
| 367 | ! |
tol = ropts$tol, |
| 368 | ! |
max.iter = ropts$max.iter |
| 369 |
) |
|
| 370 | ! |
for (g in seq_len(lavmodel@ngroups)) {
|
| 371 |
# fill in optimal rotation for this set, for this group |
|
| 372 | ! |
H[[g]][lv.idx, lv.idx] <- res$rotList[[g]] |
| 373 | ||
| 374 |
# keep track of possible re-orderings |
|
| 375 | ! |
ORDER[[g]][lv.idx] <- lv.idx[res$orderList[[g]]] |
| 376 |
} |
|
| 377 |
} # set |
|
| 378 | ||
| 379 |
# rotate all the SEM parameters |
|
| 380 | ! |
for (g in seq_len(lavmodel@ngroups)) {
|
| 381 | ! |
mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g] |
| 382 | ! |
MLIST <- GLIST[mm.in.group] |
| 383 | ! |
Hg <- H[[g]] |
| 384 | ||
| 385 |
# 1. lambda |
|
| 386 | ! |
MLIST$lambda <- t(solve(Hg, t(MLIST$lambda))) |
| 387 | ||
| 388 |
# 2. psi (note: eq 22 Asp & Muthen, 2009: transpose reversed) |
|
| 389 | ! |
MLIST$psi <- t(Hg) %*% MLIST$psi %*% Hg |
| 390 | ||
| 391 |
# 3. beta |
|
| 392 | ! |
if (!is.null(MLIST$beta)) {
|
| 393 | ! |
MLIST$beta <- t(Hg) %*% t(solve(Hg, t(MLIST$beta))) |
| 394 |
} |
|
| 395 | ||
| 396 |
# 4. alpha |
|
| 397 | ! |
if (!is.null(MLIST$alpha)) {
|
| 398 | ! |
MLIST$alpha <- t(Hg) %*% MLIST$alpha |
| 399 |
} |
|
| 400 |
# no need for rotation: nu, theta |
|
| 401 | ||
| 402 | ! |
GLIST[mm.in.group] <- MLIST |
| 403 |
} |
|
| 404 | ||
| 405 |
# rescale lambda again, so that sum-of-squares per columns is the same |
|
| 406 |
# for all groups |
|
| 407 | ! |
lambdaList <- GLIST[names(GLIST) == "lambda"] |
| 408 | ! |
psiList <- GLIST[names(GLIST) == "psi"] |
| 409 | ||
| 410 | ! |
ss_list <- lapply(lambdaList, function(x) colSums(x^2)) |
| 411 | ! |
ss_ave <- Reduce("+", ss_list) / length(ss_list)
|
| 412 | ! |
scale_factor <- vector("list", length = ncol(lambdaList[[1]]))
|
| 413 | ! |
for(g in seq_len(lavmodel@ngroups)) {
|
| 414 | ! |
scale_factor[[g]] <- (sqrt(ss_list[[g]]) / sqrt(ss_ave)) |
| 415 | ! |
lambdaList[[g]] <- t( t(lambdaList[[g]]) / scale_factor[[g]] ) |
| 416 |
} |
|
| 417 | ||
| 418 |
# rescale psiList accordingly |
|
| 419 | ! |
for(g in seq_len(lavmodel@ngroups)) {
|
| 420 | ! |
psiList[[g]] <- ( diag(scale_factor[[g]]) %*% psiList[[g]] %*% |
| 421 | ! |
diag(scale_factor[[g]]) ) |
| 422 |
} |
|
| 423 | ||
| 424 |
# put back in GLIST |
|
| 425 | ! |
GLIST[names(GLIST) == "lambda"] <- lambdaList |
| 426 | ! |
GLIST[names(GLIST) == "psi"] <- psiList |
| 427 | ||
| 428 |
} # option 3 |
|
| 429 | ||
| 430 |
# extract all rotated parameter estimates |
|
| 431 | 4x |
x.rot <- lav_model_get_parameters(lavmodel, GLIST = GLIST, type = type) |
| 432 | ||
| 433 |
# extra? |
|
| 434 | 4x |
if (extra) {
|
| 435 | 4x |
attr(x.rot, "extra") <- list(GLIST = GLIST, H = H, lv.order = ORDER) |
| 436 |
} |
|
| 437 | ||
| 438 |
# return rotated parameter estimates as a vector |
|
| 439 | 4x |
x.rot |
| 440 |
} |
|
| 441 | ||
| 442 | ||
| 443 |
# lower-level function, needed for numDeriv |
|
| 444 |
lav_model_efa_rotate_border_x <- function(x, lavmodel = NULL, |
|
| 445 |
lavoptions = NULL, |
|
| 446 |
lavpartable = NULL) {
|
|
| 447 |
# extract rotation options from lavoptions |
|
| 448 | 1428x |
method <- lavoptions$rotation |
| 449 | 1428x |
ropts <- lavoptions$rotation.args |
| 450 | 1428x |
method.args <- list( |
| 451 | 1428x |
geomin.epsilon = ropts$geomin.epsilon, |
| 452 | 1428x |
orthomax.gamma = ropts$orthomax.gamma, |
| 453 | 1428x |
cf.gamma = ropts$orthomax.gamma, |
| 454 | 1428x |
oblimin.gamma = ropts$oblimin.gamma, |
| 455 | 1428x |
promax.kappa = ropts$oblimin.kappa, |
| 456 | 1428x |
target = ropts$target, |
| 457 | 1428x |
target.mask = ropts$target.mask |
| 458 |
) |
|
| 459 | ||
| 460 |
# place parameters into model matrices |
|
| 461 | 1428x |
lavmodel <- lav_model_set_parameters(lavmodel, x = x) |
| 462 | ||
| 463 |
# GLIST |
|
| 464 | 1428x |
GLIST <- lavmodel@GLIST |
| 465 | ||
| 466 |
# res |
|
| 467 | 1428x |
res <- numeric(0L) |
| 468 | ||
| 469 |
# per group (not per block) |
|
| 470 | 1428x |
for (g in seq_len(lavmodel@ngroups)) {
|
| 471 | ||
| 472 |
# group-specific method.args |
|
| 473 | 1428x |
this.method.args <- method.args |
| 474 | ||
| 475 |
# set group-specific target/target.mask (if needed) |
|
| 476 |
# if target, check target matrix |
|
| 477 | 1428x |
if (method == "target.strict" || method == "pst") {
|
| 478 | ! |
target <- method.args$target |
| 479 | ! |
if (is.list(target)) {
|
| 480 | ! |
this.method.args$target <- target[[g]] |
| 481 |
} |
|
| 482 |
} |
|
| 483 | 1428x |
if (method == "pst") {
|
| 484 | ! |
target.mask <- method.args$target.mask |
| 485 | ! |
if (is.list(target.mask)) {
|
| 486 | ! |
this.method.args$target.mask <- target.mask[[g]] |
| 487 |
} |
|
| 488 |
} |
|
| 489 | ||
| 490 |
# select model matrices for this group |
|
| 491 | 1428x |
mm.in.group <- seq_len(lavmodel@nmat[g]) + cumsum(c(0, lavmodel@nmat))[g] |
| 492 | 1428x |
MLIST <- GLIST[mm.in.group] |
| 493 | ||
| 494 |
# reconstruct full LAMBDA (in case of dummy ov's) |
|
| 495 | 1428x |
LAMBDA.g <- lav_lisrel_lambda( |
| 496 | 1428x |
MLIST = MLIST, |
| 497 | 1428x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 498 | 1428x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 499 | 1428x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 500 | 1428x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 501 | 1428x |
remove.dummy.lv = TRUE |
| 502 |
) |
|
| 503 |
# reconstruct full THETA (in case of dummy ov's) |
|
| 504 | 1428x |
THETA.g <- lav_lisrel_theta( |
| 505 | 1428x |
MLIST = MLIST, |
| 506 | 1428x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 507 | 1428x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 508 | 1428x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 509 | 1428x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]] |
| 510 |
) |
|
| 511 | ||
| 512 |
# setnames |
|
| 513 | 1428x |
set.names <- lav_partable_efa_values(lavpartable) |
| 514 | ||
| 515 |
# for each set |
|
| 516 | 1428x |
for (set in seq_len(lavmodel@nefa)) {
|
| 517 |
# check if we have any user=7 elements in this set |
|
| 518 |
# if not, skip constraints |
|
| 519 | 1428x |
ind.idx <- which(lavpartable$op == "=~" & |
| 520 | 1428x |
lavpartable$group == g & |
| 521 | 1428x |
lavpartable$efa == set.names[set]) |
| 522 | 1428x |
if (!any(lavpartable$user[ind.idx] == 7L)) {
|
| 523 | 193x |
next |
| 524 |
} |
|
| 525 | ||
| 526 |
# which ov/lv's are involved in this set? |
|
| 527 | 1235x |
ov.idx <- lavmodel@ov.efa.idx[[g]][[set]] |
| 528 | 1235x |
lv.idx <- lavmodel@lv.efa.idx[[g]][[set]] |
| 529 | ||
| 530 |
# empty set? |
|
| 531 | 1235x |
if (length(ov.idx) == 0L) {
|
| 532 | ! |
next |
| 533 |
} |
|
| 534 | ||
| 535 |
# just 1 factor? |
|
| 536 | 1235x |
if (length(lv.idx) < 2L) {
|
| 537 | ! |
next |
| 538 |
} |
|
| 539 | ||
| 540 | 1235x |
A <- LAMBDA.g[ov.idx, lv.idx, drop = FALSE] |
| 541 | 1235x |
P <- nrow(A) |
| 542 | 1235x |
M <- ncol(A) |
| 543 | ||
| 544 |
# for oblique, we also need PSI |
|
| 545 | 1235x |
if (!ropts$orthogonal) {
|
| 546 | 1235x |
PSI <- MLIST$psi[lv.idx, lv.idx, drop = FALSE] |
| 547 |
} |
|
| 548 | ||
| 549 |
# std.ov? we use diagonal of Sigma for this set of ov's only |
|
| 550 | 1235x |
if (ropts$std.ov) {
|
| 551 | 1235x |
THETA <- THETA.g[ov.idx, ov.idx, drop = FALSE] |
| 552 | 1235x |
Sigma <- tcrossprod(A) + THETA |
| 553 | 1235x |
this.ov.var <- diag(Sigma) |
| 554 |
} else {
|
|
| 555 | ! |
this.ov.var <- rep(1, P) |
| 556 |
} |
|
| 557 | ||
| 558 |
# choose method |
|
| 559 | 1235x |
method <- tolower(method) |
| 560 | 1235x |
if (method %in% c( |
| 561 | 1235x |
"cf-quartimax", "cf-varimax", "cf-equamax", |
| 562 | 1235x |
"cf-parsimax", "cf-facparsim" |
| 563 |
)) {
|
|
| 564 | ! |
method.fname <- "lav_matrix_rotate_cf" |
| 565 | ! |
this.method.args$cf.gamma <- switch(method, |
| 566 | ! |
"cf-quartimax" = 0, |
| 567 | ! |
"cf-varimax" = 1 / P, |
| 568 | ! |
"cf-equamax" = M / (2 * P), |
| 569 | ! |
"cf-parsimax" = (M - 1) / (P + M - 2), |
| 570 | ! |
"cf-facparsim" = 1 |
| 571 |
) |
|
| 572 | 1235x |
} else if (method == "target.strict") {
|
| 573 | ! |
method.fname <- "lav_matrix_rotate_target" |
| 574 |
} else {
|
|
| 575 | 1235x |
method.fname <- paste("lav_matrix_rotate_", method, sep = "")
|
| 576 |
} |
|
| 577 | ||
| 578 |
# check if rotation method exists |
|
| 579 | 1235x |
check <- try(get(method.fname), silent = TRUE) |
| 580 | 1235x |
if (inherits(check, "try-error")) {
|
| 581 | ! |
lav_msg_stop(gettextf("unknown rotation method: %s", method.fname))
|
| 582 |
} |
|
| 583 | ||
| 584 |
# 1. compute row weigths |
|
| 585 | ||
| 586 |
# 1.a cov -> cor? |
|
| 587 | 1235x |
if (ropts$std.ov) {
|
| 588 | 1235x |
A <- A * 1 / sqrt(this.ov.var) |
| 589 |
} |
|
| 590 | ||
| 591 | 1235x |
if (ropts$row.weights == "none") {
|
| 592 | 1235x |
weights <- rep(1.0, P) |
| 593 | ! |
} else if (ropts$row.weights == "kaiser") {
|
| 594 | ! |
weights <- lav_matrix_rotate_kaiser_weights(A) |
| 595 | ! |
} else if (ropts$row.weights == "cureton-mulaik") {
|
| 596 | ! |
weights <- lav_matrix_rotate_cm_weights(A) |
| 597 |
} else {
|
|
| 598 | ! |
lav_msg_stop(gettextf("row.weights can be",
|
| 599 | ! |
lav_msg_view(c("none", "kaiser", "cureton-mulaik"), "or")))
|
| 600 |
} |
|
| 601 | 1235x |
A <- A * weights |
| 602 | ||
| 603 |
# evaluate rotation criterion, extract GRAD |
|
| 604 | 1235x |
Q <- do.call( |
| 605 | 1235x |
method.fname, |
| 606 | 1235x |
c(list(LAMBDA = A), this.method.args, list(grad = TRUE)) |
| 607 |
) |
|
| 608 | 1235x |
Gq <- attr(Q, "grad") |
| 609 | 1235x |
attr(Q, "grad") <- NULL |
| 610 | ||
| 611 |
# compute 'Z' |
|
| 612 | 1235x |
Z <- crossprod(A, Gq) |
| 613 | ||
| 614 |
# compute constraints |
|
| 615 | 1235x |
if (ropts$orthogonal) {
|
| 616 |
# the constraint: Z == diagonal |
|
| 617 |
# or in other words, the non-diagonal elements of |
|
| 618 |
# Z - t(Z) are all zero |
|
| 619 | ! |
tmp <- Z - t(Z) |
| 620 | ! |
this.res <- lav_matrix_vech(tmp, diagonal = FALSE) |
| 621 |
} else {
|
|
| 622 | 1235x |
PSI.z <- PSI * diag(Z) # rescale rows only |
| 623 | 1235x |
tmp <- Z - PSI.z |
| 624 | 1235x |
out1 <- lav_matrix_vech(tmp, diagonal = FALSE) |
| 625 | 1235x |
out2 <- lav_matrix_vechu(tmp, diagonal = FALSE) |
| 626 | 1235x |
this.res <- c(out1, out2) |
| 627 |
} |
|
| 628 | ||
| 629 | 1235x |
res <- c(res, this.res) |
| 630 |
} # set |
|
| 631 |
} # group |
|
| 632 | ||
| 633 |
# return constraint vector |
|
| 634 | 1428x |
res |
| 635 |
} |
| 1 |
# YR - 26 Nov 2013: generate partable for the unrestricted model |
|
| 2 |
# YR - 19 Mar 2017: handle twolevel model |
|
| 3 |
# YR - 27 May 2021: added lav_partable_unrestricted_chol so we can use |
|
| 4 |
# a cholesky parameterization: S = LAMBDA %*% t(LAMBDA) |
|
| 5 | ||
| 6 |
lav_partable_unrestricted <- function(lavobject = NULL, |
|
| 7 |
# if no object is available, |
|
| 8 |
lavdata = NULL, |
|
| 9 |
lavpta = NULL, |
|
| 10 |
lavoptions = NULL, |
|
| 11 |
lavsamplestats = NULL, |
|
| 12 |
lavh1 = NULL, |
|
| 13 |
# optional user-provided sample stats |
|
| 14 |
sample.cov = NULL, |
|
| 15 |
sample.mean = NULL, |
|
| 16 |
sample.slopes = NULL, |
|
| 17 |
sample.th = NULL, |
|
| 18 |
sample.th.idx = NULL, |
|
| 19 |
sample.cov.x = NULL, |
|
| 20 |
sample.mean.x = NULL) {
|
|
| 21 | ! |
lav_partable_indep_or_unrestricted( |
| 22 | ! |
lavobject = lavobject, |
| 23 | ! |
lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions, |
| 24 | ! |
lavsamplestats = lavsamplestats, lavh1 = lavh1, |
| 25 | ! |
sample.cov = sample.cov, sample.mean = sample.mean, |
| 26 | ! |
sample.slopes = sample.slopes, |
| 27 | ! |
sample.th = sample.th, sample.th.idx = sample.th.idx, |
| 28 | ! |
independent = FALSE |
| 29 |
) |
|
| 30 |
} |
|
| 31 | ||
| 32 |
# generate parameter table for an independence model |
|
| 33 |
# YR - 12 Sep 2017: special case of lav_partable_unrestricted() |
|
| 34 |
lav_partable_independence <- function(lavobject = NULL, |
|
| 35 |
# if no object is available, |
|
| 36 |
lavdata = NULL, |
|
| 37 |
lavpta = NULL, |
|
| 38 |
lavoptions = NULL, |
|
| 39 |
lavsamplestats = NULL, |
|
| 40 |
lavh1 = NULL, |
|
| 41 |
# optional user-provided sample stats |
|
| 42 |
sample.cov = NULL, |
|
| 43 |
sample.mean = NULL, |
|
| 44 |
sample.slopes = NULL, |
|
| 45 |
sample.th = NULL, |
|
| 46 |
sample.th.idx = NULL, |
|
| 47 |
sample.cov.x = NULL, |
|
| 48 |
sample.mean.x = NULL) {
|
|
| 49 | ! |
lav_partable_indep_or_unrestricted( |
| 50 | ! |
lavobject = lavobject, |
| 51 | ! |
lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions, |
| 52 | ! |
lavsamplestats = lavsamplestats, lavh1 = lavh1, |
| 53 | ! |
sample.cov = sample.cov, sample.mean = sample.mean, |
| 54 | ! |
sample.slopes = sample.slopes, |
| 55 | ! |
sample.th = sample.th, sample.th.idx = sample.th.idx, |
| 56 | ! |
independent = TRUE |
| 57 |
) |
|
| 58 |
} |
|
| 59 | ||
| 60 |
lav_partable_indep_or_unrestricted <- function(lavobject = NULL, |
|
| 61 |
# if no object is available, |
|
| 62 |
lavdata = NULL, |
|
| 63 |
lavpta = NULL, |
|
| 64 |
lavoptions = NULL, |
|
| 65 |
lavsamplestats = NULL, |
|
| 66 |
lavh1 = NULL, |
|
| 67 |
# optional user-provided sample stats |
|
| 68 |
sample.cov = NULL, |
|
| 69 |
sample.mean = NULL, |
|
| 70 |
sample.slopes = NULL, |
|
| 71 |
sample.th = NULL, |
|
| 72 |
sample.th.idx = NULL, |
|
| 73 |
sample.cov.x = NULL, |
|
| 74 |
sample.mean.x = NULL, |
|
| 75 |
independent = FALSE) {
|
|
| 76 |
# grab everything from lavaan lavobject |
|
| 77 | 61x |
if (!is.null(lavobject)) {
|
| 78 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 79 | ||
| 80 | ! |
lavdata <- lavobject@Data |
| 81 | ! |
lavoptions <- lavobject@Options |
| 82 | ! |
lavsamplestats <- lavobject@SampleStats |
| 83 | ! |
lavpta <- lavobject@pta |
| 84 | ! |
lavh1 <- lavobject@h1 |
| 85 |
} |
|
| 86 | ||
| 87 | 61x |
if (lavdata@data.type == "none") {
|
| 88 | ! |
lavsamplestats <- NULL |
| 89 |
} |
|
| 90 | ||
| 91 |
# conditional.x ? check res.cov[[1]] slot |
|
| 92 | 61x |
conditional.x <- FALSE |
| 93 | 61x |
if (!is.null(lavsamplestats) && !is.null(lavsamplestats@res.cov[[1]])) {
|
| 94 | 2x |
conditional.x <- TRUE |
| 95 | 59x |
} else if (!is.null(lavoptions) && lavoptions$conditional.x) {
|
| 96 | ! |
conditional.x <- TRUE |
| 97 |
} |
|
| 98 | ||
| 99 |
# group.w.free? |
|
| 100 | 61x |
group.w.free <- FALSE |
| 101 | 61x |
if (!is.null(lavoptions) && lavoptions$group.w.free) {
|
| 102 | ! |
group.w.free <- TRUE |
| 103 |
} |
|
| 104 |
# we use CAPS below for the list version, so we can use 'small caps' |
|
| 105 |
# within the for() loop |
|
| 106 | ||
| 107 |
# get sample statistics, all groups |
|
| 108 | 61x |
SAMPLE.cov <- sample.cov |
| 109 | 61x |
if (is.null(SAMPLE.cov) && !is.null(lavsamplestats)) {
|
| 110 | 61x |
if (conditional.x) {
|
| 111 | 2x |
SAMPLE.cov <- lavsamplestats@res.cov |
| 112 |
} else {
|
|
| 113 | 59x |
SAMPLE.cov <- lavsamplestats@cov |
| 114 |
} |
|
| 115 |
} |
|
| 116 | ||
| 117 | 61x |
SAMPLE.mean <- sample.mean |
| 118 | 61x |
if (is.null(SAMPLE.mean) && !is.null(lavsamplestats)) {
|
| 119 | 61x |
if (conditional.x) {
|
| 120 | 2x |
SAMPLE.mean <- lavsamplestats@res.int |
| 121 |
} else {
|
|
| 122 | 59x |
SAMPLE.mean <- lavsamplestats@mean |
| 123 |
} |
|
| 124 |
} |
|
| 125 | ||
| 126 | 61x |
SAMPLE.slopes <- sample.slopes |
| 127 | 61x |
if (conditional.x && is.null(SAMPLE.slopes) && !is.null(lavsamplestats)) {
|
| 128 | 2x |
SAMPLE.slopes <- lavsamplestats@res.slopes |
| 129 |
} |
|
| 130 | ||
| 131 | 61x |
SAMPLE.th <- sample.th |
| 132 | 61x |
if (is.null(SAMPLE.th) && !is.null(lavsamplestats)) {
|
| 133 | 61x |
if (conditional.x) {
|
| 134 | 2x |
SAMPLE.th <- lavsamplestats@res.th |
| 135 |
} else {
|
|
| 136 | 59x |
SAMPLE.th <- lavsamplestats@th |
| 137 |
} |
|
| 138 |
} |
|
| 139 | ||
| 140 | 61x |
SAMPLE.th.idx <- sample.th.idx |
| 141 | 61x |
if (is.null(SAMPLE.th.idx) && !is.null(lavsamplestats)) {
|
| 142 | 61x |
SAMPLE.th.idx <- lavsamplestats@th.idx |
| 143 |
} |
|
| 144 | ||
| 145 | 61x |
SAMPLE.cov.x <- sample.cov.x |
| 146 | 61x |
if (is.null(SAMPLE.cov.x) && !is.null(lavsamplestats)) {
|
| 147 | 61x |
SAMPLE.cov.x <- lavsamplestats@cov.x |
| 148 |
} |
|
| 149 | ||
| 150 | 61x |
SAMPLE.mean.x <- sample.mean.x |
| 151 | 61x |
if (is.null(SAMPLE.mean.x) && !is.null(lavsamplestats)) {
|
| 152 | 61x |
SAMPLE.mean.x <- lavsamplestats@mean.x |
| 153 |
} |
|
| 154 | ||
| 155 | ||
| 156 | ||
| 157 | 61x |
ov <- lavdata@ov |
| 158 | 61x |
meanstructure <- lavoptions$meanstructure |
| 159 | 61x |
categorical <- any(ov$type == "ordered") |
| 160 | 61x |
ngroups <- lavdata@ngroups |
| 161 | 61x |
nlevels <- lavdata@nlevels |
| 162 | 61x |
if (lavoptions$estimator == "catML") {
|
| 163 | ! |
categorical <- FALSE |
| 164 |
} |
|
| 165 | 61x |
correlation <- FALSE |
| 166 | 61x |
if (!is.null(lavoptions$correlation)) {
|
| 167 | 61x |
correlation <- lavoptions$correlation |
| 168 |
} |
|
| 169 | ||
| 170 |
# what with fixed.x? |
|
| 171 |
# - does not really matter; fit will be saturated anyway |
|
| 172 |
# - fixed.x = TRUE may avoid convergence issues with non-numeric |
|
| 173 |
# x-covariates |
|
| 174 | 61x |
fixed.x <- lavoptions$fixed.x |
| 175 | ||
| 176 |
# if multilevel |
|
| 177 | 61x |
if (nlevels > 1L) {
|
| 178 |
# fixed.x <- FALSE # for now |
|
| 179 | 2x |
conditional.x <- FALSE # for now |
| 180 | 2x |
categorical <- FALSE # for now |
| 181 |
} |
|
| 182 | ||
| 183 | 61x |
lhs <- rhs <- op <- character(0) |
| 184 | 61x |
group <- block <- level <- free <- exo <- integer(0) |
| 185 | 61x |
ustart <- numeric(0) |
| 186 | ||
| 187 |
# block number |
|
| 188 | 61x |
b <- 0L |
| 189 | 61x |
for (g in 1:ngroups) {
|
| 190 |
# only for multilevel |
|
| 191 | 65x |
if (nlevels > 1L) {
|
| 192 | 4x |
YLp <- lavsamplestats@YLp[[g]] |
| 193 | 4x |
Lp <- lavdata@Lp[[g]] |
| 194 |
} |
|
| 195 | ||
| 196 |
# local copy |
|
| 197 | 65x |
sample.cov <- SAMPLE.cov[[g]] |
| 198 | 65x |
sample.mean <- SAMPLE.mean[[g]] |
| 199 | 65x |
sample.slopes <- SAMPLE.slopes[[g]] |
| 200 | 65x |
sample.th <- SAMPLE.th[[g]] |
| 201 | 65x |
sample.th.idx <- SAMPLE.th.idx[[g]] |
| 202 | 65x |
sample.cov.x <- SAMPLE.cov.x[[g]] |
| 203 | 65x |
sample.mean.x <- SAMPLE.mean.x[[g]] |
| 204 | ||
| 205 |
# force local sample.cov to be pd -- just for starting values anyway |
|
| 206 | 65x |
if (!is.null(sample.cov) && !anyNA(sample.cov)) {
|
| 207 | 65x |
sample.cov <- lav_matrix_symmetric_force_pd(sample.cov) |
| 208 |
} |
|
| 209 | ||
| 210 | 65x |
for (l in 1:nlevels) {
|
| 211 |
# block |
|
| 212 | 69x |
b <- b + 1L |
| 213 | ||
| 214 |
# ov.names for this block |
|
| 215 | 69x |
if (is.null(lavpta)) { # only data was used
|
| 216 | ! |
if (nlevels > 1L) {
|
| 217 | ! |
ov.names <- lavdata@ov.names.l[[g]][[(ngroups - 1)*g + b]] |
| 218 |
} else {
|
|
| 219 | ! |
ov.names <- lavdata@ov.names[[g]] |
| 220 |
} |
|
| 221 | ! |
ov.names.x <- lavdata@ov.names.x[[g]] |
| 222 | ! |
ov.names.nox <- ov.names[!ov.names %in% ov.names.x] |
| 223 |
} else {
|
|
| 224 | 69x |
if (conditional.x) {
|
| 225 | 2x |
ov.names <- lavpta$vnames$ov.nox[[b]] |
| 226 |
} else {
|
|
| 227 | 67x |
ov.names <- lavpta$vnames$ov[[b]] |
| 228 |
} |
|
| 229 | 69x |
ov.names.x <- lavpta$vnames$ov.x[[b]] |
| 230 | 69x |
ov.names.nox <- lavpta$vnames$ov.nox[[b]] |
| 231 |
} |
|
| 232 | ||
| 233 |
# only for multilevel, overwrite sample.cov and sample.mean |
|
| 234 | 69x |
if (nlevels > 1L) {
|
| 235 | 8x |
if (independent) {
|
| 236 |
# beter use lavdata@Lp[[g]]$ov.x.idx?? |
|
| 237 |
# in case we have x/y mismatch across levels? |
|
| 238 | 8x |
ov.x.idx <- lavpta$vidx$ov.x[[b]] |
| 239 | 8x |
ov.names.x <- lavpta$vnames$ov.x[[b]] |
| 240 | 8x |
ov.names.nox <- lavpta$vnames$ov.nox[[b]] |
| 241 | 8x |
sample.cov.x <- lavh1$implied$cov[[b]][ov.x.idx, |
| 242 | 8x |
ov.x.idx, |
| 243 | 8x |
drop = FALSE |
| 244 |
] |
|
| 245 | 8x |
sample.mean.x <- lavh1$implied$mean[[b]][ov.x.idx] |
| 246 |
} else {
|
|
| 247 | ! |
ov.names.x <- character(0L) |
| 248 | ! |
ov.names.nox <- ov.names |
| 249 |
} |
|
| 250 | ||
| 251 | 8x |
if (length(lavh1) > 0L) {
|
| 252 | 8x |
sample.cov <- lavh1$implied$cov[[b]] |
| 253 | 8x |
sample.mean <- lavh1$implied$mean[[b]] |
| 254 |
} else {
|
|
| 255 | ! |
sample.cov <- diag(length(ov.names)) |
| 256 | ! |
sample.mean <- numeric(length(ov.names)) |
| 257 |
} |
|
| 258 | ||
| 259 |
# if(l == 1L) {
|
|
| 260 |
# sample.cov <- YLp[[2]]$Sigma.W[block.idx, block.idx, |
|
| 261 |
# drop = FALSE] |
|
| 262 |
# sample.mean <- YLp[[2]]$Mu.W[block.idx] |
|
| 263 |
# } else {
|
|
| 264 |
# sample.cov <- YLp[[2]]$Sigma.B[block.idx, block.idx, |
|
| 265 |
# drop = FALSE] |
|
| 266 |
# sample.mean <- YLp[[2]]$Mu.B[block.idx] |
|
| 267 |
# } |
|
| 268 | ||
| 269 |
# force local sample.cov to be strictly pd (and exaggerate) |
|
| 270 |
# just for starting values anyway, but at least the first |
|
| 271 |
# evaluation will be feasible |
|
| 272 | 8x |
sample.cov <- lav_matrix_symmetric_force_pd(sample.cov, |
| 273 | 8x |
tol = 1e-03 |
| 274 |
) |
|
| 275 |
} |
|
| 276 | ||
| 277 | ||
| 278 |
# a) VARIANCES (all ov's, if !conditional.x, also exo's) |
|
| 279 | 69x |
nvar <- length(ov.names) |
| 280 | ||
| 281 | 69x |
lhs <- c(lhs, ov.names) |
| 282 | 69x |
op <- c(op, rep("~~", nvar))
|
| 283 | 69x |
rhs <- c(rhs, ov.names) |
| 284 | 69x |
block <- c(block, rep(b, nvar)) |
| 285 | 69x |
group <- c(group, rep(g, nvar)) |
| 286 | 69x |
level <- c(level, rep(l, nvar)) |
| 287 | 69x |
if (correlation) {
|
| 288 | ! |
free <- c(free, rep(0L, nvar)) |
| 289 |
} else {
|
|
| 290 | 69x |
free <- c(free, rep(1L, nvar)) |
| 291 |
} |
|
| 292 | 69x |
exo <- c(exo, rep(0L, nvar)) |
| 293 | ||
| 294 |
# starting values -- variances |
|
| 295 | 69x |
if (correlation) {
|
| 296 | ! |
ustart <- c(ustart, rep(1, nvar)) |
| 297 | 69x |
} else if (!is.null(sample.cov)) {
|
| 298 | 69x |
ustart <- c(ustart, diag(sample.cov)) |
| 299 |
} else {
|
|
| 300 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nvar)) |
| 301 |
} |
|
| 302 | ||
| 303 |
# COVARIANCES! |
|
| 304 | 69x |
if (!independent) {
|
| 305 | ! |
pstar <- nvar * (nvar - 1) / 2 |
| 306 | ! |
if (pstar > 0L) { # only if more than 1 variable
|
| 307 | ! |
tmp <- utils::combn(ov.names, 2) |
| 308 | ! |
lhs <- c(lhs, tmp[1, ]) # to fill upper.tri |
| 309 | ! |
op <- c(op, rep("~~", pstar))
|
| 310 | ! |
rhs <- c(rhs, tmp[2, ]) |
| 311 | ! |
block <- c(block, rep(b, pstar)) |
| 312 | ! |
group <- c(group, rep(g, pstar)) |
| 313 | ! |
level <- c(level, rep(l, pstar)) |
| 314 | ! |
free <- c(free, rep(1L, pstar)) |
| 315 | ! |
exo <- c(exo, rep(0L, pstar)) |
| 316 |
} |
|
| 317 | ||
| 318 |
# starting values -- covariances |
|
| 319 | ! |
if (!is.null(sample.cov)) {
|
| 320 | ! |
sample.cov.vech <- lav_matrix_vech(sample.cov, diagonal = FALSE) |
| 321 | ! |
ustart <- c(ustart, sample.cov.vech) |
| 322 |
# check for 'missing by design' cells: here, the sample.cov |
|
| 323 |
# element is *exactly* zero (new in 0.6-18) |
|
| 324 | ! |
zero.cov <- which(sample.cov.vech == 0) |
| 325 | ! |
if (length(zero.cov) > 0L && !is.null(lavh1)) {
|
| 326 | ! |
n.tmp <- length(free) |
| 327 | ! |
ones.and.zeroes <- rep(1L, pstar) |
| 328 | ! |
ones.and.zeroes[zero.cov] <- 0L |
| 329 | ! |
free[(n.tmp - pstar + 1):n.tmp] <- ones.and.zeroes |
| 330 |
} |
|
| 331 |
} else {
|
|
| 332 | ! |
ustart <- c(ustart, rep(as.numeric(NA), pstar)) |
| 333 |
} |
|
| 334 |
} |
|
| 335 | ||
| 336 |
# ordered? fix variances, add thresholds |
|
| 337 | 69x |
ord.names <- character(0L) |
| 338 | 69x |
if (categorical) {
|
| 339 | 2x |
ord.names <- ov$name[ov$type == "ordered"] |
| 340 |
# only for this group |
|
| 341 | 2x |
ord.names <- ov.names[which(ov.names %in% ord.names)] |
| 342 | ||
| 343 | 2x |
if (length(ord.names) > 0L) {
|
| 344 |
# fix variances to 1.0 |
|
| 345 | 2x |
idx <- which(lhs %in% ord.names & op == "~~" & lhs == rhs) |
| 346 | 2x |
ustart[idx] <- 1.0 |
| 347 | 2x |
free[idx] <- 0L |
| 348 | ||
| 349 |
# add thresholds |
|
| 350 | 2x |
lhs.th <- character(0) |
| 351 | 2x |
rhs.th <- character(0) |
| 352 | 2x |
for (o in ord.names) {
|
| 353 | 8x |
nth <- ov$nlev[ov$name == o] - 1L |
| 354 | ! |
if (nth < 1L) next |
| 355 | 8x |
lhs.th <- c(lhs.th, rep(o, nth)) |
| 356 | 8x |
rhs.th <- c(rhs.th, paste("t", seq_len(nth), sep = ""))
|
| 357 |
} |
|
| 358 | 2x |
nel <- length(lhs.th) |
| 359 | 2x |
lhs <- c(lhs, lhs.th) |
| 360 | 2x |
rhs <- c(rhs, rhs.th) |
| 361 | 2x |
op <- c(op, rep("|", nel))
|
| 362 | 2x |
block <- c(block, rep(b, nel)) |
| 363 | 2x |
group <- c(group, rep(g, nel)) |
| 364 | 2x |
level <- c(level, rep(l, nel)) |
| 365 | 2x |
free <- c(free, rep(1L, nel)) |
| 366 | 2x |
exo <- c(exo, rep(0L, nel)) |
| 367 | ||
| 368 |
# starting values |
|
| 369 | 2x |
if (!is.null(sample.th) && !is.null(sample.th.idx)) {
|
| 370 | 2x |
th.start <- sample.th[sample.th.idx > 0L] |
| 371 | 2x |
ustart <- c(ustart, th.start) |
| 372 |
} else {
|
|
| 373 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nel)) |
| 374 |
} |
|
| 375 | ||
| 376 |
# fixed-to-zero intercepts (since 0.5.17) |
|
| 377 | 2x |
ov.int <- ord.names |
| 378 | 2x |
nel <- length(ov.int) |
| 379 | 2x |
lhs <- c(lhs, ov.int) |
| 380 | 2x |
op <- c(op, rep("~1", nel))
|
| 381 | 2x |
rhs <- c(rhs, rep("", nel))
|
| 382 | 2x |
block <- c(block, rep(b, nel)) |
| 383 | 2x |
group <- c(group, rep(g, nel)) |
| 384 | 2x |
level <- c(level, rep(l, nel)) |
| 385 | 2x |
free <- c(free, rep(0L, nel)) |
| 386 | 2x |
exo <- c(exo, rep(0L, nel)) |
| 387 | 2x |
ustart <- c(ustart, rep(0, nel)) |
| 388 | ||
| 389 |
# ~*~ (since 0.6-1) |
|
| 390 | 2x |
nel <- length(ov.int) |
| 391 | 2x |
lhs <- c(lhs, ov.int) |
| 392 | 2x |
op <- c(op, rep("~*~", nel))
|
| 393 | 2x |
rhs <- c(rhs, ov.int) |
| 394 | 2x |
block <- c(block, rep(b, nel)) |
| 395 | 2x |
group <- c(group, rep(g, nel)) |
| 396 | 2x |
level <- c(level, rep(l, nel)) |
| 397 | 2x |
free <- c(free, rep(0L, nel)) |
| 398 | 2x |
exo <- c(exo, rep(0L, nel)) |
| 399 | 2x |
ustart <- c(ustart, rep(1, nel)) |
| 400 |
} |
|
| 401 |
} # categorical |
|
| 402 | ||
| 403 |
# correlation structure? |
|
| 404 | 69x |
if (!categorical && correlation) {
|
| 405 | ! |
nel <- nvar |
| 406 | ! |
lhs <- c(lhs, ov.names) |
| 407 | ! |
op <- c(op, rep("~*~", nel))
|
| 408 | ! |
rhs <- c(rhs, ov.names) |
| 409 | ! |
block <- c(block, rep(b, nel)) |
| 410 | ! |
group <- c(group, rep(g, nel)) |
| 411 | ! |
level <- c(level, rep(l, nel)) |
| 412 | ! |
free <- c(free, rep(0L, nel)) |
| 413 | ! |
exo <- c(exo, rep(0L, nel)) |
| 414 | ! |
ustart <- c(ustart, rep(1, nel)) |
| 415 |
} |
|
| 416 | ||
| 417 |
# meanstructure? |
|
| 418 | 69x |
if (meanstructure) {
|
| 419 |
# auto-remove ordinal variables |
|
| 420 | 47x |
ov.int <- ov.names |
| 421 | 47x |
idx <- which(ov.int %in% ord.names) |
| 422 | 2x |
if (length(idx)) ov.int <- ov.int[-idx] |
| 423 | ||
| 424 | 47x |
nel <- length(ov.int) |
| 425 | 47x |
lhs <- c(lhs, ov.int) |
| 426 | 47x |
op <- c(op, rep("~1", nel))
|
| 427 | 47x |
rhs <- c(rhs, rep("", nel))
|
| 428 | 47x |
block <- c(block, rep(b, nel)) |
| 429 | 47x |
group <- c(group, rep(g, nel)) |
| 430 | 47x |
level <- c(level, rep(l, nel)) |
| 431 |
# if multilevel, level=1 has fixed zeroes |
|
| 432 | 47x |
if (nlevels > 1L && l == 1L) {
|
| 433 | 4x |
WITHIN <- rep(0L, nel) |
| 434 |
# FIXME: assuming 1 group |
|
| 435 | 4x |
within.idx <- match(Lp$within.idx[[2]], Lp$ov.idx[[1]]) |
| 436 | 4x |
WITHIN[within.idx] <- 1L |
| 437 | 4x |
free <- c(free, WITHIN) |
| 438 |
} else {
|
|
| 439 | 43x |
free <- c(free, rep(1L, nel)) |
| 440 |
} |
|
| 441 | 47x |
exo <- c(exo, rep(0L, nel)) |
| 442 | ||
| 443 |
# starting values |
|
| 444 | 47x |
if (!is.null(sample.mean)) {
|
| 445 | 47x |
sample.int.idx <- match(ov.int, ov.names) |
| 446 | 47x |
ustart <- c(ustart, sample.mean[sample.int.idx]) |
| 447 |
} else {
|
|
| 448 | ! |
ustart <- c(ustart, rep(as.numeric(NA), length(ov.int))) |
| 449 |
} |
|
| 450 |
} |
|
| 451 | ||
| 452 | ||
| 453 |
# fixed.x exogenous variables? |
|
| 454 | 69x |
if (!conditional.x && (nx <- length(ov.names.x)) > 0L) {
|
| 455 | 26x |
if (independent && lavoptions$baseline.fixed.x.free.cov) {
|
| 456 |
# add covariances for eXo |
|
| 457 | 26x |
pstar <- nx * (nx - 1) / 2 |
| 458 | 26x |
if (pstar > 0L) { # only if more than 1 variable
|
| 459 | 26x |
tmp <- utils::combn(ov.names.x, 2) |
| 460 | 26x |
lhs <- c(lhs, tmp[1, ]) # to fill upper.tri |
| 461 | 26x |
op <- c(op, rep("~~", pstar))
|
| 462 | 26x |
rhs <- c(rhs, tmp[2, ]) |
| 463 | 26x |
block <- c(block, rep(b, pstar)) |
| 464 | 26x |
group <- c(group, rep(g, pstar)) |
| 465 | 26x |
level <- c(level, rep(l, pstar)) |
| 466 | 26x |
free <- c(free, rep(1L, pstar)) |
| 467 | 26x |
exo <- c(exo, rep(0L, pstar)) |
| 468 | ||
| 469 |
# starting values |
|
| 470 | 26x |
if (!is.null(sample.cov.x)) {
|
| 471 | 24x |
rhs.idx <- match(tmp[1, ], ov.names.x) |
| 472 | 24x |
lhs.idx <- match(tmp[2, ], ov.names.x) |
| 473 | 24x |
ustart <- c( |
| 474 | 24x |
ustart, |
| 475 | 24x |
sample.cov.x[cbind(rhs.idx, lhs.idx)] |
| 476 |
) |
|
| 477 |
} else {
|
|
| 478 | 2x |
ustart <- c(ustart, rep(as.numeric(NA), pstar)) |
| 479 |
} |
|
| 480 |
} |
|
| 481 |
} |
|
| 482 | ||
| 483 | 26x |
if (fixed.x) {
|
| 484 |
# fix variances/covariances |
|
| 485 | 24x |
exo.idx <- which(rhs %in% ov.names.x & |
| 486 | 24x |
lhs %in% ov.names.x & |
| 487 | 24x |
op == "~~" & group == g) # ok |
| 488 | 24x |
exo[exo.idx] <- 1L |
| 489 | 24x |
free[exo.idx] <- 0L |
| 490 | ||
| 491 |
# fix means |
|
| 492 | 24x |
exo.idx <- which(lhs %in% ov.names.x & |
| 493 | 24x |
op == "~1" & group == g) # ok |
| 494 | 24x |
exo[exo.idx] <- 1L |
| 495 | 24x |
free[exo.idx] <- 0L |
| 496 |
} |
|
| 497 |
} |
|
| 498 | ||
| 499 |
# conditional.x? |
|
| 500 | 69x |
if (conditional.x && (nx <- length(ov.names.x)) > 0L) {
|
| 501 |
# eXo variances |
|
| 502 | 2x |
nel <- length(ov.names.x) |
| 503 | 2x |
lhs <- c(lhs, ov.names.x) |
| 504 | 2x |
op <- c(op, rep("~~", nel))
|
| 505 | 2x |
rhs <- c(rhs, ov.names.x) |
| 506 | 2x |
block <- c(block, rep(b, nel)) |
| 507 | 2x |
group <- c(group, rep(g, nel)) |
| 508 | 2x |
level <- c(level, rep(l, nel)) |
| 509 | 2x |
if (fixed.x) {
|
| 510 | 2x |
free <- c(free, rep(0L, nel)) |
| 511 | 2x |
exo <- c(exo, rep(1L, nel)) |
| 512 |
} else {
|
|
| 513 | ! |
free <- c(free, rep(1L, nel)) |
| 514 | ! |
exo <- c(exo, rep(0L, nel)) |
| 515 |
} |
|
| 516 | ||
| 517 |
# starting values |
|
| 518 | 2x |
if (!is.null(sample.cov.x)) {
|
| 519 | 2x |
ustart <- c(ustart, diag(sample.cov.x)) |
| 520 |
} else {
|
|
| 521 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nel)) |
| 522 |
} |
|
| 523 | ||
| 524 | ||
| 525 |
# eXo covariances |
|
| 526 | 2x |
pstar <- nx * (nx - 1) / 2 |
| 527 | 2x |
if (pstar > 0L) { # only if more than 1 variable
|
| 528 | ! |
tmp <- utils::combn(ov.names.x, 2) |
| 529 | ! |
lhs <- c(lhs, tmp[1, ]) # to fill upper.tri |
| 530 | ! |
op <- c(op, rep("~~", pstar))
|
| 531 | ! |
rhs <- c(rhs, tmp[2, ]) |
| 532 | ! |
block <- c(block, rep(b, pstar)) |
| 533 | ! |
group <- c(group, rep(g, pstar)) |
| 534 | ! |
level <- c(level, rep(l, pstar)) |
| 535 | ! |
if (fixed.x) {
|
| 536 | ! |
free <- c(free, rep(0L, pstar)) |
| 537 | ! |
exo <- c(exo, rep(1L, pstar)) |
| 538 |
} else {
|
|
| 539 | ! |
free <- c(free, rep(1L, pstar)) |
| 540 | ! |
exo <- c(exo, rep(0L, pstar)) |
| 541 |
} |
|
| 542 | ||
| 543 |
# starting values |
|
| 544 | ! |
if (!is.null(sample.cov.x)) {
|
| 545 | ! |
rhs.idx <- match(tmp[1, ], ov.names.x) |
| 546 | ! |
lhs.idx <- match(tmp[2, ], ov.names.x) |
| 547 | ! |
ustart <- c( |
| 548 | ! |
ustart, |
| 549 | ! |
sample.cov.x[cbind(rhs.idx, lhs.idx)] |
| 550 |
) |
|
| 551 |
} else {
|
|
| 552 | ! |
ustart <- c(ustart, rep(as.numeric(NA), pstar)) |
| 553 |
} |
|
| 554 |
} |
|
| 555 | ||
| 556 |
# eXo means |
|
| 557 | 2x |
if (meanstructure) {
|
| 558 | 2x |
ov.int <- ov.names.x |
| 559 | ||
| 560 | 2x |
nel <- length(ov.int) |
| 561 | 2x |
lhs <- c(lhs, ov.int) |
| 562 | 2x |
op <- c(op, rep("~1", nel))
|
| 563 | 2x |
rhs <- c(rhs, rep("", nel))
|
| 564 | 2x |
group <- c(group, rep(g, nel)) |
| 565 | 2x |
block <- c(block, rep(b, nel)) |
| 566 | 2x |
level <- c(level, rep(l, nel)) |
| 567 | 2x |
if (fixed.x) {
|
| 568 | 2x |
free <- c(free, rep(0L, nel)) |
| 569 | 2x |
exo <- c(exo, rep(1L, nel)) |
| 570 |
} else {
|
|
| 571 | ! |
free <- c(free, rep(1L, nel)) |
| 572 | ! |
exo <- c(exo, rep(0L, nel)) |
| 573 |
} |
|
| 574 | ||
| 575 |
# starting values |
|
| 576 | 2x |
if (!is.null(sample.mean.x)) {
|
| 577 | 2x |
sample.int.idx <- match(ov.int, ov.names.x) |
| 578 | 2x |
ustart <- c(ustart, sample.mean.x[sample.int.idx]) |
| 579 |
} else {
|
|
| 580 | ! |
ustart <- c(ustart, rep(as.numeric(NA), length(ov.int))) |
| 581 |
} |
|
| 582 |
} |
|
| 583 | ||
| 584 |
# slopes |
|
| 585 | 2x |
nnox <- length(ov.names.nox) |
| 586 | 2x |
nel <- nnox * nx |
| 587 | ||
| 588 | 2x |
lhs <- c(lhs, rep(ov.names.nox, times = nx)) |
| 589 | 2x |
op <- c(op, rep("~", nel))
|
| 590 | 2x |
rhs <- c(rhs, rep(ov.names.x, each = nnox)) |
| 591 | 2x |
block <- c(block, rep(b, nel)) |
| 592 | 2x |
group <- c(group, rep(g, nel)) |
| 593 | 2x |
level <- c(level, rep(l, nel)) |
| 594 | 2x |
if (independent) {
|
| 595 | 2x |
if (lavoptions$baseline.conditional.x.free.slopes) {
|
| 596 | 2x |
free <- c(free, rep(1L, nel)) |
| 597 |
} else {
|
|
| 598 | ! |
free <- c(free, rep(0L, nel)) |
| 599 |
} |
|
| 600 |
} else {
|
|
| 601 | ! |
free <- c(free, rep(1L, nel)) |
| 602 |
} |
|
| 603 | 2x |
exo <- c(exo, rep(1L, nel)) |
| 604 | ||
| 605 |
# starting values -- slopes |
|
| 606 | 2x |
if (independent) {
|
| 607 |
# FIXME: zero slope-structure provides a fit that |
|
| 608 |
# is equal to the conditional.x = FALSE version; |
|
| 609 |
# in principle, we could just fix the slope-structure |
|
| 610 |
# to the sample-based slopes |
|
| 611 | ||
| 612 |
# to get the old behaviour: |
|
| 613 | 2x |
if (!lavoptions$baseline.conditional.x.free.slopes) {
|
| 614 | ! |
ustart <- c(ustart, rep(0, nel)) |
| 615 |
} else {
|
|
| 616 |
# but we probably should do: |
|
| 617 | 2x |
ustart <- c(ustart, lav_matrix_vec(sample.slopes)) |
| 618 |
} |
|
| 619 | ! |
} else if (!is.null(sample.slopes)) {
|
| 620 | ! |
ustart <- c(ustart, lav_matrix_vec(sample.slopes)) |
| 621 |
} else {
|
|
| 622 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nel)) |
| 623 |
} |
|
| 624 |
} # conditional.x |
|
| 625 | ||
| 626 |
# group.w.free (new in 0.6-8) |
|
| 627 | 69x |
if (group.w.free) {
|
| 628 | ! |
lhs <- c(lhs, "group") |
| 629 | ! |
op <- c(op, "%") |
| 630 | ! |
rhs <- c(rhs, "w") |
| 631 | ! |
block <- c(block, b) |
| 632 | ! |
group <- c(group, g) |
| 633 | ! |
level <- c(level, l) |
| 634 | ! |
free <- c(free, 1L) |
| 635 | ! |
exo <- c(exo, 0L) |
| 636 | ! |
ustart <- c(ustart, lavsamplestats@WLS.obs[[g]][1]) |
| 637 |
} |
|
| 638 |
} # levels |
|
| 639 |
} # ngroups |
|
| 640 | ||
| 641 |
# free counter |
|
| 642 | 61x |
idx.free <- which(free > 0) |
| 643 | 61x |
free[idx.free] <- 1:length(idx.free) |
| 644 | ||
| 645 | 61x |
LIST <- list( |
| 646 | 61x |
id = 1:length(lhs), |
| 647 | 61x |
lhs = lhs, |
| 648 | 61x |
op = op, |
| 649 | 61x |
rhs = rhs, |
| 650 | 61x |
user = rep(1L, length(lhs)), |
| 651 | 61x |
block = block, |
| 652 | 61x |
group = group, |
| 653 | 61x |
level = level, |
| 654 | 61x |
free = free, |
| 655 | 61x |
ustart = ustart, |
| 656 | 61x |
exo = exo # , |
| 657 |
# label = rep("", length(lhs))
|
|
| 658 |
# eq.id = rep(0L, length(lhs)), |
|
| 659 |
# unco = free |
|
| 660 |
) |
|
| 661 | ||
| 662 | ||
| 663 |
# keep level column if no levels? (no for now) |
|
| 664 | 61x |
if (nlevels < 2L) {
|
| 665 | 59x |
LIST$level <- NULL |
| 666 |
} |
|
| 667 | ||
| 668 | 61x |
LIST |
| 669 |
} |
|
| 670 | ||
| 671 |
# - currently only used for continuous twolevel data |
|
| 672 |
# - conditional.x not supported (yet) |
|
| 673 |
lav_partable_unrestricted_chol <- function(lavobject = NULL, |
|
| 674 |
# if no object is available, |
|
| 675 |
lavdata = NULL, |
|
| 676 |
lavpta = NULL, # optional |
|
| 677 |
lavoptions = NULL, |
|
| 678 |
group = NULL) {
|
|
| 679 |
# grab everything from lavaan lavobject |
|
| 680 | ! |
if (!is.null(lavobject)) {
|
| 681 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 682 | ||
| 683 | ! |
lavdata <- lavobject@Data |
| 684 | ! |
lavoptions <- lavobject@Options |
| 685 |
# lavsamplestats <- lavobject@SampleStats |
|
| 686 | ! |
lavpta <- lavobject@pta |
| 687 |
# lavh1 <- lavobject@h1 |
|
| 688 |
} |
|
| 689 | ||
| 690 | ! |
ov <- lavdata@ov |
| 691 | ! |
meanstructure <- lavoptions$meanstructure |
| 692 | ! |
categorical <- any(ov$type == "ordered") |
| 693 | ! |
if (categorical) {
|
| 694 | ! |
lav_msg_stop(gettext("categorical data not supported in this function"))
|
| 695 |
} |
|
| 696 | ! |
ngroups <- lavdata@ngroups |
| 697 | ! |
nlevels <- lavdata@nlevels |
| 698 | ||
| 699 |
# select groups |
|
| 700 | ! |
if (is.null(group)) {
|
| 701 | ! |
group.select <- seq_len(ngroups) |
| 702 |
} else {
|
|
| 703 | ! |
stopifnot(is.numeric(group), all(group <= ngroups)) |
| 704 | ! |
group.select <- group |
| 705 | ! |
if (length(group.select) == 0L) {
|
| 706 | ! |
lav_msg_stop(gettext("no groups selected"))
|
| 707 |
} |
|
| 708 |
} |
|
| 709 | ||
| 710 |
# what with fixed.x? |
|
| 711 |
# - does not really matter; fit will be saturated anyway |
|
| 712 |
# - fixed.x = TRUE may avoid convergence issues with non-numeric |
|
| 713 |
# x-covariates |
|
| 714 | ! |
fixed.x <- lavoptions$fixed.x |
| 715 | ||
| 716 |
# if multilevel |
|
| 717 | ! |
if (nlevels > 1L) {
|
| 718 |
# fixed.x <- FALSE # for now |
|
| 719 | ! |
conditional.x <- FALSE # for now |
| 720 | ! |
categorical <- FALSE # for now |
| 721 |
} |
|
| 722 | ||
| 723 | ! |
lhs <- rhs <- op <- character(0) |
| 724 | ! |
group <- block <- level <- free <- exo <- integer(0) |
| 725 | ! |
ustart <- lower <- numeric(0) |
| 726 | ||
| 727 |
# block number |
|
| 728 | ! |
b <- 0L |
| 729 | ! |
for (g in 1:ngroups) {
|
| 730 | ||
| 731 |
# select group? |
|
| 732 | ! |
if (! g %in% group.select) {
|
| 733 | ! |
next |
| 734 |
} |
|
| 735 | ||
| 736 |
# only for multilevel |
|
| 737 | ! |
if (nlevels > 1L) {
|
| 738 | ! |
Lp <- lavdata@Lp[[g]] |
| 739 |
} |
|
| 740 | ||
| 741 | ! |
for (l in 1:nlevels) {
|
| 742 |
# block |
|
| 743 | ! |
b <- b + 1L |
| 744 | ||
| 745 | ! |
if (is.null(lavpta)) {
|
| 746 | ! |
ov.names <- lavdata@ov.names[[b]] |
| 747 | ! |
ov.names.x <- lavdata@ov.names.x[[b]] |
| 748 | ! |
ov.names.nox <- ov.names[!ov.names %in% ov.names.x] |
| 749 |
} else {
|
|
| 750 | ! |
ov.names <- lavpta$vnames$ov[[b]] |
| 751 | ! |
ov.names.x <- lavpta$vnames$ov.x[[b]] |
| 752 | ! |
ov.names.nox <- lavpta$vnames$ov.nox[[b]] |
| 753 |
} |
|
| 754 | ||
| 755 |
# only for multilevel, overwrite sample.cov and sample.mean |
|
| 756 | ! |
if (nlevels > 1L) {
|
| 757 | ! |
ov.names.x <- character(0L) |
| 758 | ! |
ov.names.nox <- ov.names |
| 759 |
} |
|
| 760 | ||
| 761 |
# create lv.names == ov.names |
|
| 762 | ! |
lv.names <- paste("f", ov.names, sep = "")
|
| 763 | ||
| 764 |
# a) OV VARIANCES -> fixed to zero |
|
| 765 | ! |
nvar <- length(ov.names) |
| 766 | ! |
lhs <- c(lhs, ov.names) |
| 767 | ! |
op <- c(op, rep("~~", nvar))
|
| 768 | ! |
rhs <- c(rhs, ov.names) |
| 769 | ! |
block <- c(block, rep(b, nvar)) |
| 770 | ! |
group <- c(group, rep(g, nvar)) |
| 771 | ! |
level <- c(level, rep(l, nvar)) |
| 772 | ! |
ustart <- c(ustart, rep(0.0001, nvar)) ### Force PD!! (option?) |
| 773 | ! |
free <- c(free, rep(0L, nvar)) |
| 774 | ! |
exo <- c(exo, rep(0L, nvar)) |
| 775 | ! |
lower <- c(lower, rep(0.0, nvar)) |
| 776 | ||
| 777 |
# b) LV VARIANCES -> fixed to 1.0 |
|
| 778 | ! |
nvar <- length(lv.names) |
| 779 | ! |
lhs <- c(lhs, lv.names) |
| 780 | ! |
op <- c(op, rep("~~", nvar))
|
| 781 | ! |
rhs <- c(rhs, lv.names) |
| 782 | ! |
block <- c(block, rep(b, nvar)) |
| 783 | ! |
group <- c(group, rep(g, nvar)) |
| 784 | ! |
level <- c(level, rep(l, nvar)) |
| 785 | ! |
ustart <- c(ustart, rep(1.0, nvar)) |
| 786 | ! |
free <- c(free, rep(0L, nvar)) |
| 787 | ! |
exo <- c(exo, rep(0L, nvar)) |
| 788 | ! |
lower <- c(lower, rep(1.0, nvar)) |
| 789 | ||
| 790 |
# c) LOADINGS self |
|
| 791 | ! |
nvar <- length(ov.names) |
| 792 | ! |
lhs <- c(lhs, lv.names) |
| 793 | ! |
op <- c(op, rep("=~", nvar))
|
| 794 | ! |
rhs <- c(rhs, ov.names) |
| 795 | ! |
block <- c(block, rep(b, nvar)) |
| 796 | ! |
group <- c(group, rep(g, nvar)) |
| 797 | ! |
level <- c(level, rep(l, nvar)) |
| 798 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nvar)) |
| 799 | ! |
free <- c(free, rep(1L, nvar)) |
| 800 | ! |
exo <- c(exo, rep(0L, nvar)) |
| 801 | ! |
lower <- c(lower, rep(0.0, nvar)) # lower bound! |
| 802 | ||
| 803 |
# d) LOADINGS other |
|
| 804 | ! |
if (length(ov.names) > 1L) {
|
| 805 | ! |
tmp <- utils::combn(ov.names, 2) |
| 806 | ! |
pstar <- ncol(tmp) |
| 807 | ! |
lhs <- c(lhs, paste("f", tmp[1, ], sep = ""))
|
| 808 | ! |
op <- c(op, rep("=~", pstar))
|
| 809 | ! |
rhs <- c(rhs, tmp[2, ]) |
| 810 | ! |
block <- c(block, rep(b, pstar)) |
| 811 | ! |
group <- c(group, rep(g, pstar)) |
| 812 | ! |
level <- c(level, rep(l, pstar)) |
| 813 | ! |
free <- c(free, rep(1L, pstar)) |
| 814 | ! |
exo <- c(exo, rep(0L, pstar)) |
| 815 | ! |
lower <- c(lower, rep(-Inf, pstar)) |
| 816 | ! |
ustart <- c(ustart, rep(as.numeric(NA), pstar)) |
| 817 |
} |
|
| 818 | ||
| 819 |
# check for zero coverage at level 1 (new in 0.6-18) |
|
| 820 | ! |
if (lavdata@missing == "ml" && l == 1 && !is.null(lavdata@Mp[[g]])) {
|
| 821 | ! |
coverage <- lavdata@Mp[[g]]$coverage |
| 822 | ! |
sample.cov.vech <- lav_matrix_vech(coverage, diagonal = FALSE) |
| 823 | ! |
zero.cov <- which(sample.cov.vech == 0) |
| 824 | ! |
if (length(zero.cov) > 0L) {
|
| 825 | ! |
n.tmp <- length(free) |
| 826 | ! |
ones.and.zeroes <- rep(1L, pstar) |
| 827 | ! |
ones.and.zeroes[zero.cov] <- 0L |
| 828 | ! |
inf.and.zeroes <- rep(-Inf, pstar) |
| 829 | ! |
inf.and.zeroes[zero.cov] <- 0 |
| 830 | ! |
na.and.zeroes <- rep(as.numeric(NA), pstar) |
| 831 | ! |
na.and.zeroes[zero.cov] <- 0 |
| 832 | ! |
free[ (n.tmp - pstar + 1):n.tmp] <- ones.and.zeroes |
| 833 | ! |
ustart[(n.tmp - pstar + 1):n.tmp] <- na.and.zeroes |
| 834 | ! |
lower[ (n.tmp - pstar + 1):n.tmp] <- inf.and.zeroes |
| 835 |
} |
|
| 836 |
} |
|
| 837 | ||
| 838 |
# meanstructure? |
|
| 839 | ! |
if (meanstructure) {
|
| 840 |
# OV |
|
| 841 | ! |
ov.int <- ov.names |
| 842 | ||
| 843 | ! |
nel <- length(ov.int) |
| 844 | ! |
lhs <- c(lhs, ov.int) |
| 845 | ! |
op <- c(op, rep("~1", nel))
|
| 846 | ! |
rhs <- c(rhs, rep("", nel))
|
| 847 | ! |
block <- c(block, rep(b, nel)) |
| 848 | ! |
group <- c(group, rep(g, nel)) |
| 849 | ! |
level <- c(level, rep(l, nel)) |
| 850 |
# if multilevel, level=1 has fixed zeroes |
|
| 851 | ! |
if (nlevels > 1L && l == 1L) {
|
| 852 | ! |
WITHIN <- rep(0L, nel) |
| 853 | ! |
within.idx <- match(Lp$within.idx[[2]], Lp$ov.idx[[1]]) |
| 854 | ! |
WITHIN[within.idx] <- 1L |
| 855 | ! |
free <- c(free, WITHIN) |
| 856 |
} else {
|
|
| 857 | ! |
free <- c(free, rep(1L, nel)) |
| 858 |
} |
|
| 859 | ! |
exo <- c(exo, rep(0L, nel)) |
| 860 | ! |
lower <- c(lower, rep(-Inf, nel)) |
| 861 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nel)) |
| 862 | ||
| 863 |
# LV |
|
| 864 | ! |
ov.int <- lv.names |
| 865 | ||
| 866 | ! |
nel <- length(ov.int) |
| 867 | ! |
lhs <- c(lhs, ov.int) |
| 868 | ! |
op <- c(op, rep("~1", nel))
|
| 869 | ! |
rhs <- c(rhs, rep("", nel))
|
| 870 | ! |
block <- c(block, rep(b, nel)) |
| 871 | ! |
group <- c(group, rep(g, nel)) |
| 872 | ! |
level <- c(level, rep(l, nel)) |
| 873 | ! |
free <- c(free, rep(0L, nel)) |
| 874 | ! |
exo <- c(exo, rep(0L, nel)) |
| 875 | ! |
ustart <- c(ustart, rep(0.0, nel)) |
| 876 | ! |
lower <- c(lower, rep(-Inf, nel)) |
| 877 |
} |
|
| 878 |
} # levels |
|
| 879 |
} # ngroups |
|
| 880 | ||
| 881 |
# free counter |
|
| 882 | ! |
idx.free <- which(free > 0) |
| 883 | ! |
free[idx.free] <- 1:length(idx.free) |
| 884 | ||
| 885 | ! |
LIST <- list( |
| 886 | ! |
id = 1:length(lhs), |
| 887 | ! |
lhs = lhs, |
| 888 | ! |
op = op, |
| 889 | ! |
rhs = rhs, |
| 890 | ! |
user = rep(1L, length(lhs)), |
| 891 | ! |
block = block, |
| 892 | ! |
group = group, |
| 893 | ! |
level = level, |
| 894 | ! |
free = free, |
| 895 | ! |
ustart = ustart, |
| 896 | ! |
exo = exo, |
| 897 | ! |
lower = lower # , |
| 898 |
# label = rep("", length(lhs))
|
|
| 899 |
# eq.id = rep(0L, length(lhs)), |
|
| 900 |
# unco = free |
|
| 901 |
) |
|
| 902 | ||
| 903 | ||
| 904 |
# keep level column if no levels? (no for now) |
|
| 905 | ! |
if (nlevels < 2L) {
|
| 906 | ! |
LIST$level <- NULL |
| 907 |
} |
|
| 908 | ||
| 909 | ! |
LIST |
| 910 |
} |
|
| 911 | ||
| 912 |
# create a 'baseline' model from an existing object/partable |
|
| 913 |
# - fix all (free) directed effects (factor loadings, regressions) to zero |
|
| 914 |
# - fix all (free) covariances to zero |
|
| 915 |
# - neutralize the (measured) latent variables by fixing their variances |
|
| 916 |
# to zero |
|
| 917 |
# - keep all other (relevant) constraints |
|
| 918 |
# - this *should* result in a baseline model that is always nested within |
|
| 919 |
# the original model |
|
| 920 |
lav_partable_baseline <- function(lavobject = NULL, |
|
| 921 |
# if no object is available, |
|
| 922 |
lavpartable = NULL, |
|
| 923 |
lavh1 = NULL) {
|
|
| 924 | ||
| 925 |
# grab everything from lavaan lavobject |
|
| 926 | ! |
if (!is.null(lavobject)) {
|
| 927 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 928 | ! |
lavpartable <- lavobject@ParTable |
| 929 | ! |
lavh1 <- lavobject@h1 |
| 930 |
} |
|
| 931 | ||
| 932 |
# number of blocks |
|
| 933 | ! |
nblocks <- lav_partable_nblocks(lavpartable) |
| 934 | ||
| 935 |
# conditional.x ? check res.cov[[1]] slot |
|
| 936 | ! |
conditional.x <- FALSE |
| 937 | ! |
if (!is.null(lavh1) && !is.null(lavh1$implied$res.cov[[1]])) {
|
| 938 | ! |
conditional.x <- TRUE |
| 939 |
} |
|
| 940 | ||
| 941 |
# get sample statistics, all groups |
|
| 942 | ! |
if (conditional.x) {
|
| 943 | ! |
sample.cov <- lavh1$implied$res.cov |
| 944 | ! |
sample.mean <- lavh1$implied$res.int |
| 945 |
} else {
|
|
| 946 | ! |
sample.cov <- lavh1$implied$cov |
| 947 | ! |
sample.mean <- lavh1$implied$mean |
| 948 |
} |
|
| 949 | ||
| 950 |
# shortcut of lavpartable |
|
| 951 | ! |
PT <- lavpartable |
| 952 | ||
| 953 |
# keep exo=1 starting values |
|
| 954 | ! |
exo.idx <- which(PT$exo == 1L) |
| 955 | ! |
if (!is.null(PT$est)) {
|
| 956 | ! |
PT$ustart[exo.idx] <- PT$est[exo.idx] |
| 957 | ! |
} else if (!is.null(PT$start)) {
|
| 958 | ! |
PT$iustart[exo.idx] <- PT$start[exo.idx] |
| 959 |
} |
|
| 960 | ||
| 961 |
# remove est/se columns, if present, but keep start column |
|
| 962 | ! |
PT$est <- PT$se <- NULL |
| 963 | ||
| 964 |
# lv.names |
|
| 965 | ! |
lv.names <- lav_partable_vnames(PT, "lv") |
| 966 | ||
| 967 |
# zero-out all directed effects and covariances |
|
| 968 | ! |
directed.idx <- which(PT$op %in% c("=~", "~") & PT$free > 0L & PT$exo != 1L)
|
| 969 | ! |
cov.idx <- which(PT$op == "~~" & PT$lhs != PT$rhs & PT$free > 0L) |
| 970 | ||
| 971 |
# neutralize latent variables |
|
| 972 | ! |
lv.var.idx <- which(PT$op == "~~" & PT$lhs %in% lv.names & PT$lhs == PT$rhs & |
| 973 | ! |
PT$free > 0L) |
| 974 |
#lv.int.idx <- which(PT$op == "~1" & PT$lhs %in% lv.names & PT$free > 0L) |
|
| 975 |
#zero.idx <- c(directed.idx, cov.idx, lv.var.idx, lv.int.idx) |
|
| 976 | ! |
zero.idx <- c(directed.idx, cov.idx, lv.var.idx) |
| 977 | ||
| 978 | ! |
PT$free[zero.idx] <- 0L |
| 979 | ! |
PT$start[zero.idx] <- 0 |
| 980 | ! |
PT$ustart[zero.idx] <- 0 |
| 981 | ||
| 982 |
# Question: fill in more elements in PT$start? (only ov variances for now) |
|
| 983 | ! |
for (b in seq_len(nblocks)) {
|
| 984 | ! |
ov.names.num <- lav_partable_vnames(lavpartable, "ov.num", block = b) |
| 985 | ! |
if (conditional.x) {
|
| 986 | ! |
ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = b) |
| 987 | ! |
ov.names.num <- ov.names.num[!ov.names.num %in% ov.names.x] |
| 988 |
} |
|
| 989 | ! |
ovar.idx <- which(lavpartable$block == b & |
| 990 | ! |
lavpartable$op == "~~" & |
| 991 | ! |
lavpartable$lhs %in% ov.names.num & |
| 992 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 993 | ! |
sample.var.idx <- match(lavpartable$lhs[ovar.idx], ov.names.num) |
| 994 | ! |
PT$ustart[ovar.idx] <- diag(sample.cov[[b]])[sample.var.idx] |
| 995 |
} |
|
| 996 | ||
| 997 | ! |
PT <- lav_partable_complete(PT) |
| 998 | ! |
PT |
| 999 |
} |
| 1 |
## NOTE: |
|
| 2 |
## round(1.2355, 3) = 1.236 |
|
| 3 |
## but |
|
| 4 |
## round(1.2345, 3) = 1.234 |
|
| 5 |
## |
|
| 6 |
## perhaps we should add 0.0005 or something to avoid this? |
|
| 7 | ||
| 8 |
lav_dataframe_print <- function(x, ..., nd = 3L) {
|
|
| 9 | 5x |
ROW.NAMES <- rownames(x) |
| 10 | 5x |
y <- as.data.frame(lapply(x, function(x) {
|
| 11 | 15x |
if (is.numeric(x)) round(x, nd) else x |
| 12 |
})) |
|
| 13 | 5x |
rownames(y) <- ROW.NAMES |
| 14 | ||
| 15 | 5x |
if (!is.null(attr(x, "header"))) {
|
| 16 | 5x |
cat("\n", attr(x, "header"), "\n\n", sep = "")
|
| 17 |
} |
|
| 18 | ||
| 19 | 5x |
print(y, ...) |
| 20 | ||
| 21 | 5x |
if (!is.null(attr(x, "footer"))) {
|
| 22 | ! |
cat("\n", attr(x, "footer"), "\n\n", sep = "")
|
| 23 |
} |
|
| 24 | ||
| 25 | 5x |
invisible(x) |
| 26 |
} |
|
| 27 | ||
| 28 |
lav_lavaanlist_print <- function(x, ...) {
|
|
| 29 | 20x |
y <- unclass(x) |
| 30 | 20x |
attr(y, "header") <- NULL |
| 31 | ||
| 32 | 20x |
header <- attr(x, "header") |
| 33 | 20x |
if (!is.null(header)) {
|
| 34 | 5x |
if (is.character(header)) {
|
| 35 | ! |
cat("\n", header, "\n\n", sep = "")
|
| 36 |
} else {
|
|
| 37 | 5x |
print(header) |
| 38 | 5x |
cat("\n")
|
| 39 |
} |
|
| 40 |
} |
|
| 41 | ||
| 42 | 20x |
print(y, ...) |
| 43 | 20x |
invisible(x) |
| 44 |
} |
|
| 45 | ||
| 46 | ||
| 47 |
# prints only lower triangle of a symmetric matrix |
|
| 48 |
lav_matrix_symmetric_print <- function(x, ..., nd = 3L, shift = 0L, |
|
| 49 |
diag.na.dot = TRUE) {
|
|
| 50 |
# print only lower triangle of a symmetric matrix |
|
| 51 |
# this function was inspired by the `print.correlation' function |
|
| 52 |
# in package nlme |
|
| 53 | 51x |
x <- as.matrix(x) # just in case |
| 54 | 51x |
y <- x |
| 55 | 51x |
y <- unclass(y) |
| 56 | 51x |
attributes(y)[c("header", "footer")] <- NULL
|
| 57 | 51x |
ll <- lower.tri(x, diag = TRUE) |
| 58 | 51x |
y[ll] <- format(round(x[ll], digits = nd)) |
| 59 | 51x |
y[!ll] <- "" |
| 60 | 51x |
if (diag.na.dot) {
|
| 61 |
# print a "." instead of NA on the main diagonal (eg lav_efalist_summary) |
|
| 62 | 51x |
diag.idx <- lav_matrix_diag_idx(ncol(x)) |
| 63 | 51x |
tmp <- x[diag.idx] |
| 64 | 51x |
if (all(is.na(tmp))) {
|
| 65 | ! |
y[diag.idx] <- paste(strrep(" ", nd + 2L), ".", sep = "")
|
| 66 |
} |
|
| 67 |
} |
|
| 68 | 51x |
if (!is.null(colnames(x))) {
|
| 69 | 51x |
colnames(y) <- abbreviate(colnames(x), minlength = nd + 3L) |
| 70 |
} |
|
| 71 | 51x |
if (shift > 0L) {
|
| 72 | ! |
empty.string <- rep(strrep(x = " ", times = shift), times = nrow(x)) |
| 73 | ! |
if (!is.null(rownames(x))) {
|
| 74 | ! |
rownames(y) <- paste(empty.string, rownames(x), sep = "") |
| 75 |
} else {
|
|
| 76 | ! |
rownames(y) <- empty.string |
| 77 |
} |
|
| 78 |
} |
|
| 79 | ||
| 80 | 51x |
if (!is.null(attr(x, "header"))) {
|
| 81 | ! |
cat("\n", attr(x, "header"), "\n\n", sep = "")
|
| 82 |
} |
|
| 83 | ||
| 84 | 51x |
print(y, ..., quote = FALSE, right = TRUE) |
| 85 | ||
| 86 | 51x |
if (!is.null(attr(x, "footer"))) {
|
| 87 | ! |
cat("\n", attr(x, "footer"), "\n\n", sep = "")
|
| 88 |
} |
|
| 89 | ||
| 90 | 51x |
invisible(x) |
| 91 |
} |
|
| 92 | ||
| 93 | ||
| 94 |
lav_matrix_print <- function(x, ..., nd = 3L, shift = 0L) {
|
|
| 95 | 101x |
x <- as.matrix(x) # just in case |
| 96 | 101x |
y <- unclass(x) |
| 97 | 101x |
attributes(y)[c("header", "footer")] <- NULL
|
| 98 | 101x |
if (!is.null(colnames(x))) {
|
| 99 | 101x |
colnames(y) <- abbreviate(colnames(x), minlength = nd + 3L) |
| 100 |
} |
|
| 101 | 101x |
if (shift > 0L) {
|
| 102 | 1x |
empty.string <- rep(strrep(x = " ", times = shift), times = nrow(x)) |
| 103 | 1x |
if (!is.null(rownames(x))) {
|
| 104 | 1x |
rownames(y) <- paste(empty.string, rownames(x), sep = "") |
| 105 |
} else {
|
|
| 106 | ! |
rownames(y) <- empty.string |
| 107 |
} |
|
| 108 |
} |
|
| 109 | 101x |
if (!is.null(attr(x, "header"))) {
|
| 110 | ! |
cat("\n", attr(x, "header"), "\n\n", sep = "")
|
| 111 |
} |
|
| 112 | ||
| 113 | 101x |
print(round(y, nd), right = TRUE, ...) |
| 114 | ||
| 115 | 101x |
if (!is.null(attr(x, "footer"))) {
|
| 116 | ! |
cat("\n", attr(x, "footer"), "\n\n", sep = "")
|
| 117 |
} |
|
| 118 | ||
| 119 | 101x |
invisible(x) |
| 120 |
} |
|
| 121 | ||
| 122 |
lav_vector_print <- function(x, ..., nd = 3L, shift = 0L) {
|
|
| 123 | 1x |
y <- unclass(x) |
| 124 | 1x |
attributes(y)[c("header", "footer")] <- NULL
|
| 125 |
# if(!is.null(names(x))) {
|
|
| 126 |
# names(y) <- abbreviate(names(x), minlength = nd + 3) |
|
| 127 |
# } |
|
| 128 | 1x |
if (!is.null(attr(x, "header"))) {
|
| 129 | ! |
cat("\n", attr(x, "header"), "\n\n", sep = "")
|
| 130 |
} |
|
| 131 | ||
| 132 | 1x |
if (shift > 0L) {
|
| 133 | 1x |
empty.string <- strrep(x = " ", times = shift) |
| 134 | 1x |
tmp <- format(y, digits = nd, width = 2L + nd) |
| 135 | 1x |
tmp[1] <- paste(empty.string, tmp[1], sep = "") |
| 136 | 1x |
print(tmp, quote = FALSE, ...) |
| 137 |
} else {
|
|
| 138 | ! |
print(round(y, nd), right = TRUE, ...) |
| 139 |
} |
|
| 140 | ||
| 141 | 1x |
if (!is.null(attr(x, "footer"))) {
|
| 142 | ! |
cat("\n", attr(x, "footer"), "\n\n", sep = "")
|
| 143 |
} |
|
| 144 | ||
| 145 | 1x |
invisible(x) |
| 146 |
} |
|
| 147 | ||
| 148 |
print.lavaan.character <- function(x, ...) {
|
|
| 149 | ! |
cat(x) |
| 150 | ! |
invisible(x) |
| 151 |
} |
|
| 152 | ||
| 153 |
lav_parameterestimates_print <- function(x, ..., nd = 3L) {
|
|
| 154 |
# format for numeric values |
|
| 155 | 20x |
num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")
|
| 156 | 20x |
int.format <- paste("%", max(8L, nd + 5L), "d", sep = "")
|
| 157 | 20x |
char.format <- paste("%", max(8L, nd + 5L), "s", sep = "")
|
| 158 | ||
| 159 |
# output sections |
|
| 160 | 20x |
GSECTIONS <- c( |
| 161 | 20x |
"Latent Variables", |
| 162 | 20x |
"Composites", |
| 163 | 20x |
"Regressions", |
| 164 | 20x |
"Covariances", |
| 165 | 20x |
"Intercepts", |
| 166 | 20x |
"Thresholds", |
| 167 | 20x |
"Variances", |
| 168 | 20x |
"Scales y*", |
| 169 | 20x |
"Group Weight", |
| 170 | 20x |
"R-Square" |
| 171 |
) |
|
| 172 | 20x |
ASECTIONS <- c( |
| 173 | 20x |
"Defined Parameters", |
| 174 | 20x |
"Constraints" |
| 175 |
) |
|
| 176 | ||
| 177 |
# header? |
|
| 178 | 20x |
header <- attr(x, "header") |
| 179 | 20x |
if (is.null(header)) {
|
| 180 | ! |
header <- FALSE |
| 181 |
} |
|
| 182 | ||
| 183 | 20x |
if (header) {
|
| 184 | 20x |
cat("\nParameter Estimates:\n\n")
|
| 185 | ||
| 186 |
# info about parameterization (if categorical only) |
|
| 187 | 20x |
categorical.flag <- attr(x, "categorical") |
| 188 | 20x |
if (categorical.flag) {
|
| 189 |
# container |
|
| 190 | 1x |
c1 <- c2 <- character(0L) |
| 191 | ||
| 192 |
# which parameterization? |
|
| 193 | 1x |
c1 <- c(c1, "Parameterization") |
| 194 | 1x |
tmp.txt <- attr(x, "parameterization") |
| 195 | 1x |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 196 | 1x |
substring(tmp.txt, 2), |
| 197 | 1x |
sep = "" |
| 198 |
)) |
|
| 199 | ||
| 200 |
# format c1/c2 |
|
| 201 | 1x |
c1 <- format(c1, width = 37L) |
| 202 | 1x |
c2 <- format(c2, |
| 203 | 1x |
width = 14L + max(0, (nd - 3L)) * 4L, justify = "right" |
| 204 |
) |
|
| 205 | ||
| 206 |
# create character matrix |
|
| 207 | 1x |
M <- cbind(c1, c2, deparse.level = 0) |
| 208 | 1x |
colnames(M) <- rep("", ncol(M))
|
| 209 | 1x |
rownames(M) <- rep(" ", nrow(M))
|
| 210 | ||
| 211 |
|
|
| 212 | 1x |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 213 |
} |
|
| 214 | ||
| 215 |
# info about standard errors (if we have x$se only) |
|
| 216 |
# 1. information |
|
| 217 |
# 2. se |
|
| 218 |
# 3. bootstrap requested/successful draws |
|
| 219 | 20x |
if (!is.null(x$se)) {
|
| 220 |
# container |
|
| 221 | 20x |
c1 <- c2 <- character(0L) |
| 222 | ||
| 223 |
# which type of standard errors? |
|
| 224 | 20x |
c1 <- c(c1, "Standard errors") |
| 225 | 20x |
if (attr(x, "se") == "robust.huber.white") {
|
| 226 | 1x |
tmp.txt <- "sandwich" # since 0.6-6 |
| 227 |
} else {
|
|
| 228 | 19x |
tmp.txt <- attr(x, "se") |
| 229 |
} |
|
| 230 | 20x |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 231 | 20x |
substring(tmp.txt, 2), |
| 232 | 20x |
sep = "" |
| 233 |
)) |
|
| 234 |
# information |
|
| 235 | 20x |
if (attr(x, "se") != "bootstrap") {
|
| 236 |
# type for information |
|
| 237 | 20x |
if (attr(x, "se") == "robust.huber.white") {
|
| 238 | 1x |
c1 <- c(c1, "Information bread") |
| 239 |
} else {
|
|
| 240 | 19x |
c1 <- c(c1, "Information") |
| 241 |
} |
|
| 242 | 20x |
tmp.txt <- attr(x, "information") |
| 243 | 20x |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 244 | 20x |
substring(tmp.txt, 2), |
| 245 | 20x |
sep = "" |
| 246 |
)) |
|
| 247 | ||
| 248 |
# if observed, which type? (hessian of h1) |
|
| 249 | 20x |
if (attr(x, "information") == "observed") {
|
| 250 | 6x |
c1 <- c(c1, "Observed information based on") |
| 251 | 6x |
tmp.txt <- attr(x, "observed.information") |
| 252 | 6x |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 253 | 6x |
substring(tmp.txt, 2), |
| 254 | 6x |
sep = "" |
| 255 |
)) |
|
| 256 |
} |
|
| 257 | ||
| 258 |
# if h1 is involved, structured or unstructured? |
|
| 259 | 20x |
if (attr(x, "information") %in% c("expected", "first.order") ||
|
| 260 | 20x |
attr(x, "observed.information") == "h1") {
|
| 261 | 14x |
if (attr(x, "se") == "robust.huber.white" && |
| 262 | 14x |
attr(x, "h1.information") != |
| 263 | 14x |
attr(x, "h1.information.meat")) {
|
| 264 | ! |
c1 <- c(c1, "Information bread saturated (h1) model") |
| 265 |
} else {
|
|
| 266 | 14x |
c1 <- c(c1, "Information saturated (h1) model") |
| 267 |
} |
|
| 268 | 14x |
tmp.txt <- attr(x, "h1.information") |
| 269 | 14x |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 270 | 14x |
substring(tmp.txt, 2), |
| 271 | 14x |
sep = "" |
| 272 |
)) |
|
| 273 |
} |
|
| 274 | ||
| 275 |
# if sandwich, which information for the meat? (first.order) |
|
| 276 |
# only print if it is NOT first.order |
|
| 277 | 20x |
if (attr(x, "se") == "robust.huber.white" && |
| 278 | 20x |
attr(x, "information.meat") != "first.order") {
|
| 279 | ! |
c1 <- c(c1, "Information meat") |
| 280 | ! |
tmp.txt <- attr(x, "information.meat") |
| 281 | ! |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 282 | ! |
substring(tmp.txt, 2), |
| 283 | ! |
sep = "" |
| 284 |
)) |
|
| 285 |
} |
|
| 286 | ||
| 287 |
# if sandwich, structured or unstructured for the meat? |
|
| 288 |
# only print if it is not the same as h1.information |
|
| 289 | 20x |
if (attr(x, "se") == "robust.huber.white" && |
| 290 | 20x |
attr(x, "h1.information.meat") != |
| 291 | 20x |
attr(x, "h1.information")) {
|
| 292 | ! |
c1 <- c(c1, "Information meat saturated (h1) model") |
| 293 | ! |
tmp.txt <- attr(x, "h1.information.meat") |
| 294 | ! |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 295 | ! |
substring(tmp.txt, 2), |
| 296 | ! |
sep = "" |
| 297 |
)) |
|
| 298 |
} |
|
| 299 |
} # no bootstrap |
|
| 300 | ||
| 301 |
#TDJ: Pooling options for lavaan.mi-class objects (which NEVER bootstrap) |
|
| 302 | 20x |
if (isTRUE(attr(x, "pooled"))) {
|
| 303 |
## add an empty element for a space before pooling section |
|
| 304 | ! |
c1 <- c(c1, "", "Pooled across imputations") |
| 305 | ! |
c2 <- c(c2, "", "Rubin's (1987) rules") |
| 306 |
} |
|
| 307 | 20x |
if (!is.null(attr(x, "scale.W"))) {
|
| 308 | ! |
c1 <- c(c1, "Augment within-imputation variance") |
| 309 | ! |
if (attr(x, "scale.W")) {
|
| 310 | ! |
c2 <- c(c2, "Scale by average RIV") |
| 311 |
} else {
|
|
| 312 | ! |
c2 <- c(c2, "Add between component") |
| 313 |
} |
|
| 314 |
} |
|
| 315 | 20x |
if (!is.null(attr(x, "asymptotic"))) {
|
| 316 | ! |
c1 <- c(c1, "Wald test for pooled parameters") |
| 317 | ! |
if (attr(x, "asymptotic")) {
|
| 318 | ! |
c2 <- c(c2, "Normal (z) distribution") |
| 319 |
} else {
|
|
| 320 | ! |
c2 <- c(c2, "t(df) distribution") |
| 321 |
} |
|
| 322 |
} |
|
| 323 | ||
| 324 |
# 4. |
|
| 325 | 20x |
if (attr(x, "se") == "bootstrap" && !is.null(attr(x, "bootstrap"))) {
|
| 326 | ! |
c1 <- c(c1, "Number of requested bootstrap draws") |
| 327 | ! |
c2 <- c(c2, attr(x, "bootstrap")) |
| 328 | ! |
c1 <- c(c1, "Number of successful bootstrap draws") |
| 329 | ! |
c2 <- c(c2, attr(x, "bootstrap.successful")) |
| 330 |
} |
|
| 331 | ||
| 332 |
# format c1/c2 |
|
| 333 | 20x |
c1 <- format(c1, width = 37L) |
| 334 | 20x |
c2 <- format(c2, |
| 335 | 20x |
width = 14L + max(0, (nd - 3L)) * 4L, justify = "right" |
| 336 |
) |
|
| 337 | ||
| 338 |
# create character matrix |
|
| 339 | 20x |
M <- cbind(c1, c2, deparse.level = 0) |
| 340 | 20x |
colnames(M) <- rep("", ncol(M))
|
| 341 | 20x |
rownames(M) <- rep(" ", nrow(M))
|
| 342 | ||
| 343 |
|
|
| 344 | 20x |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 345 | ||
| 346 |
#TDJ: Message for lavaan.mi-class objects when df > 1000 for t test |
|
| 347 | 20x |
if (isTRUE(attr(x, "infDF"))) {
|
| 348 | ! |
cat(c("\n Pooled t statistics with df >= 1000 are displayed with",
|
| 349 | ! |
"\n df = Inf(inity) to save space. Although the t distribution", |
| 350 | ! |
"\n with large df closely approximates a standard normal", |
| 351 | ! |
"\n distribution, exact df for reporting these t tests can be", |
| 352 | ! |
"\n obtained from parameterEstimates.mi() \n\n"), sep = "") |
| 353 |
} |
|
| 354 | ||
| 355 |
} |
|
| 356 |
} |
|
| 357 | ||
| 358 |
# number of groups |
|
| 359 | 20x |
if (is.null(x$group)) {
|
| 360 | 18x |
ngroups <- 1L |
| 361 | 18x |
x$group <- rep(1L, length(x$lhs)) |
| 362 |
} else {
|
|
| 363 | 2x |
ngroups <- lav_partable_ngroups(x) |
| 364 |
} |
|
| 365 | ||
| 366 |
# number of levels |
|
| 367 | 20x |
if (is.null(x$level)) {
|
| 368 | 19x |
nlevels <- 1L |
| 369 | 19x |
x$level <- rep(1L, length(x$lhs)) |
| 370 |
} else {
|
|
| 371 | 1x |
nlevels <- lav_partable_nlevels(x) |
| 372 |
} |
|
| 373 | ||
| 374 |
# block column |
|
| 375 | 20x |
if (is.null(x$block)) {
|
| 376 | 18x |
x$block <- rep(1L, length(x$lhs)) |
| 377 |
} |
|
| 378 | ||
| 379 |
# step column (SAM) |
|
| 380 |
# if(!is.null(x$step)) {
|
|
| 381 |
# tmp.LABEL <- rep("", length(x$lhs))
|
|
| 382 |
# p1.idx <- which(x$step == 1L) |
|
| 383 |
# p2.idx <- which(x$step == 2L) |
|
| 384 |
# tmp.LABEL[p1.idx] <- "1" |
|
| 385 |
# tmp.LABEL[p2.idx] <- "2" |
|
| 386 |
# |
|
| 387 |
# if(is.null(x$label)) {
|
|
| 388 |
# x$label <- tmp.LABEL |
|
| 389 |
# } else {
|
|
| 390 |
# x$label <- paste(x$label, tmp.LABEL, sep = "") |
|
| 391 |
# } |
|
| 392 |
# |
|
| 393 |
# x$step <- NULL |
|
| 394 |
# } |
|
| 395 | ||
| 396 |
# round to 3 digits after the decimal point |
|
| 397 | 20x |
y <- as.data.frame( |
| 398 | 20x |
lapply(x, function(x) {
|
| 399 | 229x |
if (is.integer(x)) {
|
| 400 | 78x |
sprintf(int.format, x) |
| 401 | 151x |
} else if (is.character(x)) { # perhaps plabel
|
| 402 | 71x |
sprintf(char.format, x) |
| 403 | 80x |
} else if (is.numeric(x)) {
|
| 404 | 80x |
sprintf(num.format, x) |
| 405 |
} else {
|
|
| 406 | ! |
x |
| 407 |
} |
|
| 408 |
}), |
|
| 409 | 20x |
stringsAsFactors = FALSE |
| 410 |
) |
|
| 411 | ||
| 412 |
# always remove /block/level/group/op/rhs/label/exo columns |
|
| 413 | 20x |
y$op <- y$group <- y$rhs <- y$label <- y$exo <- NULL |
| 414 | 20x |
y$block <- y$level <- NULL |
| 415 | 20x |
y$efa <- NULL |
| 416 | ||
| 417 |
# if standardized, remove std.nox column (space reasons only) |
|
| 418 |
# unless, std.all is already removed |
|
| 419 | 20x |
if (!is.null(y$std.all)) {
|
| 420 | ! |
y$std.nox <- NULL |
| 421 |
} |
|
| 422 | ||
| 423 |
# convert to character matrix |
|
| 424 | 20x |
m <- as.matrix(format.data.frame(y, |
| 425 | 20x |
na.encode = FALSE, |
| 426 | 20x |
justify = "right" |
| 427 |
)) |
|
| 428 | ||
| 429 |
# use empty row names |
|
| 430 | 20x |
rownames(m) <- rep("", nrow(m))
|
| 431 | ||
| 432 |
# handle se == 0.0 |
|
| 433 | 20x |
if (!is.null(x$se)) {
|
| 434 | 20x |
se.idx <- which(x$se == 0) |
| 435 | 20x |
if (length(se.idx) > 0L) {
|
| 436 | 19x |
m[se.idx, "se"] <- "" |
| 437 | 19x |
if (!is.null(x$z)) {
|
| 438 | 19x |
m[se.idx, "z"] <- "" |
| 439 |
} |
|
| 440 | 19x |
if (!is.null(x$pvalue)) {
|
| 441 | 19x |
m[se.idx, "pvalue"] <- "" |
| 442 |
} |
|
| 443 |
## for lavaan.mi-class objects (semTools) |
|
| 444 | 19x |
if (!is.null(x$t)) {
|
| 445 | ! |
m[se.idx, "t"] <- "" |
| 446 |
} |
|
| 447 | 19x |
if (!is.null(x$df)) {
|
| 448 | ! |
m[se.idx, "df"] <- "" |
| 449 |
} |
|
| 450 |
} |
|
| 451 | ||
| 452 |
# handle se == NA |
|
| 453 | 20x |
se.idx <- which(is.na(x$se)) |
| 454 | 20x |
if (length(se.idx) > 0L) {
|
| 455 | ! |
if (!is.null(x$z)) {
|
| 456 | ! |
m[se.idx, "z"] <- "" |
| 457 |
} |
|
| 458 | ! |
if (!is.null(x$pvalue)) {
|
| 459 | ! |
m[se.idx, "pvalue"] <- "" |
| 460 |
} |
|
| 461 |
## for lavaan.mi-class objects (semTools) |
|
| 462 | ! |
if (!is.null(x$t)) {
|
| 463 | ! |
m[se.idx, "t"] <- "" |
| 464 |
} |
|
| 465 | ! |
if (!is.null(x$df)) {
|
| 466 | ! |
m[se.idx, "df"] <- "" |
| 467 |
} |
|
| 468 |
} |
|
| 469 |
} |
|
| 470 | ||
| 471 |
# handle lower/upper boundary points |
|
| 472 | 20x |
if (!is.null(x$lower)) {
|
| 473 | ! |
b.idx <- which(abs(x$lower - x$est) < sqrt(.Machine$double.eps) & |
| 474 | ! |
(is.na(x$se) | (is.finite(x$se) & x$se != 0.0))) |
| 475 | ! |
if (length(b.idx) > 0L && !is.null(x$pvalue)) {
|
| 476 | ! |
m[b.idx, "pvalue"] <- "" |
| 477 | ! |
if (is.null(x$label)) {
|
| 478 | ! |
x$label <- rep("", length(x$lhs))
|
| 479 |
} |
|
| 480 | ! |
x$label[b.idx] <- ifelse(nchar(x$label[b.idx]) > 0L, |
| 481 | ! |
paste(x$label[b.idx], "+lb", sep = ""), |
| 482 | ! |
"lb" |
| 483 |
) |
|
| 484 |
} |
|
| 485 |
# remove lower column |
|
| 486 | ! |
m <- m[, colnames(m) != "lower"] |
| 487 |
} |
|
| 488 | 20x |
if (!is.null(x$upper)) {
|
| 489 | ! |
b.idx <- which(abs(x$upper - x$est) < sqrt(.Machine$double.eps) & |
| 490 | ! |
is.finite(x$se) & x$se != 0.0) |
| 491 | ! |
if (length(b.idx) > 0L && !is.null(x$pvalue)) {
|
| 492 | ! |
m[b.idx, "pvalue"] <- "" |
| 493 | ! |
if (is.null(x$label)) {
|
| 494 | ! |
x$label <- rep("", length(x$lhs))
|
| 495 |
} |
|
| 496 | ! |
x$label[b.idx] <- ifelse(nchar(x$label[b.idx]) > 0L, |
| 497 | ! |
paste(x$label[b.idx], "+ub", sep = ""), |
| 498 | ! |
"ub" |
| 499 |
) |
|
| 500 |
} |
|
| 501 |
# remove upper column |
|
| 502 | ! |
m <- m[, colnames(m) != "upper"] |
| 503 |
} |
|
| 504 | ||
| 505 | ||
| 506 |
# handle fmi |
|
| 507 | 20x |
if (!is.null(x$fmi)) {
|
| 508 | ! |
se.idx <- which(x$se == 0) |
| 509 | ! |
if (length(se.idx) > 0L) {
|
| 510 | ! |
m[se.idx, "fmi"] <- "" |
| 511 |
## for lavaan.mi-class objects (semTools) |
|
| 512 | ! |
if (!is.null(x$riv)) m[se.idx, "riv"] <- "" |
| 513 |
} |
|
| 514 | ||
| 515 | ! |
not.idx <- which(x$op %in% c(":=", "<", ">", "=="))
|
| 516 | ! |
if (length(not.idx) > 0L) {
|
| 517 | ! |
if (!is.null(x$fmi)) {
|
| 518 | ! |
m[not.idx, "fmi"] <- "" |
| 519 |
## for lavaan.mi-class objects (semTools) |
|
| 520 | ! |
if (!is.null(x$riv)) m[not.idx, "riv"] <- "" |
| 521 |
} |
|
| 522 |
} |
|
| 523 |
} |
|
| 524 | ||
| 525 |
# for blavaan, handle Post.SD and PSRF |
|
| 526 | 20x |
if (!is.null(x$Post.SD)) {
|
| 527 | ! |
se.idx <- which(x$Post.SD == 0) |
| 528 | ! |
if (length(se.idx) > 0L) {
|
| 529 | ! |
m[se.idx, "Post.SD"] <- "" |
| 530 | ! |
if (!is.null(x$psrf)) {
|
| 531 | ! |
m[se.idx, "psrf"] <- "" |
| 532 |
} |
|
| 533 | ! |
if (!is.null(x$PSRF)) {
|
| 534 | ! |
m[se.idx, "PSRF"] <- "" |
| 535 |
} |
|
| 536 |
} |
|
| 537 | ||
| 538 |
# handle psrf for defined parameters |
|
| 539 | ! |
not.idx <- which(x$op %in% c(":=", "<", ">", "=="))
|
| 540 | ! |
if (length(not.idx) > 0L) {
|
| 541 | ! |
if (!is.null(x$psrf)) {
|
| 542 | ! |
m[not.idx, "psrf"] <- "" |
| 543 |
} |
|
| 544 | ! |
if (!is.null(x$PSRF)) {
|
| 545 | ! |
m[not.idx, "PSRF"] <- "" |
| 546 |
} |
|
| 547 |
} |
|
| 548 |
} |
|
| 549 | ||
| 550 |
# rename some column names |
|
| 551 | 20x |
colnames(m)[colnames(m) == "lhs"] <- "" |
| 552 | 20x |
colnames(m)[colnames(m) == "op"] <- "" |
| 553 | 20x |
colnames(m)[colnames(m) == "rhs"] <- "" |
| 554 | 20x |
colnames(m)[colnames(m) == "step"] <- "Step" |
| 555 | 20x |
colnames(m)[colnames(m) == "est"] <- "Estimate" |
| 556 | 20x |
colnames(m)[colnames(m) == "se"] <- "Std.Err" |
| 557 | 20x |
colnames(m)[colnames(m) == "z"] <- "z-value" |
| 558 | 20x |
colnames(m)[colnames(m) == "pvalue"] <- "P(>|z|)" |
| 559 | 20x |
colnames(m)[colnames(m) == "std.lv"] <- "Std.lv" |
| 560 | 20x |
colnames(m)[colnames(m) == "std.all"] <- "Std.all" |
| 561 | 20x |
colnames(m)[colnames(m) == "std.nox"] <- "Std.nox" |
| 562 | 20x |
colnames(m)[colnames(m) == "prior"] <- "Prior" |
| 563 | 20x |
colnames(m)[colnames(m) == "fmi"] <- "FMI" |
| 564 |
## for lavaan.mi-class objects (semTools) |
|
| 565 | 20x |
if ("t" %in% colnames(m)) {
|
| 566 | ! |
colnames(m)[colnames(m) == "t"] <- "t-value" |
| 567 | ! |
colnames(m)[colnames(m) == "P(>|z|)"] <- "P(>|t|)" |
| 568 | ! |
colnames(m)[colnames(m) == "riv"] <- "RIV" |
| 569 |
} |
|
| 570 | ||
| 571 |
# format column names |
|
| 572 | 20x |
colnames(m) <- sprintf(char.format, colnames(m)) |
| 573 | ||
| 574 |
# exceptions for blavaan: Post.Mean (width = 9), Prior (width = 14) |
|
| 575 | 20x |
if (!is.null(x$Post.Mean)) {
|
| 576 | ! |
tmp <- gsub("[ \t]+", "", colnames(m), perl = TRUE)
|
| 577 | ||
| 578 |
# reformat "Post.Mean" column |
|
| 579 | ! |
col.idx <- which(tmp == "Post.Mean") |
| 580 | ! |
if (length(col.idx) > 0L) {
|
| 581 | ! |
tmp.format <- paste("%", max(9, nd + 5), "s", sep = "")
|
| 582 | ! |
colnames(m)[col.idx] <- sprintf(tmp.format, colnames(m)[col.idx]) |
| 583 | ! |
m[, col.idx] <- sprintf(tmp.format, m[, col.idx]) |
| 584 |
} |
|
| 585 | ||
| 586 |
# reformat "Prior" column |
|
| 587 | ! |
col.idx <- which(tmp == "Prior") |
| 588 | ! |
if (length(col.idx) > 0L) {
|
| 589 | ! |
MAX <- max(nchar(m[, col.idx])) + 1L |
| 590 | ! |
tmp.format <- paste("%", max(MAX, nd + 5), "s", sep = "")
|
| 591 | ! |
colnames(m)[col.idx] <- sprintf(tmp.format, colnames(m)[col.idx]) |
| 592 | ! |
m[, col.idx] <- sprintf(tmp.format, m[, col.idx]) |
| 593 |
} |
|
| 594 |
} |
|
| 595 | ||
| 596 | 20x |
b <- 0L |
| 597 |
# group-specific sections |
|
| 598 | 20x |
for (g in 1:ngroups) {
|
| 599 |
# group header |
|
| 600 | 22x |
if (ngroups > 1L) {
|
| 601 | 4x |
group.label <- attr(x, "group.label") |
| 602 | 4x |
cat("\n\n")
|
| 603 | 4x |
cat("Group ", g, " [", group.label[g], "]:\n", sep = "")
|
| 604 |
} |
|
| 605 | ||
| 606 | 22x |
for (l in 1:nlevels) {
|
| 607 |
# block number |
|
| 608 | 24x |
b <- b + 1L |
| 609 | ||
| 610 |
# ov/lv names |
|
| 611 | 24x |
ov.names <- lav_object_vnames(x, "ov", block = b) |
| 612 | 24x |
lv.names <- lav_object_vnames(x, "lv", block = b) |
| 613 | ||
| 614 |
# level header |
|
| 615 | 24x |
if (nlevels > 1L) {
|
| 616 | 4x |
level.label <- attr(x, "level.label") |
| 617 | 4x |
cat("\n\n")
|
| 618 | 4x |
cat("Level ", l, " [", level.label[l], "]:\n", sep = "")
|
| 619 |
} |
|
| 620 | ||
| 621 |
# group-specific sections |
|
| 622 | 24x |
for (s in GSECTIONS) {
|
| 623 | 240x |
if (s == "Latent Variables") {
|
| 624 | 24x |
row.idx <- which(x$op == "=~" & !x$lhs %in% ov.names & |
| 625 | 24x |
x$block == b) |
| 626 | 8x |
if (length(row.idx) == 0L) next |
| 627 | 16x |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx]) |
| 628 | 216x |
} else if (s == "Composites") {
|
| 629 | 24x |
row.idx <- which(x$op == "<~" & x$block == b) |
| 630 | 24x |
if (length(row.idx) == 0L) next |
| 631 | ! |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx]) |
| 632 | 192x |
} else if (s == "Regressions") {
|
| 633 | 24x |
row.idx <- which(x$op == "~" & x$block == b) |
| 634 | 8x |
if (length(row.idx) == 0L) next |
| 635 | 16x |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx]) |
| 636 | 168x |
} else if (s == "Covariances") {
|
| 637 | 24x |
row.idx <- which(x$op == "~~" & x$lhs != x$rhs & !x$exo & |
| 638 | 24x |
x$block == b) |
| 639 | 12x |
if (length(row.idx) == 0L) next |
| 640 |
# make distinction between residual and plain |
|
| 641 | 12x |
y.names <- unique(c( |
| 642 | 12x |
lav_object_vnames(x, "eqs.y"), |
| 643 | 12x |
lav_object_vnames(x, "ov.ind"), |
| 644 | 12x |
lav_object_vnames(x, "lv.ind") |
| 645 |
)) |
|
| 646 | 12x |
PREFIX <- rep("", length(row.idx))
|
| 647 | 12x |
PREFIX[x$rhs[row.idx] %in% y.names] <- " ." |
| 648 | 12x |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx], |
| 649 | 12x |
PREFIX = PREFIX |
| 650 |
) |
|
| 651 |
# m[row.idx,1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx]) |
|
| 652 | 144x |
} else if (s == "Intercepts") {
|
| 653 | 24x |
row.idx <- which(x$op == "~1" & !x$exo & x$block == b) |
| 654 | 11x |
if (length(row.idx) == 0L) next |
| 655 |
# make distinction between intercepts and means |
|
| 656 | 13x |
y.names <- unique(c( |
| 657 | 13x |
lav_object_vnames(x, "eqs.y"), |
| 658 | 13x |
lav_object_vnames(x, "ov.ind"), |
| 659 | 13x |
lav_object_vnames(x, "lv.ind") |
| 660 |
)) |
|
| 661 | 13x |
PREFIX <- rep("", length(row.idx))
|
| 662 | 13x |
PREFIX[x$lhs[row.idx] %in% y.names] <- " ." |
| 663 | 13x |
m[row.idx, 1] <- lav_print_format_names(x$lhs[row.idx], x$label[row.idx], |
| 664 | 13x |
PREFIX = PREFIX |
| 665 |
) |
|
| 666 |
# m[row.idx,1] <- lav_print_format_names(x$lhs[row.idx], x$label[row.idx]) |
|
| 667 | 120x |
} else if (s == "Thresholds") {
|
| 668 | 24x |
row.idx <- which(x$op == "|" & x$block == b) |
| 669 | 23x |
if (length(row.idx) == 0L) next |
| 670 | 1x |
m[row.idx, 1] <- lav_print_format_names(paste(x$lhs[row.idx], "|", |
| 671 | 1x |
x$rhs[row.idx], |
| 672 | 1x |
sep = "" |
| 673 | 1x |
), x$label[row.idx]) |
| 674 | 96x |
} else if (s == "Variances") {
|
| 675 | 24x |
row.idx <- which(x$op == "~~" & x$lhs == x$rhs & !x$exo & |
| 676 | 24x |
x$block == b) |
| 677 | ! |
if (length(row.idx) == 0L) next |
| 678 |
# make distinction between residual and plain |
|
| 679 | 24x |
y.names <- unique(c( |
| 680 | 24x |
lav_object_vnames(x, "eqs.y"), |
| 681 | 24x |
lav_object_vnames(x, "ov.ind"), |
| 682 | 24x |
lav_object_vnames(x, "lv.ind") |
| 683 |
)) |
|
| 684 | 24x |
PREFIX <- rep("", length(row.idx))
|
| 685 | 24x |
PREFIX[x$rhs[row.idx] %in% y.names] <- " ." |
| 686 | 24x |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx], |
| 687 | 24x |
PREFIX = PREFIX |
| 688 |
) |
|
| 689 | 72x |
} else if (s == "Scales y*") {
|
| 690 | 24x |
row.idx <- which(x$op == "~*~" & x$block == b) |
| 691 | 24x |
if (length(row.idx) == 0L) next |
| 692 | ! |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx]) |
| 693 | 48x |
} else if (s == "Group Weight") {
|
| 694 | 24x |
row.idx <- which(x$lhs == "group" & x$op == "%" & x$block == b) |
| 695 | 24x |
if (length(row.idx) == 0L) next |
| 696 | ! |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx]) |
| 697 | 24x |
} else if (s == "R-Square") {
|
| 698 | 24x |
row.idx <- which(x$op == "r2" & x$block == b) |
| 699 | 24x |
if (length(row.idx) == 0L) next |
| 700 | ! |
m[row.idx, 1] <- lav_print_format_names(x$rhs[row.idx], x$label[row.idx]) |
| 701 |
} else {
|
|
| 702 | ! |
row.idx <- integer(0L) |
| 703 |
} |
|
| 704 | ||
| 705 |
# do we need special formatting for this section? |
|
| 706 |
# three types: |
|
| 707 |
# - regular (nothing to do, except row/colnames) |
|
| 708 |
# - R-square |
|
| 709 |
# - Latent Variables (and Composites), Regressions and Covariances |
|
| 710 |
# 'bundle' the output per lhs element |
|
| 711 | ||
| 712 |
# bundling |
|
| 713 | 82x |
if (s %in% c( |
| 714 | 82x |
"Latent Variables", "Composites", |
| 715 | 82x |
"Regressions", "Covariances" |
| 716 |
)) {
|
|
| 717 | 44x |
nel <- length(row.idx) |
| 718 | 44x |
M <- matrix("", nrow = nel * 2, ncol = ncol(m))
|
| 719 | 44x |
colnames(M) <- colnames(m) |
| 720 | 44x |
rownames(M) <- rep("", NROW(M))
|
| 721 |
# colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
|
|
| 722 | 44x |
if (is.null(x$efa)) {
|
| 723 | 44x |
LHS <- paste(x$lhs[row.idx], x$op[row.idx]) |
| 724 |
} else {
|
|
| 725 | ! |
LHS <- paste( |
| 726 | ! |
x$lhs[row.idx], x$op[row.idx], |
| 727 | ! |
x$efa[row.idx] |
| 728 |
) |
|
| 729 |
} |
|
| 730 | 44x |
lhs.idx <- seq(1, nel * 2L, 2L) |
| 731 | 44x |
rhs.idx <- seq(1, nel * 2L, 2L) + 1L |
| 732 | 44x |
if (s == "Covariances") {
|
| 733 |
# make distinction between residual and plain |
|
| 734 | 12x |
y.names <- unique(c( |
| 735 | 12x |
lav_object_vnames(x, "eqs.y"), |
| 736 | 12x |
lav_object_vnames(x, "ov.ind"), |
| 737 | 12x |
lav_object_vnames(x, "lv.ind") |
| 738 |
)) |
|
| 739 | 12x |
PREFIX <- rep("", length(row.idx))
|
| 740 | 12x |
PREFIX[x$lhs[row.idx] %in% y.names] <- "." |
| 741 |
} else {
|
|
| 742 | 32x |
PREFIX <- rep("", length(LHS))
|
| 743 |
} |
|
| 744 | 44x |
M[lhs.idx, 1] <- sprintf("%1s%-15s", PREFIX, LHS)
|
| 745 | 44x |
M[rhs.idx, ] <- m[row.idx, ] |
| 746 |
# avoid duplicated LHS labels |
|
| 747 | 44x |
if (nel > 1L) {
|
| 748 | 42x |
del.idx <- integer(0) |
| 749 | 42x |
old.lhs <- "" |
| 750 | 42x |
for (i in 1:nel) {
|
| 751 | 280x |
if (LHS[i] == old.lhs) {
|
| 752 | 146x |
del.idx <- c(del.idx, lhs.idx[i]) |
| 753 |
} |
|
| 754 | 280x |
old.lhs <- LHS[i] |
| 755 |
} |
|
| 756 | 42x |
if (length(del.idx) > 0L) {
|
| 757 | 38x |
M <- M[-del.idx, , drop = FALSE] |
| 758 |
} |
|
| 759 |
} |
|
| 760 | 44x |
cat("\n", s, ":\n", sep = "")
|
| 761 |
# cat("\n")
|
|
| 762 | 44x |
print(M, quote = FALSE) |
| 763 | ||
| 764 |
# R-square |
|
| 765 | 38x |
} else if (s == "R-Square") {
|
| 766 | ! |
M <- m[row.idx, 1:2, drop = FALSE] |
| 767 | ! |
colnames(M) <- colnames(m)[1:2] |
| 768 | ! |
rownames(M) <- rep("", NROW(M))
|
| 769 |
# colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
|
|
| 770 | ! |
cat("\n", s, ":\n", sep = "")
|
| 771 |
# cat("\n")
|
|
| 772 | ! |
print(M, quote = FALSE) |
| 773 | ||
| 774 |
# Regular |
|
| 775 |
} else {
|
|
| 776 |
# M <- rbind(matrix("", nrow = 1L, ncol = ncol(m)),
|
|
| 777 |
# m[row.idx,]) |
|
| 778 | 38x |
M <- m[row.idx, , drop = FALSE] |
| 779 | 38x |
colnames(M) <- colnames(m) |
| 780 | 38x |
rownames(M) <- rep("", NROW(M))
|
| 781 |
# colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
|
|
| 782 | 38x |
cat("\n", s, ":\n", sep = "")
|
| 783 |
# cat("\n")
|
|
| 784 | 38x |
print(M, quote = FALSE) |
| 785 |
} |
|
| 786 |
} # GSECTIONS |
|
| 787 |
} # levels |
|
| 788 |
} # groups |
|
| 789 | ||
| 790 |
# asections |
|
| 791 | 20x |
for (s in ASECTIONS) {
|
| 792 | 40x |
if (s == "Defined Parameters") {
|
| 793 | 20x |
row.idx <- which(x$op == ":=") |
| 794 | 20x |
m[row.idx, 1] <- lav_print_format_names(x$lhs[row.idx], "") |
| 795 | 20x |
M <- m[row.idx, , drop = FALSE] |
| 796 | 20x |
colnames(M) <- colnames(m) |
| 797 | 20x |
} else if (s == "Constraints") {
|
| 798 | 20x |
row.idx <- which(x$op %in% c("==", "<", ">"))
|
| 799 | 20x |
if (length(row.idx) == 0) next |
| 800 | ! |
m[row.idx, 1] <- lav_print_format_constraints(x$lhs[row.idx], x$op[row.idx], |
| 801 | ! |
x$rhs[row.idx], |
| 802 | ! |
nd = nd |
| 803 |
) |
|
| 804 | ! |
m[row.idx, 2] <- sprintf(num.format, abs(x$est[row.idx])) |
| 805 | ! |
M <- m[row.idx, 1:2, drop = FALSE] |
| 806 | ! |
colnames(M) <- c("", sprintf(char.format, "|Slack|"))
|
| 807 |
} else {
|
|
| 808 | ! |
row.idx <- integer(0L) |
| 809 |
} |
|
| 810 | ||
| 811 | 20x |
if (length(row.idx) == 0L) {
|
| 812 | 19x |
next |
| 813 |
} |
|
| 814 | ||
| 815 | 1x |
rownames(M) <- rep("", NROW(M))
|
| 816 |
# colnames(M)[1] <- sprintf("%-17s", paste(s, ":", sep = ""))
|
|
| 817 |
# cat("\n")
|
|
| 818 | 1x |
cat("\n", s, ":\n", sep = "")
|
| 819 | 1x |
print(M, quote = FALSE) |
| 820 |
} |
|
| 821 | 20x |
cat("\n")
|
| 822 | ||
| 823 | 20x |
invisible(m) |
| 824 |
} |
|
| 825 | ||
| 826 |
lav_print_format_names <- function(NAMES, LABELS, PREFIX = NULL) {
|
|
| 827 | 102x |
W <- 14 |
| 828 | 102x |
if (is.null(PREFIX)) {
|
| 829 | 53x |
PREFIX <- rep("", length(NAMES))
|
| 830 |
} |
|
| 831 | ||
| 832 | 102x |
multiB <- FALSE |
| 833 | 102x |
if (any(nchar(NAMES) != nchar(NAMES, "bytes"))) {
|
| 834 | ! |
multiB <- TRUE |
| 835 |
} |
|
| 836 | 102x |
if (any(nchar(LABELS) != nchar(LABELS, "bytes"))) {
|
| 837 | ! |
multiB <- TRUE |
| 838 |
} |
|
| 839 |
# labels? |
|
| 840 | 102x |
l.idx <- which(nchar(LABELS) > 0L) |
| 841 | 102x |
if (length(l.idx) > 0L) {
|
| 842 | 16x |
if (!multiB) {
|
| 843 | 16x |
LABELS <- abbreviate(LABELS, 4) |
| 844 | 16x |
LABELS[l.idx] <- paste(" (", LABELS[l.idx], ")", sep = "")
|
| 845 | 16x |
MAX.L <- max(nchar(LABELS)) |
| 846 | 16x |
NAMES <- abbreviate(NAMES, |
| 847 | 16x |
minlength = (W - MAX.L), |
| 848 | 16x |
strict = TRUE |
| 849 |
) |
|
| 850 |
} else {
|
|
| 851 |
# do not abbreviate anything (eg in multi-byte locales) |
|
| 852 | ! |
MAX.L <- 4L |
| 853 |
} |
|
| 854 | 16x |
NAMES <- sprintf(paste("%-", (W - MAX.L), "s%", MAX.L, "s",
|
| 855 | 16x |
sep = "" |
| 856 | 16x |
), NAMES, LABELS) |
| 857 |
} else {
|
|
| 858 | 86x |
if (!multiB) {
|
| 859 | 86x |
NAMES <- abbreviate(NAMES, minlength = W, strict = TRUE) |
| 860 |
} else {
|
|
| 861 | ! |
NAMES <- sprintf(paste("%-", W, "s", sep = ""), NAMES)
|
| 862 |
} |
|
| 863 |
} |
|
| 864 | ||
| 865 | 102x |
char.format <- paste("%3s%-", W, "s", sep = "")
|
| 866 | 102x |
sprintf(char.format, PREFIX, NAMES) |
| 867 |
} |
|
| 868 | ||
| 869 |
lav_print_format_constraints <- function(lhs, op, rhs, nd) {
|
|
| 870 | ! |
nd <- max(nd, 3) |
| 871 | ! |
W <- 41 + (nd - 3) * 3 |
| 872 | ||
| 873 | ! |
nel <- length(lhs) |
| 874 | ! |
if (length(nel) == 0L) {
|
| 875 | ! |
return(character(0)) |
| 876 |
} |
|
| 877 | ! |
NAMES <- character(nel) |
| 878 | ! |
for (i in 1:nel) {
|
| 879 | ! |
if (rhs[i] == "0" && op[i] == ">") {
|
| 880 | ! |
con.string <- paste(lhs[i], " - 0", sep = "") |
| 881 | ! |
} else if (rhs[i] == "0" && op[i] == "<") {
|
| 882 | ! |
con.string <- paste(rhs[i], " - (", lhs[i], ")", sep = "")
|
| 883 | ! |
} else if (rhs[i] != "0" && op[i] == ">") {
|
| 884 | ! |
con.string <- paste(lhs[i], " - (", rhs[i], ")", sep = "")
|
| 885 | ! |
} else if (rhs[i] != "0" && op[i] == "<") {
|
| 886 | ! |
con.string <- paste(rhs[i], " - (", lhs[i], ")", sep = "")
|
| 887 | ! |
} else if (rhs[i] == "0" && op[i] == "==") {
|
| 888 | ! |
con.string <- paste(lhs[i], " - 0", sep = "") |
| 889 | ! |
} else if (rhs[i] != "0" && op[i] == "==") {
|
| 890 | ! |
con.string <- paste(lhs[i], " - (", rhs[i], ")", sep = "")
|
| 891 |
} |
|
| 892 | ! |
con.string <- abbreviate(con.string, W, strict = TRUE) |
| 893 | ! |
char.format <- paste(" %-", W, "s", sep = "")
|
| 894 | ! |
NAMES[i] <- sprintf(char.format, con.string) |
| 895 |
} |
|
| 896 | ||
| 897 | ! |
NAMES |
| 898 |
} |
|
| 899 | ||
| 900 |
lav_fsr_summary <- function(object, ...) {
|
|
| 901 | ! |
dotdotdot <- list(...) |
| 902 | ! |
if (!is.null(dotdotdot$nd)) {
|
| 903 | ! |
nd <- dotdotdot$nd |
| 904 |
} else {
|
|
| 905 | ! |
nd <- 3L |
| 906 |
} |
|
| 907 | ||
| 908 | ! |
lav_fsr_print(x = object, nd = nd, mm = TRUE, struc = TRUE) |
| 909 |
} |
|
| 910 | ||
| 911 |
lav_fsr_print <- function(x, ..., nd = 3L, mm = FALSE, struc = FALSE) {
|
|
| 912 | ! |
y <- unclass(x) |
| 913 | ||
| 914 |
# print header |
|
| 915 | ! |
if (!is.null(y$header)) {
|
| 916 | ! |
cat(y$header) |
| 917 | ! |
cat("\n")
|
| 918 |
} |
|
| 919 | ||
| 920 | ! |
if (mm && !is.null(y$MM.FIT)) {
|
| 921 | ! |
cat("\n")
|
| 922 | ! |
nblocks <- length(y$MM.FIT) |
| 923 | ! |
for (b in seq_len(nblocks)) {
|
| 924 | ! |
cat( |
| 925 | ! |
"Measurement block for latent variable(s):", |
| 926 | ! |
paste(lav_object_vnames(y$MM.FIT[[b]], "lv")), "\n" |
| 927 |
) |
|
| 928 | ||
| 929 |
# fit measures? |
|
| 930 | ! |
b.options <- lavInspect(y$MM.FIT[[b]], "options") |
| 931 | ! |
if (!(length(b.options$test) == 1L && b.options$test == "none")) {
|
| 932 | ! |
cat("\n")
|
| 933 | ! |
print(fitMeasures(y$MM.FIT[[b]], c("chisq", "df", "pvalue", "cfi", "rmsea", "srmr")))
|
| 934 |
} |
|
| 935 | ||
| 936 |
# parameter estimates |
|
| 937 | ! |
PE <- lavParameterEstimates(y$MM.FIT[[b]], |
| 938 | ! |
ci = FALSE, |
| 939 | ! |
output = "text", header = TRUE |
| 940 |
) |
|
| 941 | ! |
lav_parameterestimates_print(PE, ..., nd = nd) |
| 942 | ! |
cat("\n")
|
| 943 |
} |
|
| 944 |
} |
|
| 945 | ||
| 946 |
# print PE |
|
| 947 | ! |
if (struc) {
|
| 948 | ! |
cat("Structural Part\n")
|
| 949 | ! |
cat("\n")
|
| 950 | ! |
print(summary(y$STRUC.FIT, |
| 951 | ! |
fit.measures = FALSE, estimates = FALSE, |
| 952 | ! |
modindices = FALSE |
| 953 |
)) |
|
| 954 | ! |
FIT <- fitMeasures(y$STRUC.FIT, fit.measures = "default") |
| 955 | ! |
if (FIT["df"] > 0) {
|
| 956 | ! |
lav_fitmeasures_print(FIT, add.h0 = FALSE) |
| 957 |
} |
|
| 958 |
} |
|
| 959 | ! |
PE <- lavParameterEstimates(y$STRUC.FIT, |
| 960 | ! |
ci = FALSE, |
| 961 | ! |
remove.eq = FALSE, remove.system.eq = TRUE, |
| 962 | ! |
remove.ineq = FALSE, remove.def = FALSE, |
| 963 | ! |
remove.nonfree = FALSE, remove.unused = TRUE, |
| 964 | ! |
output = "text", header = TRUE |
| 965 |
) |
|
| 966 | ! |
lav_parameterestimates_print(PE, ..., nd = nd) |
| 967 | ||
| 968 | ! |
invisible(y) |
| 969 |
} |
|
| 970 | ||
| 971 |
# new in 0.6-12 |
|
| 972 |
lav_summary_print <- function(x, ..., nd = 3L) {
|
|
| 973 | 24x |
y <- unclass(x) # change to ordinary list |
| 974 | ||
| 975 |
# get nd, if it is stored as an attribute |
|
| 976 | 24x |
ND <- attr(y, "nd") |
| 977 | 24x |
if (!is.null(ND) && is.numeric(ND)) {
|
| 978 | 24x |
nd <- as.integer(ND) |
| 979 |
} |
|
| 980 | ||
| 981 |
# header |
|
| 982 | 24x |
if (!is.null(y$header)) {
|
| 983 | 20x |
lavaan.version <- y$header$lavaan.version |
| 984 | 20x |
sam.approach <- y$header$sam.approach |
| 985 | 20x |
optim.method <- y$header$optim.method |
| 986 | 20x |
optim.iterations <- y$header$optim.iterations |
| 987 | 20x |
optim.converged <- y$header$optim.converged |
| 988 | ||
| 989 |
# sam or sem? |
|
| 990 | 20x |
if (sam.approach) {
|
| 991 | ! |
cat("This is ",
|
| 992 | ! |
sprintf("lavaan %s", lavaan.version),
|
| 993 | ! |
" -- using the SAM approach to SEM\n", |
| 994 | ! |
sep = "" |
| 995 |
) |
|
| 996 |
} else {
|
|
| 997 | 20x |
cat(sprintf("lavaan %s ", lavaan.version))
|
| 998 | ||
| 999 |
# Convergence or not? |
|
| 1000 | 20x |
if (optim.method == "none") {
|
| 1001 | ! |
cat("-- DRY RUN with 0 iterations --\n")
|
| 1002 | 20x |
} else if (optim.iterations > 0) {
|
| 1003 | 20x |
if (optim.converged) {
|
| 1004 | 20x |
if (optim.iterations == 1L) {
|
| 1005 | 5x |
cat("ended normally after 1 iteration\n")
|
| 1006 |
} else {
|
|
| 1007 | 15x |
cat(sprintf( |
| 1008 | 15x |
"ended normally after %i iterations\n", |
| 1009 | 15x |
optim.iterations |
| 1010 |
)) |
|
| 1011 |
} |
|
| 1012 |
} else {
|
|
| 1013 | ! |
if (optim.iterations == 1L) {
|
| 1014 | ! |
cat("did NOT end normally after 1 iteration\n")
|
| 1015 |
} else {
|
|
| 1016 | ! |
cat(sprintf( |
| 1017 | ! |
"did NOT end normally after %i iterations\n", |
| 1018 | ! |
optim.iterations |
| 1019 |
)) |
|
| 1020 |
} |
|
| 1021 | ! |
cat("** WARNING ** Estimates below are most likely unreliable\n")
|
| 1022 |
} |
|
| 1023 |
} else {
|
|
| 1024 | ! |
cat("did not run (perhaps do.fit = FALSE)?\n")
|
| 1025 | ! |
cat("** WARNING ** Estimates below are simply the starting values\n")
|
| 1026 |
} |
|
| 1027 |
} |
|
| 1028 |
} |
|
| 1029 | ||
| 1030 |
#TDJ: print header for lavaan.mi object (or nothing when NULL) |
|
| 1031 | 24x |
cat(y$top_of_lavaanmi) |
| 1032 | ||
| 1033 |
# optim |
|
| 1034 | 24x |
if (!is.null(y$optim)) {
|
| 1035 | 20x |
estimator <- y$optim$estimator |
| 1036 | 20x |
estimator.args <- y$optim$estimator.args |
| 1037 | 20x |
optim.method <- y$optim$optim.method |
| 1038 | 20x |
npar <- y$optim$npar |
| 1039 | 20x |
eq.constraints <- y$optim$eq.constraints |
| 1040 | 20x |
nrow.ceq.jac <- y$optim$nrow.ceq.jac |
| 1041 | 20x |
nrow.cin.jac <- y$optim$nrow.cin.jac |
| 1042 | 20x |
nrow.con.jac <- y$optim$nrow.con.jac |
| 1043 | 20x |
con.jac.rank <- y$optim$con.jac.rank |
| 1044 | ||
| 1045 | 20x |
cat("\n")
|
| 1046 |
# cat("Optimization information:\n\n")
|
|
| 1047 | ||
| 1048 | 20x |
c1 <- c("Estimator")
|
| 1049 |
# second column |
|
| 1050 | 20x |
tmp.est <- toupper(estimator) |
| 1051 | 20x |
if (tmp.est == "DLS") {
|
| 1052 | ! |
dls.first.letter <- substr( |
| 1053 | ! |
estimator.args$dls.GammaNT, |
| 1054 | ! |
1L, 1L |
| 1055 |
) |
|
| 1056 | ! |
tmp.est <- paste("DLS-", toupper(dls.first.letter), sep = "")
|
| 1057 |
} |
|
| 1058 | 20x |
c2 <- tmp.est |
| 1059 | ||
| 1060 |
# additional estimator args |
|
| 1061 | 20x |
if (!is.null(estimator.args) && |
| 1062 | 20x |
length(estimator.args) > 0L) {
|
| 1063 | ! |
if (estimator == "DLS") {
|
| 1064 | ! |
c1 <- c(c1, "Estimator DLS value for a") |
| 1065 | ! |
c2 <- c(c2, estimator.args$dls.a) |
| 1066 |
} |
|
| 1067 |
} |
|
| 1068 | ||
| 1069 |
# optimization method + npar |
|
| 1070 | 20x |
c1 <- c(c1, "Optimization method", "Number of model parameters") |
| 1071 | 20x |
c2 <- c(c2, toupper(optim.method), npar) |
| 1072 | ||
| 1073 |
# optional output |
|
| 1074 | 20x |
if (eq.constraints) {
|
| 1075 | 5x |
c1 <- c(c1, "Number of equality constraints") |
| 1076 | 5x |
c2 <- c(c2, nrow.ceq.jac) |
| 1077 |
} |
|
| 1078 | 20x |
if (nrow.cin.jac > 0L) {
|
| 1079 | 1x |
c1 <- c(c1, "Number of inequality constraints") |
| 1080 | 1x |
c2 <- c(c2, nrow.cin.jac) |
| 1081 |
} |
|
| 1082 | 20x |
if (nrow.con.jac > 0L) {
|
| 1083 | 6x |
if (con.jac.rank == (nrow.ceq.jac + nrow.cin.jac)) {
|
| 1084 |
# nothing to do (don't print, as this is redundant information) |
|
| 1085 |
} else {
|
|
| 1086 | ! |
c1 <- c(c1, "Row rank of the constraints matrix") |
| 1087 | ! |
c2 <- c(c2, con.jac.rank) |
| 1088 |
} |
|
| 1089 |
} |
|
| 1090 | ||
| 1091 |
# format |
|
| 1092 | 20x |
c1 <- format(c1, width = 40L) |
| 1093 | 20x |
c2 <- format(c2, |
| 1094 | 20x |
width = 11L + max(0, (nd - 3L)) * 4L, |
| 1095 | 20x |
justify = "right" |
| 1096 |
) |
|
| 1097 | ||
| 1098 |
# character matrix |
|
| 1099 | 20x |
M <- cbind(c1, c2, deparse.level = 0) |
| 1100 | 20x |
colnames(M) <- rep("", ncol(M))
|
| 1101 | 20x |
rownames(M) <- rep(" ", nrow(M))
|
| 1102 | ||
| 1103 |
|
|
| 1104 | 20x |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1105 |
} |
|
| 1106 | ||
| 1107 |
# sam header |
|
| 1108 | 24x |
if (!is.null(y$sam.header)) {
|
| 1109 | ! |
cat("\n")
|
| 1110 | ! |
sam.method <- y$sam.header$sam.method |
| 1111 | ! |
sam.local.options <- y$sam.header$sam.local.options |
| 1112 | ! |
sam.mm.list <- y$sam.header$sam.mm.list |
| 1113 | ! |
sam.mm.estimator <- y$sam.header$sam.mm.estimator |
| 1114 | ! |
sam.struc.estimator <- y$sam.header$sam.struc.estimator |
| 1115 | ||
| 1116 |
# sam method |
|
| 1117 | ! |
c1 <- c("SAM method")
|
| 1118 | ! |
c2 <- toupper(sam.method) |
| 1119 | ||
| 1120 |
# options |
|
| 1121 | ! |
if (sam.method == "local") {
|
| 1122 | ! |
c1 <- c(c1, "Mapping matrix M method") |
| 1123 | ! |
c2 <- c(c2, sam.local.options$M.method) |
| 1124 |
# TODo: more! |
|
| 1125 |
} |
|
| 1126 | ||
| 1127 |
# number of measurement blocks |
|
| 1128 | ! |
c1 <- c(c1, "Number of measurement blocks") |
| 1129 | ! |
c2 <- c(c2, length(sam.mm.list)) |
| 1130 | ||
| 1131 |
# estimator measurement blocks |
|
| 1132 | ! |
c1 <- c(c1, "Estimator measurement part") |
| 1133 | ! |
c2 <- c(c2, sam.mm.estimator) |
| 1134 | ||
| 1135 |
# estimator structural part |
|
| 1136 | ! |
c1 <- c(c1, "Estimator structural part") |
| 1137 | ! |
c2 <- c(c2, sam.struc.estimator) |
| 1138 | ||
| 1139 |
# format |
|
| 1140 | ! |
c1 <- format(c1, width = 40L) |
| 1141 | ! |
c2 <- format(c2, |
| 1142 | ! |
width = 11L + max(0, (nd - 3L)) * 4L, |
| 1143 | ! |
justify = "right" |
| 1144 |
) |
|
| 1145 | ||
| 1146 |
# character matrix |
|
| 1147 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1148 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1149 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1150 | ||
| 1151 |
|
|
| 1152 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1153 |
} |
|
| 1154 | ||
| 1155 |
# efa/rotation |
|
| 1156 | 24x |
if (!is.null(y$rotation)) {
|
| 1157 | ! |
cat("\n")
|
| 1158 | ! |
rotation <- y$rotation |
| 1159 | ! |
rotation.args <- y$rotation.args |
| 1160 | ||
| 1161 |
# cat("Rotation information:\n\n")
|
|
| 1162 |
# container |
|
| 1163 | ! |
c1 <- c2 <- character(0L) |
| 1164 | ||
| 1165 |
# rotation method |
|
| 1166 | ! |
c1 <- c(c1, "Rotation method") |
| 1167 | ! |
if (rotation$rotation == "none") {
|
| 1168 | ! |
MM <- toupper(rotation$rotation) |
| 1169 | ! |
} else if (rotation$rotation.args$orthogonal) {
|
| 1170 | ! |
MM <- paste(toupper(rotation$rotation), " ", "ORTHOGONAL", |
| 1171 | ! |
sep = "" |
| 1172 |
) |
|
| 1173 |
} else {
|
|
| 1174 | ! |
MM <- paste(toupper(rotation$rotation), " ", "OBLIQUE", |
| 1175 | ! |
sep = "" |
| 1176 |
) |
|
| 1177 |
} |
|
| 1178 | ! |
c2 <- c(c2, MM) |
| 1179 | ||
| 1180 | ! |
if (rotation$rotation != "none") {
|
| 1181 |
# method options |
|
| 1182 | ! |
if (rotation$rotation == "geomin") {
|
| 1183 | ! |
c1 <- c(c1, "Geomin epsilon") |
| 1184 | ! |
c2 <- c(c2, rotation$rotation.args$geomin.epsilon) |
| 1185 | ! |
} else if (rotation$rotation == "orthomax") {
|
| 1186 | ! |
c1 <- c(c1, "Orthomax gamma") |
| 1187 | ! |
c2 <- c(c2, rotation$rotation.args$orthomax.gamma) |
| 1188 | ! |
} else if (rotation$rotation == "cf") {
|
| 1189 | ! |
c1 <- c(c1, "Crawford-Ferguson gamma") |
| 1190 | ! |
c2 <- c(c2, rotation$rotation.args$cf.gamma) |
| 1191 | ! |
} else if (rotation$rotation == "oblimin") {
|
| 1192 | ! |
c1 <- c(c1, "Oblimin gamma") |
| 1193 | ! |
c2 <- c(c2, rotation$rotation.args$oblimin.gamma) |
| 1194 | ! |
} else if (rotation$rotation == "promax") {
|
| 1195 | ! |
c1 <- c(c1, "Promax kappa") |
| 1196 | ! |
c2 <- c(c2, rotation$rotation.args$promax.kappa) |
| 1197 |
} |
|
| 1198 | ||
| 1199 |
# rotation algorithm |
|
| 1200 | ! |
c1 <- c(c1, "Rotation algorithm (rstarts)") |
| 1201 | ! |
tmp <- paste(toupper(rotation$rotation.args$algorithm), |
| 1202 | ! |
" (", rotation$rotation.args$rstarts, ")",
|
| 1203 | ! |
sep = "" |
| 1204 |
) |
|
| 1205 | ! |
c2 <- c(c2, tmp) |
| 1206 | ||
| 1207 |
# Standardized metric (or not) |
|
| 1208 | ! |
c1 <- c(c1, "Standardized metric") |
| 1209 | ! |
if (rotation$rotation.args$std.ov) {
|
| 1210 | ! |
c2 <- c(c2, "TRUE") |
| 1211 |
} else {
|
|
| 1212 | ! |
c2 <- c(c2, "FALSE") |
| 1213 |
} |
|
| 1214 | ||
| 1215 |
# Row weights |
|
| 1216 | ! |
c1 <- c(c1, "Row weights") |
| 1217 | ! |
tmp.txt <- rotation$rotation.args$row.weights |
| 1218 | ! |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 1219 | ! |
substring(tmp.txt, 2), |
| 1220 | ! |
sep = "" |
| 1221 |
)) |
|
| 1222 |
} |
|
| 1223 | ||
| 1224 |
# format c1/c2 |
|
| 1225 | ! |
c1 <- format(c1, width = 33L) |
| 1226 | ! |
c2 <- format(c2, |
| 1227 | ! |
width = 18L + max(0, (nd - 3L)) * 4L, |
| 1228 | ! |
justify = "right" |
| 1229 |
) |
|
| 1230 | ||
| 1231 |
# create character matrix |
|
| 1232 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1233 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1234 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1235 | ||
| 1236 |
|
|
| 1237 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1238 |
} |
|
| 1239 | ||
| 1240 |
# data object |
|
| 1241 | 24x |
if (!is.null(y$data)) {
|
| 1242 | 20x |
cat("\n")
|
| 1243 | 20x |
lav_data_print_short(y$data, nd = nd) |
| 1244 |
} |
|
| 1245 | ||
| 1246 |
# sam local stats: measurement blocks + structural part |
|
| 1247 | 24x |
if (!is.null(y$sam)) {
|
| 1248 | ! |
cat("\n")
|
| 1249 | ! |
sam.method <- y$sam$sam.method |
| 1250 | ! |
sam.mm.table <- y$sam$sam.mm.table |
| 1251 | ! |
sam.mm.rel <- y$sam$sam.mm.rel |
| 1252 | ! |
sam.struc.fit <- y$sam$sam.struc.fit |
| 1253 | ! |
ngroups <- y$sam$ngroups |
| 1254 | ! |
nlevels <- y$sam$nlevels |
| 1255 | ! |
group.label <- y$sam$group.label |
| 1256 | ! |
level.label <- y$sam$level.label |
| 1257 | ! |
block.label <- y$sam$block.label |
| 1258 | ||
| 1259 |
# measurement |
|
| 1260 | ! |
tmp <- sam.mm.table |
| 1261 | ! |
if (sam.method == "global") {
|
| 1262 | ! |
cat("Summary Information Measurement Part:\n\n")
|
| 1263 |
} else {
|
|
| 1264 | ! |
cat("Summary Information Measurement + Structural:\n\n")
|
| 1265 |
} |
|
| 1266 | ! |
print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
|
| 1267 | ||
| 1268 | ! |
if (sam.method == "local") {
|
| 1269 |
# reliability information |
|
| 1270 | ! |
c1 <- c2 <- character(0L) |
| 1271 | ! |
if (ngroups == 1L && nlevels == 1L) {
|
| 1272 | ! |
cat("\n")
|
| 1273 | ! |
cat(" Model-based reliability latent variables:\n\n")
|
| 1274 | ! |
tmp <- data.frame(as.list(sam.mm.rel[[1]])) |
| 1275 | ! |
class(tmp) <- c("lavaan.data.frame", "data.frame")
|
| 1276 | ! |
print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
|
| 1277 | ! |
} else if (ngroups > 1L && nlevels == 1L) {
|
| 1278 | ! |
cat("\n")
|
| 1279 | ! |
cat(" Model-based reliability latent variables (per group):\n")
|
| 1280 | ! |
for (g in 1:ngroups) {
|
| 1281 | ! |
cat("\n")
|
| 1282 | ! |
cat(" Group ", g, " [", group.label[g], "]:\n\n",
|
| 1283 | ! |
sep = "" |
| 1284 |
) |
|
| 1285 | ! |
tmp <- data.frame(as.list(sam.mm.rel[[g]])) |
| 1286 | ! |
class(tmp) <- c("lavaan.data.frame", "data.frame")
|
| 1287 | ! |
print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
|
| 1288 |
} |
|
| 1289 | ! |
} else if (ngroups == 1L && nlevels > 1L) {
|
| 1290 | ! |
cat("\n")
|
| 1291 | ! |
cat(" Model-based reliability latent variables (per level):\n")
|
| 1292 | ! |
for (g in 1:nlevels) {
|
| 1293 | ! |
cat("\n")
|
| 1294 | ! |
cat(" Level ", g, " [", level.label[g], "]:\n\n",
|
| 1295 | ! |
sep = "" |
| 1296 |
) |
|
| 1297 | ! |
tmp <- data.frame(as.list(sam.mm.rel[[g]])) |
| 1298 | ! |
class(tmp) <- c("lavaan.data.frame", "data.frame")
|
| 1299 | ! |
print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
|
| 1300 |
} |
|
| 1301 | ! |
} else if (ngroups > 1L && nlevels > 1L) {
|
| 1302 | ! |
cat("\n")
|
| 1303 | ! |
cat(" Model-based reliability latent variables (per group/level):\n")
|
| 1304 | ! |
for (g in 1:length(block.label)) {
|
| 1305 | ! |
cat("\n")
|
| 1306 | ! |
cat(" Group/Level ", g, " [", block.label[g], "]:\n\n",
|
| 1307 | ! |
sep = "" |
| 1308 |
) |
|
| 1309 | ! |
tmp <- data.frame(as.list(sam.mm.rel[[g]])) |
| 1310 | ! |
class(tmp) <- c("lavaan.data.frame", "data.frame")
|
| 1311 | ! |
print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
|
| 1312 |
} |
|
| 1313 |
} |
|
| 1314 | ||
| 1315 | ! |
cat("\n")
|
| 1316 | ! |
cat(" Summary Information Structural part:\n\n")
|
| 1317 | ! |
tmp <- data.frame(as.list(sam.struc.fit)) |
| 1318 | ! |
class(tmp) <- c("lavaan.data.frame", "data.frame")
|
| 1319 | ! |
print(tmp, row.names = rep(" ", nrow(tmp)), nd = nd)
|
| 1320 |
} |
|
| 1321 |
} |
|
| 1322 | ||
| 1323 |
# test statistics |
|
| 1324 | 24x |
if (!is.null(y$test)) {
|
| 1325 | 20x |
cat("\n")
|
| 1326 | 20x |
lav_test_print(y$test, nd = nd) |
| 1327 |
} |
|
| 1328 | ||
| 1329 |
# extra fit measures (if present) |
|
| 1330 | 24x |
if (!is.null(y$fit)) {
|
| 1331 | ! |
add.h0 <- FALSE |
| 1332 | ! |
if (!is.null(attr(y$fit, "add.h0"))) {
|
| 1333 | ! |
add.h0 <- isTRUE(attr(y$fit, "add.h0")) |
| 1334 |
} |
|
| 1335 | ! |
lav_fitmeasures_print(y$fit, nd = nd, add.h0 = add.h0) |
| 1336 |
} |
|
| 1337 | ||
| 1338 |
# efa output |
|
| 1339 | 24x |
if (!is.null(y$efa)) {
|
| 1340 |
# get cutoff, if it is stored as an attribute |
|
| 1341 | 4x |
CT <- attr(y, "cutoff") |
| 1342 | 4x |
if (!is.null(CT) && is.numeric(CT)) {
|
| 1343 | 4x |
cutoff <- CT |
| 1344 |
} else {
|
|
| 1345 | ! |
cutoff <- 0.3 |
| 1346 |
} |
|
| 1347 |
# get dot.cutoff, if it is stored as an attribute |
|
| 1348 | 4x |
DC <- attr(y, "dot.cutoff") |
| 1349 | 4x |
if (!is.null(DC) && is.numeric(DC)) {
|
| 1350 | 4x |
dot.cutoff <- DC |
| 1351 |
} else {
|
|
| 1352 | ! |
dot.cutoff <- 0.1 |
| 1353 |
} |
|
| 1354 |
# get alpha.level, if it is stored as an attribute |
|
| 1355 | 4x |
AL <- attr(y, "alpha.level") |
| 1356 | 4x |
if (!is.null(AL) && is.numeric(AL)) {
|
| 1357 | 4x |
alpha.level <- AL |
| 1358 |
} else {
|
|
| 1359 | ! |
alpha.level <- 0.01 |
| 1360 |
} |
|
| 1361 | ||
| 1362 | 4x |
for (b in seq_len(y$efa$nblocks)) {
|
| 1363 | 4x |
if (length(y$efa$block.label) > 0L) {
|
| 1364 | ! |
cat("\n\n")
|
| 1365 | ! |
cat(y$efa$block.label[[b]], ":\n\n", sep = "") |
| 1366 |
} |
|
| 1367 | 4x |
if (!is.null(y$efa$lambda[[b]])) {
|
| 1368 | 4x |
cat("\n")
|
| 1369 | 4x |
if (!is.null(y$efa$lambda.se[[b]]) && alpha.level > 0) {
|
| 1370 | 4x |
cat("Standardized loadings: (* = significant at ",
|
| 1371 | 4x |
round(alpha.level * 100), |
| 1372 | 4x |
"% level)\n\n", |
| 1373 | 4x |
sep = "" |
| 1374 |
) |
|
| 1375 |
} else {
|
|
| 1376 | ! |
cat("Standardized loadings:\n\n")
|
| 1377 |
} |
|
| 1378 | 4x |
LAMBDA <- unclass(y$efa$lambda[[b]]) |
| 1379 | 4x |
THETA <- unname(unclass(y$efa$theta[[b]])) |
| 1380 | 4x |
lav_print_loadings(LAMBDA, |
| 1381 | 4x |
nd = nd, cutoff = cutoff, |
| 1382 | 4x |
dot.cutoff = dot.cutoff, |
| 1383 | 4x |
alpha.level = alpha.level, |
| 1384 | 4x |
resvar = THETA, # diag elements only |
| 1385 | 4x |
x.se = y$efa$lambda.se[[b]] |
| 1386 |
) |
|
| 1387 |
} |
|
| 1388 | ||
| 1389 | 4x |
if (!is.null(y$efa$sumsq.table[[b]])) {
|
| 1390 | 4x |
cat("\n")
|
| 1391 | 4x |
print(y$efa$sumsq.table[[b]], nd = nd) |
| 1392 |
} |
|
| 1393 | ||
| 1394 |
# factor correlations: |
|
| 1395 | 4x |
if (!y$efa$orthogonal && !is.null(y$efa$psi[[b]]) && |
| 1396 | 4x |
ncol(y$efa$psi[[b]]) > 1L) {
|
| 1397 | 3x |
cat("\n")
|
| 1398 | 3x |
if (!is.null(y$efa$psi.se[[b]]) && alpha.level > 0) {
|
| 1399 | 3x |
cat("Factor correlations: (* = significant at ",
|
| 1400 | 3x |
round(alpha.level * 100), |
| 1401 | 3x |
"% level)\n\n", |
| 1402 | 3x |
sep = "" |
| 1403 |
) |
|
| 1404 |
} else {
|
|
| 1405 | ! |
cat("Factor correlations:\n\n")
|
| 1406 |
} |
|
| 1407 | 3x |
lav_print_psi(y$efa$psi[[b]], |
| 1408 | 3x |
nd = nd, |
| 1409 | 3x |
alpha.level = alpha.level, |
| 1410 | 3x |
x.se = y$efa$psi.se[[b]] |
| 1411 |
) |
|
| 1412 |
} |
|
| 1413 | ||
| 1414 |
# factor score determinacy (for regression scores only!) |
|
| 1415 | 4x |
if (!is.null(y$efa$fs.determinacy[[b]])) {
|
| 1416 | ! |
cat("\n")
|
| 1417 | ! |
cat("Correlation regression factor scores and factors (determinacy):\n\n")
|
| 1418 | ! |
print(y$efa$fs.determinacy[[b]], nd = nd) |
| 1419 | ! |
cat("\n")
|
| 1420 | ! |
cat("R2 regression factor scores (= squared correlations):\n\n")
|
| 1421 | ! |
tmp <- y$efa$fs.determinacy[[b]] |
| 1422 | ! |
tmp2 <- tmp * tmp |
| 1423 | ! |
class(tmp2) <- c("lavaan.vector", "numeric")
|
| 1424 | ! |
print(tmp2, nd = nd) |
| 1425 |
} |
|
| 1426 | ||
| 1427 |
# lambda.structure |
|
| 1428 | 4x |
if (!is.null(y$efa$lambda.structure[[b]])) {
|
| 1429 | ! |
cat("\n")
|
| 1430 | ! |
cat("Standardized structure (= LAMBDA %*% PSI):\n\n")
|
| 1431 | ! |
print(y$efa$lambda.structure[[b]], nd = nd) |
| 1432 |
} |
|
| 1433 | ||
| 1434 |
# standard errors lambda |
|
| 1435 | 4x |
if (!is.null(y$efa$theta.se[[b]])) { # we check for theta.se
|
| 1436 |
# as lambda.se is needed for '*' |
|
| 1437 | ! |
cat("\n")
|
| 1438 | ! |
cat("Standard errors standardized loadings:\n\n")
|
| 1439 | ! |
print(y$efa$lambda.se[[b]], nd = nd) |
| 1440 |
} |
|
| 1441 | ||
| 1442 |
# z-statistics lambda |
|
| 1443 | 4x |
if (!is.null(y$efa$lambda.zstat[[b]])) {
|
| 1444 | ! |
cat("\n")
|
| 1445 | ! |
cat("Z-statistics standardized loadings:\n\n")
|
| 1446 | ! |
print(y$efa$lambda.zstat[[b]], nd = nd) |
| 1447 |
} |
|
| 1448 | ||
| 1449 |
# pvalues lambda |
|
| 1450 | 4x |
if (!is.null(y$efa$lambda.pvalue[[b]])) {
|
| 1451 | ! |
cat("\n")
|
| 1452 | ! |
cat("P-values standardized loadings:\n\n")
|
| 1453 | ! |
print(y$efa$lambda.pvalue[[b]], nd = nd) |
| 1454 |
} |
|
| 1455 | ||
| 1456 |
# standard errors theta |
|
| 1457 | 4x |
if (!is.null(y$efa$theta.se[[b]])) {
|
| 1458 | ! |
cat("\n")
|
| 1459 | ! |
cat("Standard errors unique variances:\n\n")
|
| 1460 | ! |
print(y$efa$theta.se[[b]], nd = nd) |
| 1461 |
} |
|
| 1462 | ||
| 1463 |
# z-statistics theta |
|
| 1464 | 4x |
if (!is.null(y$efa$theta.zstat[[b]])) {
|
| 1465 | ! |
cat("\n")
|
| 1466 | ! |
cat("Z-statistics unique variances:\n\n")
|
| 1467 | ! |
print(y$efa$theta.zstat[[b]], nd = nd) |
| 1468 |
} |
|
| 1469 | ||
| 1470 |
# pvalues theta |
|
| 1471 | 4x |
if (!is.null(y$efa$theta.pvalue[[b]])) {
|
| 1472 | ! |
cat("\n")
|
| 1473 | ! |
cat("P-values unique variances:\n\n")
|
| 1474 | ! |
print(y$efa$theta.pvalue[[b]], nd = nd) |
| 1475 |
} |
|
| 1476 | ||
| 1477 |
# standard errors psi |
|
| 1478 | 4x |
if (!is.null(y$efa$theta.se[[b]])) { # we check for theta.se
|
| 1479 |
# as psi.se is needed for '*' |
|
| 1480 | ! |
cat("\n")
|
| 1481 | ! |
cat("Standard errors factor correlations:\n\n")
|
| 1482 | ! |
print(y$efa$psi.se[[b]], nd = nd) |
| 1483 |
} |
|
| 1484 | ||
| 1485 |
# z-statistics psi |
|
| 1486 | 4x |
if (!is.null(y$efa$psi.zstat[[b]])) {
|
| 1487 | ! |
cat("\n")
|
| 1488 | ! |
cat("Z-statistics factor correlations:\n\n")
|
| 1489 | ! |
print(y$efa$psi.zstat[[b]], nd = nd) |
| 1490 |
} |
|
| 1491 | ||
| 1492 |
# pvalues psi |
|
| 1493 | 4x |
if (!is.null(y$efa$psi.pvalue[[b]])) {
|
| 1494 | ! |
cat("\n")
|
| 1495 | ! |
cat("P-values factor correlations:\n\n")
|
| 1496 | ! |
print(y$efa$psi.pvalue[[b]], nd = nd) |
| 1497 |
} |
|
| 1498 |
} # blocks |
|
| 1499 | 4x |
cat("\n")
|
| 1500 |
} # efa |
|
| 1501 | ||
| 1502 |
# parameter table |
|
| 1503 | 24x |
if (!is.null(y$pe) && is.null(y$efa)) {
|
| 1504 | 20x |
PE <- y$pe |
| 1505 | 20x |
class(PE) <- c( |
| 1506 | 20x |
"lavaan.parameterEstimates", "lavaan.data.frame", |
| 1507 | 20x |
"data.frame" |
| 1508 |
) |
|
| 1509 | 20x |
print(PE, nd = nd) |
| 1510 |
} |
|
| 1511 | ||
| 1512 |
# modification indices |
|
| 1513 | 24x |
if (!is.null(y$mi)) {
|
| 1514 | ! |
cat("Modification Indices:\n\n")
|
| 1515 | ! |
MI <- y$mi |
| 1516 | ! |
rownames(MI) <- NULL |
| 1517 | ! |
print(MI, nd = nd) |
| 1518 |
} |
|
| 1519 | ||
| 1520 | 24x |
invisible(y) |
| 1521 |
} |
|
| 1522 | ||
| 1523 |
# helper function to print the loading matrix, masking small loadings |
|
| 1524 |
lav_print_loadings <- function(x, nd = 3L, cutoff = 0.3, dot.cutoff = 0.1, |
|
| 1525 |
alpha.level = 0.01, resvar = NULL, x.se = NULL) {
|
|
| 1526 |
# unclass |
|
| 1527 | 4x |
y <- unclass(x) |
| 1528 | ||
| 1529 |
# round, and create a character matriy |
|
| 1530 | 4x |
y <- format(round(y, nd), width = 3L + nd, justify = "right") |
| 1531 | ||
| 1532 |
# right-align column names |
|
| 1533 | 4x |
colnames(y) <- format(colnames(y), width = 3L + nd, justify = "right") |
| 1534 | ||
| 1535 |
# create dot/empty string |
|
| 1536 | 4x |
dot.string <- format(".", width = 3L + nd, justify = "right")
|
| 1537 | 4x |
empty.string <- format(" ", width = 3L + nd)
|
| 1538 | ||
| 1539 |
# print a 'dot' if dot.cutoff < |loading| < cutoff |
|
| 1540 | 4x |
if (dot.cutoff < cutoff) {
|
| 1541 | 4x |
y[abs(x) < cutoff & abs(x) > dot.cutoff] <- dot.string |
| 1542 |
} |
|
| 1543 | ||
| 1544 |
# print nothing if |loading| < dot.cutoff |
|
| 1545 | 4x |
y[abs(x) < min(dot.cutoff, cutoff)] <- empty.string |
| 1546 | ||
| 1547 |
# add 'star' for significant loadings (if provided) using alpha = 0.01 |
|
| 1548 | 4x |
if (!is.null(x.se) && !any(is.na(x.se))) {
|
| 1549 | 4x |
colNAMES <- colnames(y) |
| 1550 | 4x |
rowNAMES <- rownames(y) |
| 1551 | 4x |
x.se[x.se < sqrt(.Machine$double.eps)] <- 1 # to avoid NA |
| 1552 | 4x |
zstat <- x / x.se |
| 1553 | 4x |
z.cutoff <- qnorm(1 - (alpha.level / 2)) |
| 1554 | 4x |
zstat.string <- ifelse(abs(zstat) > z.cutoff, "*", " ") |
| 1555 | 4x |
y <- matrix(paste(y, zstat.string, sep = ""), nrow(y), ncol(y)) |
| 1556 | 4x |
colnames(y) <- colNAMES |
| 1557 | 4x |
rownames(y) <- rowNAMES |
| 1558 |
} |
|
| 1559 | ||
| 1560 |
# add resvar |
|
| 1561 | 4x |
if (!is.null(resvar)) {
|
| 1562 | 4x |
NAMES <- colnames(y) |
| 1563 | 4x |
y <- cbind(y, format(round(cbind(resvar, 1 - resvar), nd), |
| 1564 | 4x |
width = 12L + nd, justify = "right" |
| 1565 |
)) |
|
| 1566 | 4x |
resvar.names <- format(c("unique.var", "communalities"),
|
| 1567 | 4x |
width = 12L + nd, justify = "right" |
| 1568 |
) |
|
| 1569 | 4x |
colnames(y) <- c(NAMES, resvar.names) |
| 1570 |
} |
|
| 1571 | ||
| 1572 |
|
|
| 1573 | 4x |
print(y, quote = FALSE) |
| 1574 |
} |
|
| 1575 | ||
| 1576 |
# helper function to print the psi matrix, showing signif stars |
|
| 1577 |
lav_print_psi <- function(x, nd = 3L, alpha.level = 0.01, x.se = NULL) {
|
|
| 1578 |
# unclass |
|
| 1579 | 3x |
y <- unclass(x) |
| 1580 | ||
| 1581 |
# round, and create a character matriy |
|
| 1582 | 3x |
y <- format(round(y, nd), width = 3L + nd, justify = "right") |
| 1583 | ||
| 1584 |
# right-align column names |
|
| 1585 | 3x |
colnames(y) <- format(colnames(y), width = 3L + nd, justify = "right") |
| 1586 | ||
| 1587 |
# add 'star' for significant loadings (if provided) using alpha = 0.01 |
|
| 1588 | 3x |
if (!is.null(x.se) && !any(is.na(x.se))) {
|
| 1589 | 3x |
colNAMES <- colnames(y) |
| 1590 | 3x |
rowNAMES <- rownames(y) |
| 1591 | 3x |
x.se[x.se < sqrt(.Machine$double.eps)] <- 1 # to avoid NA |
| 1592 | 3x |
zstat <- x / x.se |
| 1593 | 3x |
z.cutoff <- qnorm(1 - (alpha.level / 2)) |
| 1594 | 3x |
zstat.string <- ifelse(abs(zstat) > z.cutoff, "*", " ") |
| 1595 | 3x |
y <- matrix(paste(y, zstat.string, sep = ""), nrow(y), ncol(y)) |
| 1596 | 3x |
colnames(y) <- colNAMES |
| 1597 | 3x |
rownames(y) <- rowNAMES |
| 1598 |
} |
|
| 1599 | ||
| 1600 |
# remove upper part |
|
| 1601 | 3x |
ll <- upper.tri(x, diag = FALSE) |
| 1602 | 3x |
y[ll] <- "" |
| 1603 | ||
| 1604 |
|
|
| 1605 | 3x |
print(y, quote = FALSE) |
| 1606 |
} |
| 1 |
# miscellaneous functions related to graphs |
|
| 2 |
# often using an adjancency matrix as input |
|
| 3 |
# |
|
| 4 |
# collecting functions that were in lav_utils.R |
|
| 5 |
# YR 15 Oct 2025 |
|
| 6 | ||
| 7 |
# find index of 'ancestors' (predictors) for all nodes in a DAG |
|
| 8 |
# given an adjacency matrix B (rows are y's, columns are x's) |
|
| 9 |
# |
|
| 10 |
# this (speedy!) version is written by Luc De Wilde |
|
| 11 |
lav_graph_get_ancestors <- function(B = NULL) {
|
|
| 12 | ! |
B <- abs(B) |
| 13 | ! |
nr <- nrow(B) |
| 14 | ! |
out_env <- new.env(parent = emptyenv()) |
| 15 | ||
| 16 |
# container to hold ancestor indices per node |
|
| 17 | ! |
out.idx <- vector("list", length = nr)
|
| 18 | ||
| 19 | ! |
get_ancestors <- function(nr, callers) {
|
| 20 | ! |
if (any(callers == nr)) {
|
| 21 | ! |
lav_msg_warn(gettextf("Cycle detected for element nr %d !", nr))
|
| 22 | ! |
return(integer(0)) |
| 23 |
} |
|
| 24 | ! |
x <- get0(as.character(nr), envir = out_env, ifnotfound = NULL) |
| 25 | ! |
if (!is.null(x)) return(x) |
| 26 | ! |
retval <- integer(0L) |
| 27 | ! |
x.direct.idx <- which(B[nr, ] != 0) |
| 28 | ! |
for (j in seq_along(x.direct.idx)) {
|
| 29 | ! |
thisone <- x.direct.idx[j] |
| 30 | ! |
retval <- c(retval, thisone) |
| 31 | ! |
sub <- get_ancestors(thisone, c(callers, nr)) |
| 32 | ! |
if (all(sub != nr)) retval <- c(retval, sub) |
| 33 |
} |
|
| 34 | ! |
retval <- sort.int(unique(retval)) |
| 35 | ! |
assign(as.character(nr), retval, envir = out_env) |
| 36 | ! |
retval |
| 37 |
} |
|
| 38 | ||
| 39 |
# run over each node |
|
| 40 | ! |
for (i in seq_len(nr)) {
|
| 41 | ! |
out.idx[[i]] <- get_ancestors(i, integer(0)) |
| 42 |
} # all nodes |
|
| 43 | ! |
out.idx |
| 44 |
} |
|
| 45 | ||
| 46 | ||
| 47 |
# cluster rows/cols that are linked/connected |
|
| 48 |
# return list of connected nodes |
|
| 49 |
# we assume A is the square/symmetric (binary) adjacency matrix of an |
|
| 50 |
# undirected graph |
|
| 51 |
# |
|
| 52 |
# this version written by Luc De Wilde |
|
| 53 |
lav_graph_get_connected_nodes <- function(A) {
|
|
| 54 | ||
| 55 |
# make sure we have square symmetric matrix |
|
| 56 | ! |
A <- as.matrix(A) |
| 57 | ||
| 58 |
# A must be square |
|
| 59 | ! |
stopifnot(nrow(A) == ncol(A)) |
| 60 | ||
| 61 |
# A must be symmetric |
|
| 62 | ! |
stopifnot(isSymmetric(A)) |
| 63 | ||
| 64 |
# set diagonal to zero (just in case) |
|
| 65 | ! |
diag(A) <- 0L |
| 66 | ||
| 67 |
# make it logical |
|
| 68 | ! |
A <- (A != 0) |
| 69 | ||
| 70 |
# number of cols/rows |
|
| 71 | ! |
M <- ncol(A) |
| 72 | ||
| 73 |
# catch diagonal A |
|
| 74 | ! |
if (all(lavaan::lav_matrix_vech(A, diagonal = FALSE) == 0L)) {
|
| 75 | ! |
return(seq_len(M)) |
| 76 |
} |
|
| 77 | ||
| 78 | ! |
visited <- rep(FALSE, M) # track visited nodes |
| 79 | ! |
membership <- integer(M) # component id for each node |
| 80 | ! |
component.id <- 0L # current component id |
| 81 | ||
| 82 | ! |
put_node_in_component <- function(node, componentid) {
|
| 83 | ! |
visited[node] <<- TRUE |
| 84 | ! |
membership[node] <<- componentid |
| 85 | ! |
toadd <- which(A[, node]) |
| 86 | ! |
for (n in toadd) {
|
| 87 | ! |
if (!visited[n]) put_node_in_component(n, componentid) |
| 88 |
} |
|
| 89 |
} |
|
| 90 | ||
| 91 | ! |
for (node in seq_len(M)) {
|
| 92 | ! |
if (!visited[node]) {
|
| 93 | ! |
component.id <- component.id + 1L |
| 94 | ! |
put_node_in_component(node, component.id) |
| 95 |
} |
|
| 96 |
} |
|
| 97 | ||
| 98 | ! |
membership |
| 99 |
} |
|
| 100 | ||
| 101 |
# This routine tries to order the expressions such that all expressions that |
|
| 102 |
# use a certain variable come after the expression that defines this variable. |
|
| 103 |
# input adj.mat is an adjacency matrix |
|
| 104 |
# when there is a 1 in element (r, c) this means that the variable |
|
| 105 |
# defined in expression r is used in expression c. |
|
| 106 | ||
| 107 |
# contributed by ldw (adapted from function defined by Kss2k, github issue #445) |
|
| 108 |
lav_graph_order_adj_mat <- function(adj.mat, warn = TRUE) {
|
|
| 109 | 2x |
adjmat <- adj.mat |
| 110 | 2x |
n <- nrow(adjmat) |
| 111 | 2x |
k <- 0 |
| 112 | 2x |
testen <- 1:n |
| 113 | 2x |
while (TRUE) {
|
| 114 | 2x |
found <- FALSE |
| 115 | 2x |
tests <- testen # which expressions are tested in the next loop |
| 116 | 2x |
for (i in tests) {
|
| 117 | 2x |
if (all(adjmat[1:n, i] == 0)) { # var defined in expression i doesn't use
|
| 118 |
# vars not already defined, select as next |
|
| 119 | 2x |
k <- k + 1 # increment order counter |
| 120 | 2x |
adjmat[i, ] <- 0 # remove usage indicator of defined variable |
| 121 | 2x |
adjmat[i, i] <- k # keep order of expressions in diagonal element |
| 122 | 2x |
found <- TRUE |
| 123 | 2x |
testen <- testen[testen != i] # don't test this i in next loop |
| 124 |
} |
|
| 125 |
} |
|
| 126 | 2x |
if (k == n) return(order(diag(adjmat))) # all done |
| 127 | ! |
if (!found) { # no definable var found
|
| 128 | ! |
if (warn) {
|
| 129 | ! |
lav_msg_warn(gettext("unable to sort `:=` parameters;",
|
| 130 | ! |
"system of defined parameters contains a cycle")) |
| 131 |
} |
|
| 132 | ! |
return(seq_len(n)) # cycle detected; return original order |
| 133 |
} |
|
| 134 |
} |
|
| 135 |
} |
|
| 136 | ||
| 137 |
# This function performs the same task as lav_graph_order_adj_mat but |
|
| 138 |
# takes as input two vectors (character or integer) of the same length |
|
| 139 |
# defining the dependencies: |
|
| 140 |
# inputs are vectors defined and definedby of the same length, where |
|
| 141 |
# for each index j for these vectors |
|
| 142 |
# node definedby[j] is used in the definition of node defined[j]. |
|
| 143 |
# This routine tries to order all nodes such that all node definitions that |
|
| 144 |
# use a certain node come after the definition of that node. |
|
| 145 | ||
| 146 |
# contributed by ldw as alternative for lav_graph_order_adj_mat |
|
| 147 |
# this function is faster, requires less memory and handles also |
|
| 148 |
# character vectors |
|
| 149 |
lav_graph_topological_sort <- function(defined, definedby, warn = TRUE) {
|
|
| 150 | ! |
nodes <- unique(c(definedby, defined)) |
| 151 | ! |
n <- length(nodes) |
| 152 | ! |
rv <- vector(mode(definedby), n) |
| 153 | ! |
k <- 0L |
| 154 | ! |
testnodes <- rep(TRUE, n) |
| 155 | ! |
testedges <- rep(TRUE, length(defined)) |
| 156 | ! |
while (TRUE) {
|
| 157 | ! |
found <- FALSE |
| 158 | ! |
tests <- which(testnodes) |
| 159 | ! |
for (i in tests) {
|
| 160 | ! |
tocheck <- nodes[i] |
| 161 | ! |
if (all(tocheck != defined[testedges])) {
|
| 162 | ! |
k <- k + 1L |
| 163 | ! |
testnodes[i] <- FALSE |
| 164 | ! |
rv[k] <- tocheck |
| 165 | ! |
found <- TRUE |
| 166 | ! |
testedges[definedby == tocheck] <- FALSE |
| 167 |
} |
|
| 168 |
} |
|
| 169 | ! |
if (k == n) return(rv) # all done |
| 170 | ! |
if (!found) { # no definable node found
|
| 171 | ! |
if (warn) {
|
| 172 | ! |
lav_msg_warn(gettext("unable to sort;",
|
| 173 | ! |
"dependencies contain a cycle")) |
| 174 |
} |
|
| 175 | ! |
return(nodes) # cycle detected; return original order |
| 176 |
} |
|
| 177 |
} |
|
| 178 |
} |
|
| 179 | ||
| 180 |
# Topological grouping and placing of nodes in a matrix. |
|
| 181 |
# Nodes which need to be placed at a border are given in argument bordernodes. |
|
| 182 |
# This routine does a topological sort and returns a data.frame with the nodes, |
|
| 183 |
# their position in a matrix (rows, cols) and an indication of root |
|
| 184 |
# (no dependencies, indic == "r") or |
|
| 185 |
# leave (no other nodes depend on this one, indic == "l"), as follows : |
|
| 186 |
# the first column contains all nodes without dependencies (*1) (*2) |
|
| 187 |
# the second column contains nodes with only dependency |
|
| 188 |
# in the first column (*1)(*3) |
|
| 189 |
# the third column contains nodes with only dependencies in the first and |
|
| 190 |
# second, with at least one in the second column and so on (*3) |
|
| 191 |
# (*1) nodes with successors but no successors in the next column are promoted |
|
| 192 |
# to the column just before the least column of the successors, except |
|
| 193 |
# the nodes mentioned in bordernodes and in the first column. |
|
| 194 |
# (*2) the rows in the first column are chosen so that they are in the |
|
| 195 |
# neighborhood of the mean of the rows from the nodes depending on them.(*4) |
|
| 196 |
# (*3) the rows in the second to last column are chosen so that the sum of the |
|
| 197 |
# row-distances to connected nodes is minimized |
|
| 198 |
# (*4) if there are nodes forced to the top border in columns 2 through |
|
| 199 |
# maxcol-1, the items in column1s 1 and maxcol cannot occupy the first row; |
|
| 200 |
# analogue for the bottom |
|
| 201 |
lav_graph_topological_matrix <- function( |
|
| 202 |
defined, |
|
| 203 |
definedby, |
|
| 204 |
bordernodes = character(0), |
|
| 205 |
warn = TRUE) {
|
|
| 206 | ! |
rv <- lav_graph_topological_sort(defined, definedby, warn) |
| 207 | ! |
n <- length(rv) |
| 208 | ! |
rvrow <- integer(n) |
| 209 | ! |
rvcol <- integer(n) |
| 210 | ! |
rvindic <- character(n) |
| 211 |
# position nodes in matrix, column by column, and mark root and leave nodes |
|
| 212 |
# rows are assigned but not yet adapted |
|
| 213 | ! |
colmax <- 0L |
| 214 | ! |
bordersincol <- 0L |
| 215 | ! |
topborderfixed <- FALSE |
| 216 | ! |
bottomborderfixed <- FALSE |
| 217 | ! |
for (i in seq.int(n)) {
|
| 218 | ! |
predecessors <- definedby[rv[i] == defined] |
| 219 | ! |
followers <- defined[rv[i] == definedby] |
| 220 | ! |
if (length(predecessors) == 0L) {
|
| 221 | ! |
rvcol[i] <- 1L |
| 222 | ! |
colmax[1L] <- colmax[1L] + 1L |
| 223 | ! |
rvrow[i] <- colmax[1L] |
| 224 | ! |
rvindic[i] <- "r" # root |
| 225 |
} else {
|
|
| 226 | ! |
if (length(followers) == 0L) {
|
| 227 | ! |
rvindic[i] <- "l" |
| 228 |
} |
|
| 229 | ! |
predecessor.ind <- match(predecessors, rv) |
| 230 | ! |
rvcol[i] <- max(rvcol[predecessor.ind]) + 1L |
| 231 | ! |
if (length(colmax) < rvcol[i]) {
|
| 232 | ! |
colmax[rvcol[i]] <- 1L |
| 233 | ! |
bordersincol <- 0L |
| 234 |
} else {
|
|
| 235 | ! |
colmax[rvcol[i]] <- colmax[rvcol[i]] + 1L |
| 236 |
} |
|
| 237 | ! |
rvrow[i] <- colmax[rvcol[i]] |
| 238 | ! |
if (rv[i] %in% bordernodes && rvindic[i] != "l") {
|
| 239 | ! |
bordersincol <- bordersincol + 1L |
| 240 | ! |
topborderfixed <- TRUE |
| 241 | ! |
if (bordersincol == 2L) bottomborderfixed <- TRUE |
| 242 | ! |
if (bordersincol > 2L) {
|
| 243 | ! |
rvcol[i] <- rvcol[i] + 1L |
| 244 | ! |
colmax[rvcol[i]] <- 1L |
| 245 | ! |
rvrow[i] <- colmax[rvcol[i]] |
| 246 |
} |
|
| 247 |
} |
|
| 248 |
} |
|
| 249 |
} |
|
| 250 |
# increment columns ? (*) |
|
| 251 | ! |
incremented <- TRUE |
| 252 | ! |
while (incremented) {
|
| 253 | ! |
incremented <- FALSE |
| 254 | ! |
for (i in seq_along(rv)) {
|
| 255 | ! |
if (rvindic[i] != "l" && !(rv[i] %in% bordernodes && rvindic[i] == "r")) {
|
| 256 | ! |
followers <- defined[rv[i] == definedby] |
| 257 | ! |
followers.ind <- match(followers, rv) |
| 258 | ! |
mincol <- min(rvcol[followers.ind]) |
| 259 | ! |
if (rvcol[i] < mincol - 1L) {
|
| 260 | ! |
incremented <- TRUE |
| 261 | ! |
curcol <- rvcol[i] |
| 262 | ! |
rvcol[i] <- mincol - 1L |
| 263 |
# adapt rows in curcol |
|
| 264 | ! |
rvrow[rvcol == curcol & rvrow > rvrow[i]] <- |
| 265 | ! |
rvrow[rvcol == curcol & rvrow > rvrow[i]] - 1L |
| 266 | ! |
colmax[curcol] <- colmax[curcol] - 1L |
| 267 |
# adapt rows in newcol |
|
| 268 | ! |
colmax[mincol - 1L] <- colmax[mincol - 1L] + 1L |
| 269 | ! |
rvrow[i] <- colmax[mincol - 1L] |
| 270 |
} |
|
| 271 |
} |
|
| 272 |
} |
|
| 273 |
} |
|
| 274 |
# place bordernodes in columns 2 through maxcol-1 in the first or last row |
|
| 275 | ! |
for (col in seq.int(2L, length(colmax) - 1L)) {
|
| 276 | ! |
bordernodes.incol <- which(rvcol == col & rv %in% bordernodes) |
| 277 | ! |
if (length(bordernodes.incol) > 0L) {
|
| 278 | ! |
totop <- bordernodes.incol[1L] |
| 279 | ! |
if (rvrow[totop] != 1L) {
|
| 280 | ! |
swappie <- which(rvcol == col & rvrow == 1L) |
| 281 | ! |
rvrow[swappie] <- rvrow[totop] |
| 282 | ! |
rvrow[totop] <- 1L |
| 283 |
} |
|
| 284 |
} |
|
| 285 | ! |
if (length(bordernodes.incol) > 1L) {
|
| 286 | ! |
tobottom <- bordernodes.incol[2L] |
| 287 | ! |
if (rvrow[tobottom] != colmax[col]) {
|
| 288 | ! |
swappie <- which(rvcol == col & rvrow == colmax[col]) |
| 289 | ! |
rvrow[swappie] <- rvrow[tobottom] |
| 290 | ! |
rvrow[tobottom] <- max(colmax) |
| 291 |
} |
|
| 292 |
} |
|
| 293 |
} |
|
| 294 |
# help function to order doubles as integers in a specified range |
|
| 295 | ! |
order_doubles_interval <- function(inorder, outrange) {
|
| 296 | ! |
stopifnot(length(inorder) < outrange[2] - outrange[1] + 2) |
| 297 | ! |
if (length(inorder) == 1) {
|
| 298 | ! |
if (inorder >= outrange[1L] && inorder <= outrange[2L]) {
|
| 299 | ! |
return(as.integer(inorder)) |
| 300 |
} |
|
| 301 | ! |
return(as.integer(sum(outrange) / 2)) |
| 302 |
} |
|
| 303 | ! |
in.order <- order(inorder) |
| 304 | ! |
in.order[in.order] <- seq_along(inorder) |
| 305 | ! |
if (length(inorder) == outrange[2] - outrange[1] + 1) {
|
| 306 | ! |
return(as.integer(outrange[1]) + in.order - 1L) |
| 307 |
} |
|
| 308 | ! |
as.integer(outrange[1] + (in.order - 1L) * |
| 309 | ! |
(outrange[2] - outrange[1] + 0.99) / (length(in.order) - 1L)) |
| 310 |
} |
|
| 311 |
# arrange nodes in first column (***) |
|
| 312 | ! |
rowmax <- max(colmax) |
| 313 | ! |
addrows <- 0L |
| 314 | ! |
if (topborderfixed) addrows <- 1L |
| 315 | ! |
if (bottomborderfixed) addrows <- 2L |
| 316 | ! |
rowmax <- max(colmax, colmax[1L] + addrows, colmax[length(colmax)] + addrows) |
| 317 | ! |
nodescol1 <- which(rvcol == 1L) |
| 318 | ! |
optimalrows <- sapply(nodescol1, function(ci) {
|
| 319 | ! |
nextnodes.ind <- which(rv[ci] == definedby) |
| 320 | ! |
if (length(nextnodes.ind) == 0L) {
|
| 321 | ! |
colmax[1L] / 2 |
| 322 |
} else {
|
|
| 323 | ! |
nextnodes <- defined[nextnodes.ind] |
| 324 | ! |
mean(rvrow[match(nextnodes, rv)]) |
| 325 |
} |
|
| 326 |
}) |
|
| 327 | ! |
interval1l <- c( |
| 328 | ! |
if (topborderfixed) 2L else 1L, |
| 329 | ! |
if (bottomborderfixed) rowmax - 1L else rowmax |
| 330 |
) |
|
| 331 | ! |
rvrow[nodescol1] <- order_doubles_interval(optimalrows, interval1l) |
| 332 | ||
| 333 |
# adapt rows in columns to match as close as possible the rows of the |
|
| 334 |
# connected nodes in prior column(s), except for |
|
| 335 |
# borders for all but the last column: (**) |
|
| 336 | ! |
if (length(colmax) > 1L) {
|
| 337 | ! |
for (c in seq.int(2L, length(colmax))) {
|
| 338 | ! |
if (c == length(colmax)) {
|
| 339 | ! |
cnodes.ind <- which(rvcol == c) |
| 340 | ! |
interval <- interval1l |
| 341 |
} else {
|
|
| 342 | ! |
cnodes.ind <- which(rvcol == c & !(rv %in% bordernodes)) |
| 343 | ! |
if (length(cnodes.ind) == 0L) next |
| 344 | ! |
interval <- range(rvrow[cnodes.ind]) |
| 345 | ! |
interval[2L] <- max(interval[2L], colmax - 1L) |
| 346 |
} |
|
| 347 | ! |
optimalrows <- sapply(cnodes.ind, function(ci) {
|
| 348 | ! |
prevnodes.ind <- which(rv[ci] == defined) |
| 349 | ! |
if (length(prevnodes.ind) == 0L) {
|
| 350 | ! |
rvrow[ci] |
| 351 |
} else {
|
|
| 352 | ! |
prevnodes <- definedby[prevnodes.ind] |
| 353 | ! |
mean(rvrow[match(prevnodes, rv)]) |
| 354 |
} |
|
| 355 |
}) |
|
| 356 | ! |
rvrow[cnodes.ind] <- order_doubles_interval(optimalrows, interval) |
| 357 |
} |
|
| 358 |
} |
|
| 359 |
# order on column, then row, and return |
|
| 360 | ! |
neworder <- order(rvcol * 1000L + rvrow) |
| 361 | ! |
stopifnot(length(neworder) == length(unique(neworder))) |
| 362 | ! |
data.frame( |
| 363 | ! |
nodes = rv[neworder], |
| 364 | ! |
rows = rvrow[neworder], |
| 365 | ! |
cols = rvcol[neworder], |
| 366 | ! |
indic = rvindic[neworder] |
| 367 |
) |
|
| 368 |
} |
| 1 |
# rotation algorithms |
|
| 2 |
# |
|
| 3 |
# YR 3 April 2019 -- gradient projection algorithm |
|
| 4 |
# YR 21 April 2019 -- pairwise rotation algorithm |
|
| 5 |
# YR 11 May 2020 -- order.idx is done in rotation matrix |
|
| 6 |
# (suggested by Florian Scharf) |
|
| 7 |
# YR 02 June 2024 -- add group argument, so target and target.mask can |
|
| 8 |
# be a list |
|
| 9 | ||
| 10 |
# main function to rotate a single matrix 'A' |
|
| 11 |
lav_matrix_rotate <- function(A = NULL, # original matrix |
|
| 12 |
orthogonal = FALSE, # default is oblique |
|
| 13 |
method = "geomin", # default rot method |
|
| 14 |
method.args = list( |
|
| 15 |
geomin.epsilon = 0.01, |
|
| 16 |
orthomax.gamma = 1, |
|
| 17 |
cf.gamma = 0, |
|
| 18 |
oblimin.gamma = 0, |
|
| 19 |
promax.kappa = 4, |
|
| 20 |
target = matrix(0, 0, 0), |
|
| 21 |
target.mask = matrix(0, 0, 0) |
|
| 22 |
), |
|
| 23 |
init.ROT = NULL, # initial rotation matrix |
|
| 24 |
init.ROT.check = TRUE, # check if init ROT is ok |
|
| 25 |
rstarts = 100L, # number of random starts |
|
| 26 |
row.weights = "default", # row weighting |
|
| 27 |
std.ov = FALSE, # rescale ov |
|
| 28 |
ov.var = NULL, # ov variances |
|
| 29 |
algorithm = "gpa", # rotation algorithm |
|
| 30 |
reflect = TRUE, # refect sign |
|
| 31 |
order.lv.by = "index", # how to order the lv's |
|
| 32 |
gpa.tol = 0.00001, # stopping tol gpa |
|
| 33 |
tol = 1e-07, # stopping tol others |
|
| 34 |
keep.rep = FALSE, # store replications |
|
| 35 |
max.iter = 10000L, # max gpa iterations |
|
| 36 |
group = 1L) { # group number
|
|
| 37 | ||
| 38 |
# check A |
|
| 39 | 3x |
if (!inherits(A, "matrix")) {
|
| 40 | ! |
lav_msg_stop(gettext("A does not seem to be a matrix"))
|
| 41 |
} |
|
| 42 | ||
| 43 | 3x |
P <- nrow(A) |
| 44 | 3x |
M <- ncol(A) |
| 45 | 3x |
if (M < 2L) { # single dimension
|
| 46 | ! |
res <- list( |
| 47 | ! |
LAMBDA = A, PHI = matrix(1, 1, 1), ROT = matrix(1, 1, 1), |
| 48 | ! |
orthogonal = orthogonal, method = "none", |
| 49 | ! |
method.args = list(), row.weights = "none", |
| 50 | ! |
algorithm = "none", iter = 0L, converged = TRUE, |
| 51 | ! |
method.value = 0 |
| 52 |
) |
|
| 53 | ! |
return(res) |
| 54 |
} |
|
| 55 | ||
| 56 |
# method |
|
| 57 | 3x |
method <- tolower(method) |
| 58 | ||
| 59 |
# if promax, skip everything, then call promax() later |
|
| 60 | 3x |
if (method == "promax") {
|
| 61 |
# orig.algorithm <- algorithm |
|
| 62 |
# orig.rstarts <- rstarts |
|
| 63 | ||
| 64 | ! |
algorithm <- "none" |
| 65 | ! |
rstarts <- 0L |
| 66 | ! |
init.ROT <- NULL |
| 67 | ! |
ROT <- diag(M) |
| 68 |
} |
|
| 69 | ||
| 70 |
# check init.ROT |
|
| 71 | 3x |
if (!is.null(init.ROT) && init.ROT.check) {
|
| 72 | ! |
if (!inherits(init.ROT, "matrix")) {
|
| 73 | ! |
lav_msg_stop(gettext("init.ROT does not seem to a matrix"))
|
| 74 |
} |
|
| 75 | ! |
if (nrow(init.ROT) != M) {
|
| 76 | ! |
lav_msg_stop(gettextf( |
| 77 | ! |
"nrow(init.ROT) = %1$s does not equal ncol(A) = %2$s", |
| 78 | ! |
nrow(init.ROT), M)) |
| 79 |
} |
|
| 80 | ! |
if (nrow(init.ROT) != ncol(init.ROT)) {
|
| 81 | ! |
lav_msg_stop(gettextf( |
| 82 | ! |
"nrow(init.ROT) = %1$s does not equal ncol(init.ROT) = %2$s", |
| 83 | ! |
nrow(init.ROT), ncol(init.ROT))) |
| 84 |
} |
|
| 85 |
# rotation matrix? |
|
| 86 | ! |
if (!lav_matrix_rotate_check(init.ROT, orthogonal = orthogonal)) {
|
| 87 | ! |
lav_msg_stop(gettext("init.ROT does not look like a rotation matrix"))
|
| 88 |
} |
|
| 89 |
} |
|
| 90 | ||
| 91 |
# determine method function name |
|
| 92 | 3x |
if (method %in% c( |
| 93 | 3x |
"cf-quartimax", "cf-varimax", "cf-equamax", |
| 94 | 3x |
"cf-parsimax", "cf-facparsim" |
| 95 |
)) {
|
|
| 96 | ! |
method.fname <- "lav_matrix_rotate_cf" |
| 97 | ! |
method.args$cf.gamma <- switch(method, |
| 98 | ! |
"cf-quartimax" = 0, |
| 99 | ! |
"cf-varimax" = 1 / P, |
| 100 | ! |
"cf-equamax" = M / (2 * P), |
| 101 | ! |
"cf-parsimax" = (M - 1) / (P + M - 2), |
| 102 | ! |
"cf-facparsim" = 1 |
| 103 |
) |
|
| 104 | 3x |
} else if (method %in% c("bi-quartimin", "biquartimin")) {
|
| 105 | ! |
method.fname <- "lav_matrix_rotate_biquartimin" |
| 106 | 3x |
} else if (method %in% c("bi-geomin", "bigeomin")) {
|
| 107 | ! |
method.fname <- "lav_matrix_rotate_bigeomin" |
| 108 | 3x |
} else if (method == "target.strict") {
|
| 109 | ! |
method.fname <- "lav_matrix_rotate_target" |
| 110 |
} else {
|
|
| 111 | 3x |
method.fname <- paste("lav_matrix_rotate_", method, sep = "")
|
| 112 |
} |
|
| 113 | ||
| 114 |
# check if rotation method exists |
|
| 115 | 3x |
check <- try(get(method.fname), silent = TRUE) |
| 116 | 3x |
if (inherits(check, "try-error")) {
|
| 117 | ! |
lav_msg_stop(gettext("unknown rotation method:"), method.fname)
|
| 118 |
} |
|
| 119 | ||
| 120 |
# if target, check target matrix |
|
| 121 | 3x |
if (method == "target.strict" || method == "pst") {
|
| 122 | ! |
target <- method.args$target |
| 123 | ! |
if (is.list(target)) {
|
| 124 | ! |
method.args$target <- target <- target[[group]] |
| 125 |
} |
|
| 126 |
# check dimension of target/A |
|
| 127 | ! |
if (nrow(target) != nrow(A)) {
|
| 128 | ! |
lav_msg_stop(gettext("nrow(target) != nrow(A)"))
|
| 129 |
} |
|
| 130 | ! |
if (ncol(target) != ncol(A)) {
|
| 131 | ! |
lav_msg_stop(gettext("ncol(target) != ncol(A)"))
|
| 132 |
} |
|
| 133 |
} |
|
| 134 | 3x |
if (method == "pst") {
|
| 135 | ! |
target.mask <- method.args$target.mask |
| 136 | ! |
if (is.list(target.mask)) {
|
| 137 | ! |
method.args$target.mask <- target.mask <- target.mask[[group]] |
| 138 |
} |
|
| 139 |
# check dimension of target.mask/A |
|
| 140 | ! |
if (nrow(target.mask) != nrow(A)) {
|
| 141 | ! |
lav_msg_stop(gettext("nrow(target.mask) != nrow(A)"))
|
| 142 |
} |
|
| 143 | ! |
if (ncol(target.mask) != ncol(A)) {
|
| 144 | ! |
lav_msg_stop(gettext("col(target.mask) != ncol(A)"))
|
| 145 |
} |
|
| 146 |
} |
|
| 147 |
# we keep this here, so lav_matrix_rotate() can be used independently |
|
| 148 | 3x |
if (method == "target.strict" && anyNA(target)) {
|
| 149 | ! |
method <- "pst" |
| 150 | ! |
method.fname <- "lav_matrix_rotate_pst" |
| 151 | ! |
target.mask <- matrix(1, nrow = nrow(target), ncol = ncol(target)) |
| 152 | ! |
target.mask[is.na(target)] <- 0 |
| 153 | ! |
method.args$target.mask <- target.mask |
| 154 |
} |
|
| 155 | ||
| 156 |
# set orthogonal option |
|
| 157 | 3x |
if (missing(orthogonal)) {
|
| 158 |
# the default is oblique, except for varimax, entropy and a few others |
|
| 159 | ! |
if (method %in% c( |
| 160 | ! |
"varimax", "entropy", "mccammon", |
| 161 | ! |
"tandem1", "tandem2" |
| 162 |
)) {
|
|
| 163 | ! |
orthogonal <- TRUE |
| 164 |
} else {
|
|
| 165 | ! |
orthogonal <- FALSE |
| 166 |
} |
|
| 167 |
} else {
|
|
| 168 | 3x |
if (!orthogonal && method %in% c( |
| 169 | 3x |
"varimax", "entropy", "mccammon", |
| 170 | 3x |
"tandem1", "tandem2" |
| 171 |
)) {
|
|
| 172 | ! |
lav_msg_warn(gettextf( |
| 173 | ! |
"rotation method %s may not work with oblique rotation.", |
| 174 | ! |
dQuote(method) |
| 175 |
)) |
|
| 176 |
} |
|
| 177 |
} |
|
| 178 | ||
| 179 |
# set row.weights |
|
| 180 | 3x |
row.weights <- tolower(row.weights) |
| 181 | 3x |
if (row.weights == "default") {
|
| 182 |
# the default is "none", except for varimax |
|
| 183 | ! |
if (method %in% c("varimax", "promax")) {
|
| 184 | ! |
row.weights <- "kaiser" |
| 185 |
} else {
|
|
| 186 | ! |
row.weights <- "none" |
| 187 |
} |
|
| 188 |
} |
|
| 189 | ||
| 190 |
# check algorithm |
|
| 191 | 3x |
algorithm <- tolower(algorithm) |
| 192 | 3x |
if (algorithm %in% c("gpa", "pairwise", "none")) {
|
| 193 |
# nothing to do |
|
| 194 |
} else {
|
|
| 195 | ! |
lav_msg_stop(gettext("algorithm must be gpa or pairwise"))
|
| 196 |
} |
|
| 197 | ||
| 198 | ||
| 199 | ||
| 200 |
# 1. compute row weigths |
|
| 201 | ||
| 202 |
# 1.a cov -> cor? |
|
| 203 | 3x |
if (std.ov) {
|
| 204 | 3x |
A <- A * 1 / sqrt(ov.var) |
| 205 |
} |
|
| 206 | ||
| 207 | 3x |
if (row.weights == "none") {
|
| 208 | 3x |
weights <- rep(1.0, P) |
| 209 | ! |
} else if (row.weights == "kaiser") {
|
| 210 | ! |
weights <- lav_matrix_rotate_kaiser_weights(A) |
| 211 | ! |
} else if (row.weights == "cureton-mulaik") {
|
| 212 | ! |
weights <- lav_matrix_rotate_cm_weights(A) |
| 213 |
} else {
|
|
| 214 | ! |
lav_msg_stop(gettext("row.weights can be none, kaiser or cureton-mulaik"))
|
| 215 |
} |
|
| 216 | 3x |
A <- A * weights |
| 217 | ||
| 218 | ||
| 219 |
# 2. rotate |
|
| 220 | ||
| 221 |
# multiple random starts? |
|
| 222 | 3x |
if (rstarts > 0L) {
|
| 223 | 3x |
REP <- sapply(seq_len(rstarts), function(rep) {
|
| 224 |
# random start (always orthogonal) |
|
| 225 | 90x |
init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE) |
| 226 |
# init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = orthogonal) |
|
| 227 | ||
| 228 | 90x |
if (lav_verbose()) {
|
| 229 | ! |
cat("\n")
|
| 230 | ! |
cat("rstart = ", sprintf("%4d", rep), " start:\n")
|
| 231 |
} |
|
| 232 | ||
| 233 | ||
| 234 |
# choose rotation algorithm |
|
| 235 | 90x |
if (algorithm == "gpa") {
|
| 236 | 90x |
ROT <- lav_matrix_rotate_gpa( |
| 237 | 90x |
A = A, orthogonal = orthogonal, |
| 238 | 90x |
init.ROT = init.ROT, |
| 239 | 90x |
method.fname = method.fname, |
| 240 | 90x |
method.args = method.args, |
| 241 | 90x |
gpa.tol = gpa.tol, |
| 242 | 90x |
max.iter = max.iter |
| 243 |
) |
|
| 244 | 90x |
info <- attr(ROT, "info") |
| 245 | 90x |
attr(ROT, "info") <- NULL |
| 246 | 90x |
res <- c(info$method.value, lav_matrix_vec(ROT)) |
| 247 | ! |
} else if (algorithm == "pairwise") {
|
| 248 | ! |
ROT <- lav_matrix_rotate_pairwise( |
| 249 | ! |
A = A, |
| 250 | ! |
orthogonal = orthogonal, |
| 251 | ! |
init.ROT = init.ROT, |
| 252 | ! |
method.fname = method.fname, |
| 253 | ! |
method.args = method.args, |
| 254 | ! |
tol = tol, |
| 255 | ! |
max.iter = max.iter |
| 256 |
) |
|
| 257 | ! |
info <- attr(ROT, "info") |
| 258 | ! |
attr(ROT, "info") <- NULL |
| 259 | ! |
res <- c(info$method.value, lav_matrix_vec(ROT)) |
| 260 |
} |
|
| 261 | ||
| 262 | 90x |
if (lav_verbose()) {
|
| 263 | ! |
cat( |
| 264 | ! |
"rstart = ", sprintf("%4d", rep),
|
| 265 | ! |
" end; current crit = ", sprintf("%17.15f", res[1]), "\n"
|
| 266 |
) |
|
| 267 |
} |
|
| 268 | 90x |
res |
| 269 |
}) |
|
| 270 | 3x |
best.idx <- which.min(REP[1, ]) |
| 271 | 3x |
ROT <- matrix(REP[-1, best.idx], nrow = M, ncol = M) |
| 272 | 3x |
if (keep.rep) {
|
| 273 | ! |
info <- list(method.value = REP[1, best.idx], REP = REP) |
| 274 |
} else {
|
|
| 275 | 3x |
info <- list(method.value = REP[1, best.idx]) |
| 276 |
} |
|
| 277 | ! |
} else if (algorithm != "none") {
|
| 278 |
# initial rotation matrix |
|
| 279 | ! |
if (is.null(init.ROT)) {
|
| 280 | ! |
init.ROT <- diag(M) |
| 281 |
} |
|
| 282 | ||
| 283 |
# Gradient Projection Algorithm |
|
| 284 | ! |
if (algorithm == "gpa") {
|
| 285 | ! |
ROT <- lav_matrix_rotate_gpa( |
| 286 | ! |
A = A, orthogonal = orthogonal, |
| 287 | ! |
init.ROT = init.ROT, |
| 288 | ! |
method.fname = method.fname, |
| 289 | ! |
method.args = method.args, |
| 290 | ! |
gpa.tol = gpa.tol, |
| 291 | ! |
max.iter = max.iter |
| 292 |
) |
|
| 293 | ! |
} else if (algorithm == "pairwise") {
|
| 294 | ! |
ROT <- lav_matrix_rotate_pairwise( |
| 295 | ! |
A = A, |
| 296 | ! |
orthogonal = orthogonal, |
| 297 | ! |
init.ROT = init.ROT, |
| 298 | ! |
method.fname = method.fname, |
| 299 | ! |
method.args = method.args, |
| 300 | ! |
tol = tol, |
| 301 | ! |
max.iter = max.iter |
| 302 |
) |
|
| 303 |
} |
|
| 304 | ! |
info <- attr(ROT, "info") |
| 305 | ! |
attr(ROT, "info") <- NULL |
| 306 |
} |
|
| 307 | ||
| 308 |
# final rotation |
|
| 309 | 3x |
if (orthogonal) {
|
| 310 |
# LAMBDA <- A %*% solve(t(ROT)) |
|
| 311 |
# note: when ROT is orthogonal, solve(t(ROT)) == ROT |
|
| 312 | ! |
LAMBDA <- A %*% ROT |
| 313 | ! |
PHI <- diag(ncol(LAMBDA)) # correlation matrix == I |
| 314 |
} else {
|
|
| 315 |
# LAMBDA <- A %*% solve(t(ROT)) |
|
| 316 | 3x |
LAMBDA <- t(solve(ROT, t(A))) |
| 317 | 3x |
PHI <- crossprod(ROT) # correlation matrix |
| 318 |
} |
|
| 319 | ||
| 320 |
# 3. undo row weighting |
|
| 321 | 3x |
LAMBDA <- LAMBDA / weights |
| 322 | ||
| 323 |
# here, after re-weighted, we run promax if needed |
|
| 324 | 3x |
if (method == "promax") {
|
| 325 | ! |
LAMBDA.orig <- LAMBDA |
| 326 | ||
| 327 |
# first, run 'classic' varimax using varimax() from the stats package |
|
| 328 |
# we split varimax from promax, so we can control the normalize flag |
|
| 329 | ! |
normalize.flag <- row.weights == "kaiser" |
| 330 | ! |
xx <- stats::varimax(x = LAMBDA, normalize = normalize.flag) |
| 331 | ||
| 332 |
# promax |
|
| 333 | ! |
kappa <- method.args$promax.kappa |
| 334 | ! |
out <- lav_matrix_rotate_promax( |
| 335 | ! |
x = xx$loadings, m = kappa, |
| 336 | ! |
varimax.ROT = xx$rotmat |
| 337 |
) |
|
| 338 | ! |
LAMBDA <- out$loadings |
| 339 | ! |
PHI <- solve(crossprod(out$rotmat)) |
| 340 | ||
| 341 |
# compute 'ROT' to be compatible with GPa |
|
| 342 | ! |
ROTt.inv <- solve( |
| 343 | ! |
crossprod(LAMBDA.orig), |
| 344 | ! |
crossprod(LAMBDA.orig, LAMBDA) |
| 345 |
) |
|
| 346 | ! |
ROT <- solve(t(ROTt.inv)) |
| 347 | ||
| 348 | ! |
info <- list( |
| 349 | ! |
algorithm = "promax", iter = 0L, converged = TRUE, |
| 350 | ! |
method.value = as.numeric(NA) |
| 351 |
) |
|
| 352 |
} |
|
| 353 | ||
| 354 |
# 3.b undo cov -> cor |
|
| 355 | 3x |
if (std.ov) {
|
| 356 | 3x |
LAMBDA <- LAMBDA * sqrt(ov.var) |
| 357 |
} |
|
| 358 | ||
| 359 |
# 4.a reflect so that column sum is always positive |
|
| 360 | 3x |
if (reflect) {
|
| 361 | 3x |
SUM <- colSums(LAMBDA) |
| 362 | 3x |
neg.idx <- which(SUM < 0) |
| 363 | 3x |
if (length(neg.idx) > 0L) {
|
| 364 | 3x |
LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE] |
| 365 | 3x |
ROT[, neg.idx] <- -1 * ROT[, neg.idx, drop = FALSE] |
| 366 | 3x |
if (!orthogonal) {
|
| 367 |
# recompute PHI |
|
| 368 | 3x |
PHI <- crossprod(ROT) |
| 369 |
} |
|
| 370 |
} |
|
| 371 |
} |
|
| 372 | ||
| 373 |
# 4.b reorder the columns |
|
| 374 | 3x |
if (order.lv.by == "sumofsquares") {
|
| 375 | ! |
L2 <- LAMBDA * LAMBDA |
| 376 | ! |
order.idx <- base::order(colSums(L2), decreasing = TRUE) |
| 377 | 3x |
} else if (order.lv.by == "index") {
|
| 378 |
# reorder using Asparouhov & Muthen 2009 criterion (see Appendix D) |
|
| 379 | 3x |
max.loading <- apply(abs(LAMBDA), 2, max) |
| 380 |
# 1: per factor, number of the loadings that are at least 0.8 of the |
|
| 381 |
# highest loading of the factor |
|
| 382 |
# 2: mean of the index numbers |
|
| 383 | 3x |
average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
|
| 384 | 9x |
mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i])) |
| 385 |
}) |
|
| 386 |
# order of the factors |
|
| 387 | 3x |
order.idx <- base::order(average.index) |
| 388 | ! |
} else if (order.lv.by == "none") {
|
| 389 | ! |
order.idx <- seq_len(ncol(LAMBDA)) |
| 390 |
} else {
|
|
| 391 | ! |
lav_msg_stop(gettext("order must be index, sumofsquares or none"))
|
| 392 |
} |
|
| 393 | ||
| 394 |
# do the same in PHI |
|
| 395 | 3x |
LAMBDA <- LAMBDA[, order.idx, drop = FALSE] |
| 396 | 3x |
PHI <- PHI[order.idx, order.idx, drop = FALSE] |
| 397 | ||
| 398 |
# new in 0.6-6, also do this in ROT, so we won't have to do this |
|
| 399 |
# again upstream |
|
| 400 | 3x |
ROT <- ROT[, order.idx, drop = FALSE] |
| 401 | ||
| 402 |
# 6. return results as a list |
|
| 403 | 3x |
res <- list( |
| 404 | 3x |
LAMBDA = LAMBDA, PHI = PHI, ROT = ROT, order.idx = order.idx, |
| 405 | 3x |
orthogonal = orthogonal, method = method, |
| 406 | 3x |
method.args = method.args, row.weights = row.weights |
| 407 |
) |
|
| 408 | ||
| 409 |
# add method info |
|
| 410 | 3x |
res <- c(res, info) |
| 411 | ||
| 412 | 3x |
res |
| 413 |
} |
|
| 414 | ||
| 415 | ||
| 416 |
# Gradient Projection Algorithm (Jennrich 2001, 2002) |
|
| 417 |
# |
|
| 418 |
# - this is a translation of the SAS PROC IML code presented in the Appendix |
|
| 419 |
# of Bernaards & Jennrich (2005) |
|
| 420 |
# - as the orthogonal and oblique algorithm are so similar, they are |
|
| 421 |
# combined in a single function |
|
| 422 |
# - the default is oblique rotation |
|
| 423 |
# |
|
| 424 |
lav_matrix_rotate_gpa <- function(A = NULL, # original matrix |
|
| 425 |
orthogonal = FALSE, # default is oblique |
|
| 426 |
init.ROT = NULL, # initial rotation |
|
| 427 |
method.fname = NULL, # criterion function |
|
| 428 |
method.args = list(), # optional method args |
|
| 429 |
gpa.tol = 0.00001, |
|
| 430 |
max.iter = 10000L) {
|
|
| 431 |
# number of columns |
|
| 432 | 90x |
M <- ncol(A) |
| 433 | ||
| 434 |
# transpose of A (not needed for orthogonal) |
|
| 435 | 90x |
At <- t(A) |
| 436 | ||
| 437 |
# check init.ROT |
|
| 438 | 90x |
if (is.null(init.ROT)) {
|
| 439 | ! |
ROT <- diag(M) |
| 440 |
} else {
|
|
| 441 | 90x |
ROT <- init.ROT |
| 442 |
} |
|
| 443 | ||
| 444 |
# set initial value of alpha to 1 |
|
| 445 | 90x |
alpha <- 1 |
| 446 | ||
| 447 |
# initial rotation |
|
| 448 | 90x |
if (orthogonal) {
|
| 449 | ! |
LAMBDA <- A %*% ROT |
| 450 |
} else {
|
|
| 451 | 90x |
LAMBDA <- t(solve(ROT, At)) |
| 452 |
} |
|
| 453 | ||
| 454 |
# using the current LAMBDA, evaluate the user-specified |
|
| 455 |
# rotation criteron; return Q (the criterion) and its gradient Gq |
|
| 456 | 90x |
Q <- do.call( |
| 457 | 90x |
method.fname, |
| 458 | 90x |
c(list(LAMBDA = LAMBDA), method.args, list(grad = TRUE)) |
| 459 |
) |
|
| 460 | 90x |
Gq <- attr(Q, "grad") |
| 461 | 90x |
attr(Q, "grad") <- NULL |
| 462 | 90x |
Q.current <- Q |
| 463 | ||
| 464 |
# compute gradient GRAD of f() at ROT from the gradient Gq of Q at LAMBDA |
|
| 465 |
# in a manner appropiate for orthogonal or oblique rotation |
|
| 466 | 90x |
if (orthogonal) {
|
| 467 | ! |
GRAD <- crossprod(A, Gq) |
| 468 |
} else {
|
|
| 469 | 90x |
GRAD <- -1 * solve(t(init.ROT), crossprod(Gq, LAMBDA)) |
| 470 |
} |
|
| 471 | ||
| 472 |
# start iterations |
|
| 473 | 90x |
converged <- FALSE |
| 474 | 90x |
for (iter in seq_len(max.iter + 1L)) {
|
| 475 |
# compute projection Gp of GRAD onto the linear manifold tangent at |
|
| 476 |
# ROT to the manifold of orthogonal or normal (for oblique) matrices |
|
| 477 |
# |
|
| 478 |
# this projection is zero if and only if ROT is a stationary point of |
|
| 479 |
# f() restricted to the orthogonal/normal matrices |
|
| 480 | 5426x |
if (orthogonal) {
|
| 481 | ! |
MM <- crossprod(ROT, GRAD) |
| 482 | ! |
SYMM <- (MM + t(MM)) / 2 |
| 483 | ! |
Gp <- GRAD - (ROT %*% SYMM) |
| 484 |
} else {
|
|
| 485 | 5426x |
Gp <- GRAD - t(t(ROT) * colSums(ROT * GRAD)) |
| 486 |
} |
|
| 487 | ||
| 488 |
# check Frobenius norm of Gp |
|
| 489 | 5426x |
frob <- sqrt(sum(Gp * Gp)) |
| 490 | ||
| 491 |
# if verbose, print |
|
| 492 | 5426x |
if (lav_verbose()) {
|
| 493 | ! |
cat( |
| 494 | ! |
" iter = ", sprintf("%4d", iter - 1),
|
| 495 | ! |
" Q = ", sprintf("%9.7f", Q.current),
|
| 496 | ! |
" frob.log10 = ", sprintf("%10.7f", log10(frob)),
|
| 497 | ! |
" alpha = ", sprintf("%9.7f", alpha), "\n"
|
| 498 |
) |
|
| 499 |
} |
|
| 500 | ||
| 501 | 5426x |
if (frob < gpa.tol) {
|
| 502 | 90x |
converged <- TRUE |
| 503 | 90x |
break |
| 504 |
} |
|
| 505 | ||
| 506 |
# update |
|
| 507 | 5336x |
alpha <- 2 * alpha |
| 508 | 5336x |
for (i in seq_len(1000)) { # make option?
|
| 509 | ||
| 510 |
# step in the negative projected gradient direction |
|
| 511 |
# (note, the original algorithm in Jennrich 2001 used G, not Gp) |
|
| 512 | 10947x |
X <- ROT - alpha * Gp |
| 513 | ||
| 514 | 10947x |
if (orthogonal) {
|
| 515 |
# use SVD to compute the projection ROTt of X onto the manifold |
|
| 516 |
# of orthogonal matrices |
|
| 517 | ! |
svd.out <- svd(X) |
| 518 | ! |
U <- svd.out$u |
| 519 | ! |
V <- svd.out$v |
| 520 | ! |
ROTt <- U %*% t(V) |
| 521 |
} else {
|
|
| 522 |
# compute the projection ROTt of X onto the manifold |
|
| 523 |
# of normal matrices |
|
| 524 | 10947x |
v <- 1 / sqrt(apply(X^2, 2, sum)) |
| 525 | 10947x |
ROTt <- X %*% diag(v) |
| 526 |
} |
|
| 527 | ||
| 528 |
# rotate again |
|
| 529 | 10947x |
if (orthogonal) {
|
| 530 | ! |
LAMBDA <- A %*% ROTt |
| 531 |
} else {
|
|
| 532 | 10947x |
LAMBDA <- t(solve(ROTt, At)) |
| 533 |
} |
|
| 534 | ||
| 535 |
# evaluate criterion |
|
| 536 | 10947x |
Q.new <- do.call(method.fname, c( |
| 537 | 10947x |
list(LAMBDA = LAMBDA), |
| 538 | 10947x |
method.args, list(grad = TRUE) |
| 539 |
)) |
|
| 540 | 10947x |
Gq <- attr(Q.new, "grad") |
| 541 | 10947x |
attr(Q.new, "grad") <- NULL |
| 542 | ||
| 543 |
# check stopping criterion |
|
| 544 | 10947x |
if (Q.new < Q.current - 0.5 * frob * frob * alpha) {
|
| 545 | 5336x |
break |
| 546 |
} else {
|
|
| 547 | 5611x |
alpha <- alpha / 2 |
| 548 |
} |
|
| 549 | ||
| 550 | 5611x |
if (i == 1000) {
|
| 551 | ! |
lav_msg_warn(gettext("half-stepping failed in GPA"))
|
| 552 |
} |
|
| 553 |
} |
|
| 554 | ||
| 555 |
# update |
|
| 556 | 5336x |
ROT <- ROTt |
| 557 | 5336x |
Q.current <- Q.new |
| 558 | ||
| 559 | 5336x |
if (orthogonal) {
|
| 560 | ! |
GRAD <- crossprod(A, Gq) |
| 561 |
} else {
|
|
| 562 | 5336x |
GRAD <- -1 * solve(t(ROT), crossprod(Gq, LAMBDA)) |
| 563 |
} |
|
| 564 |
} # iter |
|
| 565 | ||
| 566 |
# warn if no convergence |
|
| 567 | 90x |
if (!converged) {
|
| 568 | ! |
lav_msg_warn(gettextf( |
| 569 | ! |
"GP rotation algorithm did not converge after %s iterations", |
| 570 | ! |
max.iter |
| 571 |
)) |
|
| 572 |
} |
|
| 573 | ||
| 574 |
# algorithm information |
|
| 575 | 90x |
info <- list( |
| 576 | 90x |
algorithm = "gpa", |
| 577 | 90x |
iter = iter - 1L, |
| 578 | 90x |
converged = converged, |
| 579 | 90x |
method.value = Q.current |
| 580 |
) |
|
| 581 | ||
| 582 | 90x |
attr(ROT, "info") <- info |
| 583 | ||
| 584 | 90x |
ROT |
| 585 |
} |
|
| 586 | ||
| 587 | ||
| 588 |
# pairwise rotation algorithm with direct line search |
|
| 589 |
# |
|
| 590 |
# based on Kaiser's (1959) algorithm and Jennrich and Sampson (1966) algorithm |
|
| 591 |
# but to make it generic, a line search is used; inspired by Browne 2001 |
|
| 592 |
# |
|
| 593 |
# - orthogonal: rotate one pair of columns (=plane) at a time |
|
| 594 |
# - oblique: rotate 1 factor in one pair of columns (=plane) at a time |
|
| 595 |
# note: in the oblique case, (1,2) is not the same as (2,1) |
|
| 596 |
# - BUT use optimize() to find the optimal angle (for each plane) |
|
| 597 |
# (see Browne, 2001, page 130) |
|
| 598 |
# - repeat until the changes in the f() criterion are below tol |
|
| 599 |
# |
|
| 600 | ||
| 601 |
lav_matrix_rotate_pairwise <- function(A = NULL, # original matrix |
|
| 602 |
orthogonal = FALSE, |
|
| 603 |
init.ROT = NULL, |
|
| 604 |
method.fname = NULL, # crit function |
|
| 605 |
method.args = list(), # method args |
|
| 606 |
tol = 1e-8, |
|
| 607 |
max.iter = 1000L) {
|
|
| 608 |
# number of columns |
|
| 609 | ! |
M <- ncol(A) |
| 610 | ||
| 611 |
# initial LAMBDA + PHI |
|
| 612 | ! |
if (is.null(init.ROT)) {
|
| 613 | ! |
LAMBDA <- A |
| 614 | ! |
if (!orthogonal) {
|
| 615 | ! |
PHI <- diag(M) |
| 616 |
} |
|
| 617 |
} else {
|
|
| 618 | ! |
if (orthogonal) {
|
| 619 | ! |
LAMBDA <- A %*% init.ROT |
| 620 |
} else {
|
|
| 621 | ! |
LAMBDA <- t(solve(init.ROT, t(A))) |
| 622 | ! |
PHI <- crossprod(init.ROT) |
| 623 |
} |
|
| 624 |
} |
|
| 625 | ||
| 626 |
# using the current LAMBDA, evaluate the user-specified |
|
| 627 |
# rotation criteron; return Q (the criterion) only |
|
| 628 | ! |
Q.current <- do.call(method.fname, c( |
| 629 | ! |
list(LAMBDA = LAMBDA), |
| 630 | ! |
method.args, list(grad = FALSE) |
| 631 |
)) |
|
| 632 | ||
| 633 |
# if verbose, print |
|
| 634 | ! |
if (lav_verbose()) {
|
| 635 | ! |
cat( |
| 636 | ! |
" iter = ", sprintf("%4d", 0),
|
| 637 | ! |
" Q = ", sprintf("%13.11f", Q.current), "\n"
|
| 638 |
) |
|
| 639 |
} |
|
| 640 | ||
| 641 |
# plane combinations |
|
| 642 | ! |
if (orthogonal) {
|
| 643 | ! |
PLANE <- utils::combn(M, 2) |
| 644 |
} else {
|
|
| 645 | ! |
tmp <- utils::combn(M, 2) |
| 646 | ! |
PLANE <- cbind(tmp, tmp[c(2, 1), , drop = FALSE]) |
| 647 |
} |
|
| 648 | ||
| 649 |
# define objective function -- orthogonal |
|
| 650 | ! |
objf_orth <- function(theta = 0, A = NULL, col1 = 0L, col2 = 0L) {
|
| 651 |
# construct ROT |
|
| 652 | ! |
ROT <- diag(M) |
| 653 | ! |
ROT[col1, col1] <- base::cos(theta) |
| 654 | ! |
ROT[col1, col2] <- base::sin(theta) |
| 655 | ! |
ROT[col2, col1] <- -1 * base::sin(theta) |
| 656 | ! |
ROT[col2, col2] <- base::cos(theta) |
| 657 | ||
| 658 |
# rotate |
|
| 659 | ! |
LAMBDA <- A %*% ROT |
| 660 | ||
| 661 |
# evaluate criterion |
|
| 662 | ! |
Q <- do.call(method.fname, c( |
| 663 | ! |
list(LAMBDA = LAMBDA), |
| 664 | ! |
method.args, list(grad = FALSE) |
| 665 |
)) |
|
| 666 | ||
| 667 | ! |
Q |
| 668 |
} |
|
| 669 | ||
| 670 |
# define objective function -- oblique |
|
| 671 | ! |
objf_obliq <- function(delta = 0, A = NULL, col1 = 0L, col2 = 0L, |
| 672 | ! |
phi12 = 0) {
|
| 673 |
# construct ROT |
|
| 674 | ! |
ROT <- diag(M) |
| 675 | ||
| 676 |
# gamma |
|
| 677 | ! |
gamma2 <- 1 + (2 * delta * phi12) + (delta * delta) |
| 678 | ||
| 679 | ! |
ROT[col1, col1] <- sqrt(abs(gamma2)) |
| 680 | ! |
ROT[col1, col2] <- -1 * delta |
| 681 | ! |
ROT[col2, col1] <- 0 |
| 682 | ! |
ROT[col2, col2] <- 1 |
| 683 | ||
| 684 |
# rotate |
|
| 685 | ! |
LAMBDA <- A %*% ROT |
| 686 | ||
| 687 |
# evaluate criterion |
|
| 688 | ! |
Q <- do.call(method.fname, c( |
| 689 | ! |
list(LAMBDA = LAMBDA), |
| 690 | ! |
method.args, list(grad = FALSE) |
| 691 |
)) |
|
| 692 | ! |
Q |
| 693 |
} |
|
| 694 | ||
| 695 |
# start iterations |
|
| 696 | ! |
converged <- FALSE |
| 697 | ! |
Q.old <- Q.current |
| 698 | ! |
for (iter in seq_len(max.iter)) {
|
| 699 |
# rotate - one cycle |
|
| 700 | ! |
for (pl in seq_len(ncol(PLANE))) {
|
| 701 |
# choose plane |
|
| 702 | ! |
col1 <- PLANE[1, pl] |
| 703 | ! |
col2 <- PLANE[2, pl] |
| 704 | ||
| 705 |
# optimize |
|
| 706 | ! |
if (orthogonal) {
|
| 707 | ! |
out <- optimize( |
| 708 | ! |
f = objf_orth, interval = c(-pi / 4, +pi / 4), |
| 709 | ! |
A = LAMBDA, col1 = col1, col2 = col2, |
| 710 | ! |
maximum = FALSE, tol = .Machine$double.eps^0.25 |
| 711 |
) |
|
| 712 |
# best rotation - for this plane |
|
| 713 | ! |
theta <- out$minimum |
| 714 | ||
| 715 |
# construct ROT |
|
| 716 | ! |
ROT <- diag(M) |
| 717 | ! |
ROT[col1, col1] <- base::cos(theta) |
| 718 | ! |
ROT[col1, col2] <- base::sin(theta) |
| 719 | ! |
ROT[col2, col1] <- -1 * base::sin(theta) |
| 720 | ! |
ROT[col2, col2] <- base::cos(theta) |
| 721 |
} else {
|
|
| 722 | ! |
phi12 <- PHI[col1, col2] |
| 723 | ! |
out <- optimize( |
| 724 | ! |
f = objf_obliq, interval = c(-1, +1), |
| 725 | ! |
A = LAMBDA, col1 = col1, col2 = col2, |
| 726 | ! |
phi12 = phi12, |
| 727 | ! |
maximum = FALSE, tol = .Machine$double.eps^0.25 |
| 728 |
) |
|
| 729 | ||
| 730 |
# best rotation - for this plane |
|
| 731 | ! |
delta <- out$minimum |
| 732 | ||
| 733 |
# construct ROT |
|
| 734 | ! |
ROT <- diag(M) |
| 735 | ||
| 736 |
# gamma |
|
| 737 | ! |
gamma2 <- 1 + (2 * delta * phi12) + (delta * delta) |
| 738 | ! |
gamma <- sqrt(abs(gamma2)) |
| 739 | ||
| 740 | ! |
ROT[col1, col1] <- gamma |
| 741 | ! |
ROT[col1, col2] <- -1 * delta |
| 742 | ! |
ROT[col2, col1] <- 0 |
| 743 | ! |
ROT[col2, col2] <- 1 |
| 744 |
} |
|
| 745 | ||
| 746 |
# rotate |
|
| 747 | ! |
LAMBDA <- LAMBDA %*% ROT |
| 748 | ||
| 749 | ! |
if (!orthogonal) {
|
| 750 |
# rotate PHI |
|
| 751 | ! |
PHI[col1, ] <- (1 / gamma) * PHI[col1, ] + (delta / gamma) * PHI[col2, ] |
| 752 | ! |
PHI[, col1] <- PHI[col1, ] |
| 753 | ! |
PHI[col1, col1] <- 1 |
| 754 |
} |
|
| 755 |
} # all planes |
|
| 756 | ||
| 757 |
# check for convergence |
|
| 758 | ! |
Q.current <- do.call(method.fname, c( |
| 759 | ! |
list(LAMBDA = LAMBDA), |
| 760 | ! |
method.args, list(grad = FALSE) |
| 761 |
)) |
|
| 762 | ||
| 763 |
# absolute change in Q |
|
| 764 | ! |
diff <- abs(Q.old - Q.current) |
| 765 | ||
| 766 |
# if verbose, print |
|
| 767 | ! |
if (lav_verbose()) {
|
| 768 | ! |
cat( |
| 769 | ! |
" iter = ", sprintf("%4d", iter),
|
| 770 | ! |
" Q = ", sprintf("%13.11f", Q.current),
|
| 771 | ! |
" change = ", sprintf("%13.11f", diff), "\n"
|
| 772 |
) |
|
| 773 |
} |
|
| 774 | ||
| 775 | ! |
if (diff < tol) {
|
| 776 | ! |
converged <- TRUE |
| 777 | ! |
break |
| 778 |
} else {
|
|
| 779 | ! |
Q.old <- Q.current |
| 780 |
} |
|
| 781 |
} # iter |
|
| 782 | ||
| 783 |
# warn if no convergence |
|
| 784 | ! |
if (!converged) {
|
| 785 | ! |
lav_msg_warn(gettextf( |
| 786 | ! |
"pairwise rotation algorithm did not converge after %s iterations", |
| 787 | ! |
max.iter |
| 788 |
)) |
|
| 789 |
} |
|
| 790 | ||
| 791 |
# compute final rotation matrix |
|
| 792 | ! |
if (orthogonal) {
|
| 793 | ! |
ROT <- solve(crossprod(A), crossprod(A, LAMBDA)) |
| 794 |
} else {
|
|
| 795 |
# to be compatible with GPa |
|
| 796 | ! |
ROTt.inv <- solve(crossprod(A), crossprod(A, LAMBDA)) |
| 797 | ! |
ROT <- solve(t(ROTt.inv)) |
| 798 |
} |
|
| 799 | ||
| 800 |
# algorithm information |
|
| 801 | ! |
info <- list( |
| 802 | ! |
algorithm = "pairwise", |
| 803 | ! |
iter = iter, |
| 804 | ! |
converged = converged, |
| 805 | ! |
method.value = Q.current |
| 806 |
) |
|
| 807 | ||
| 808 | ! |
attr(ROT, "info") <- info |
| 809 | ||
| 810 | ! |
ROT |
| 811 |
} |
| 1 |
# this code is written by Michael Hallquist |
|
| 2 |
# First draft of parser to convert Mplus model syntax to lavaan model syntax |
|
| 3 | ||
| 4 |
# idea: build parTable and run model from mplus syntax |
|
| 5 |
# then perhaps write export function: parTable2Mplus |
|
| 6 |
# and/or parTable2lavaan |
|
| 7 | ||
| 8 |
lav_mplus_trim <- function(string) {
|
|
| 9 | ! |
stringTrim <- sapply(string, function(x) {
|
| 10 | ! |
x <- sub("^\\s*", "", x, perl = TRUE)
|
| 11 | ! |
x <- sub("\\s*$", "", x, perl = TRUE)
|
| 12 | ! |
return(x) |
| 13 | ! |
}, USE.NAMES = FALSE) |
| 14 | ! |
return(stringTrim) |
| 15 |
} |
|
| 16 | ||
| 17 |
# small utility function to join strings in a regexp loop |
|
| 18 |
lav_mplus_join_regex <- function(cmd, argExpand, matches, iterator, matchLength = "match.length") {
|
|
| 19 | ! |
if (iterator == 1 && matches[iterator] > 1) {
|
| 20 | ! |
pre <- substr(cmd, 1, matches[iterator] - 1) |
| 21 |
} else {
|
|
| 22 | ! |
pre <- "" |
| 23 |
} |
|
| 24 | ||
| 25 |
# if this is not the final match, then get sub-string between the end of this match and the beginning of the next |
|
| 26 |
# otherwise, match to the end of the command |
|
| 27 | ! |
post.end <- ifelse(iterator < length(matches), matches[iterator + 1] - 1, nchar(cmd)) |
| 28 | ! |
post <- substr(cmd, matches[iterator] + attr(matches, matchLength)[iterator], post.end) |
| 29 | ||
| 30 | ! |
cmd.expand <- paste(pre, argExpand, post, sep = "") |
| 31 | ! |
return(cmd.expand) |
| 32 |
} |
|
| 33 | ||
| 34 |
# expand Mplus hyphen syntax (will also expand constraints with hyphens) |
|
| 35 |
lav_mplus_expand_cmd <- function(cmd, alphaStart = TRUE) {
|
|
| 36 |
# use negative lookahead and negative lookbehind to eliminate possibility of hyphen being used as a negative starting value (e.g., x*-1) |
|
| 37 |
# also avoid match of anything that includes a decimal point, such as a floating-point starting value -10.5*x1 |
|
| 38 | ||
| 39 |
# if alphaStart==TRUE, then require that the matches before and after hyphens begin with alpha character |
|
| 40 |
# this is used for variable names, whereas the more generic expansion works for numeric constraints and such |
|
| 41 | ||
| 42 |
# need to do a better job of this so that u1-u20* is supported... I don't think the regexp below is general enough |
|
| 43 | ||
| 44 |
# if (alphaStart) {
|
|
| 45 |
# hyphens <- gregexpr("[_A-Za-z]+\\w*\\s*-\\s*[_A-Za-z]+\\w*", cmd, perl=TRUE)[[1]]
|
|
| 46 |
# } else {
|
|
| 47 |
# hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))", cmd, perl=TRUE)[[1]]
|
|
| 48 |
# } |
|
| 49 | ||
| 50 |
# hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))", cmd, perl=TRUE)[[1]]
|
|
| 51 | ||
| 52 |
# support trailing @XXX. Still still fail on Trait1-Trait3*XXX |
|
| 53 | ! |
hyphens <- gregexpr("(?!<(\\*|\\.))\\w+(?!(\\*|\\.))\\s*-\\s*(?!<(\\*|\\.))\\w+(?!(\\*|\\.))(@[\\d\\.\\-]+)?", cmd, perl = TRUE)[[1]]
|
| 54 | ||
| 55 |
# Promising, but this is still failing in the case of x3*1 -4.25*x4 |
|
| 56 |
# On either side of a hyphen, require alpha character followed by alphanumeric |
|
| 57 |
# This enforces that neither side of the hyphen can be a number |
|
| 58 |
# Alternatively, match digits on either side alone |
|
| 59 |
# hyphens <- gregexpr("([A-z]+\\w*\\s*-\\s*[A-z]+\\w*(@[\\d\\.-]+)?|\\d+\\s*-\\s*\\d+)", cmd, perl=TRUE)[[1]]
|
|
| 60 | ||
| 61 | ! |
if (hyphens[1L] > 0) {
|
| 62 | ! |
cmd.expand <- c() |
| 63 | ! |
ep <- 1 |
| 64 | ||
| 65 | ! |
for (v in 1:length(hyphens)) {
|
| 66 |
# match one keyword before and after hyphen |
|
| 67 | ! |
argsplit <- strsplit(substr(cmd, hyphens[v], hyphens[v] + attr(hyphens, "match.length")[v] - 1), "\\s*-\\s*", perl = TRUE)[[1]] |
| 68 | ||
| 69 | ! |
v_pre <- argsplit[1] |
| 70 | ! |
v_post <- argsplit[2] |
| 71 | ||
| 72 | ! |
v_post.suffix <- sub("^([^@]+)(@[\\d\\-.]+)?$", "\\2", v_post, perl = TRUE) # will be empty string if not present
|
| 73 | ! |
v_post <- sub("@[\\d\\-.]+$", "", v_post, perl = TRUE) # trim @ suffix
|
| 74 | ||
| 75 |
# If v_pre and v_post contain leading alpha characters, verify that these prefixes match. |
|
| 76 |
# Otherwise, there is nothing to expand, as in the case of MODEL CONSTRAINT: e1e2=e1-e2_n. |
|
| 77 | ! |
v_pre.alpha <- sub("\\d+$", "", v_pre, perl = TRUE)
|
| 78 | ! |
v_post.alpha <- sub("\\d+$", "", v_post, perl = TRUE)
|
| 79 | ||
| 80 |
# only enforce prefix match if we have leading alpha characters (i.e., not simple numeric 1 - 3 syntax) |
|
| 81 | ! |
if (length(v_pre.alpha) > 0L && length(v_post.alpha) > 0L) {
|
| 82 |
# if alpha prefixes do match, assume that the hyphen is not for expansion (e.g., in subtraction case) |
|
| 83 | ! |
if (v_pre.alpha != v_post.alpha) {
|
| 84 | ! |
return(cmd) |
| 85 |
} |
|
| 86 |
} |
|
| 87 | ||
| 88 |
# the basic positive lookbehind blows up with pure numeric constraints (1 - 3) because no alpha char precedes digit |
|
| 89 |
# can use an non-capturing alternation grouping to allow for digits only or the final digits after alphas (as in v_post.num) |
|
| 90 | ! |
v_pre.num <- as.integer(sub("\\w*(?<=[A-Za-z_])(\\d+)$", "\\1", v_pre, perl = TRUE)) # use positive lookbehind to avoid greedy \w+ match -- capture all digits
|
| 91 | ||
| 92 | ! |
v_post.match <- regexpr("^(?:\\w*(?<=[A-Za-z_])(\\d+)|(\\d+))$", v_post, perl = TRUE)
|
| 93 | ! |
stopifnot(v_post.match[1L] > 0) |
| 94 | ||
| 95 |
# match mat be under capture[1] or capture[2] because of alternation above |
|
| 96 | ! |
whichCapture <- which(attr(v_post.match, "capture.start") > 0) |
| 97 | ||
| 98 | ! |
v_post.num <- as.integer(substr(v_post, attr(v_post.match, "capture.start")[whichCapture], attr(v_post.match, "capture.start")[whichCapture] + attr(v_post.match, "capture.length")[whichCapture] - 1)) |
| 99 | ! |
v_post.prefix <- substr(v_post, 1, attr(v_post.match, "capture.start")[whichCapture] - 1) # just trusting that pre and post match |
| 100 | ||
| 101 | ! |
if (is.na(v_pre.num) || is.na(v_post.num)) lav_msg_stop( |
| 102 | ! |
gettext("Cannot expand variables:"), v_pre, ", ", v_post)
|
| 103 | ! |
v_expand <- paste(v_post.prefix, v_pre.num:v_post.num, v_post.suffix, sep = "", collapse = " ") |
| 104 | ||
| 105 |
# for first hyphen, there may be non-hyphenated syntax preceding the initial match |
|
| 106 | ! |
cmd.expand[ep] <- lav_mplus_join_regex(cmd, v_expand, hyphens, v) |
| 107 | ||
| 108 |
# This won't really work because the cmd.expand element may contain other variables |
|
| 109 |
# that are at the beginning or end, prior to hyphen stuff |
|
| 110 |
# This is superseded by logic above where @ is included in hyphen match, then trapped as suffix |
|
| 111 |
# I don't think it will work yet for this Mplus syntax: y1-y10*5 -- the 5 wouldn't propagate |
|
| 112 |
# handle the case of @ fixed values or * starting values used in a list |
|
| 113 |
# example: Trait1-Trait3@1 |
|
| 114 |
## if (grepl("@|\\*", cmd.expand[ep], perl=TRUE)) {
|
|
| 115 |
## exp_split <- strsplit(cmd.expand[ep], "\\s+", perl=TRUE)[[1]] |
|
| 116 |
## suffixes <- sub("^([^@\\*]+)([@*][\\d\\.-]+)?$", "\\2", exp_split, perl=TRUE)
|
|
| 117 |
## variables <- sub("^([^@\\*]+)([@*][\\d\\.-]+)?$", "\\1", exp_split, perl=TRUE)
|
|
| 118 |
## suffixes <- suffixes[suffixes != ""] |
|
| 119 |
## if (length(unique(suffixes)) > 1L) {
|
|
| 120 |
## browser() |
|
| 121 | ||
| 122 |
## #stop("Don't know how to interpret syntax: ", cmd)
|
|
| 123 |
## } else {
|
|
| 124 |
## variables <- paste0(variables, suffixes[1]) |
|
| 125 |
## cmd.expand[ep] <- paste(variables, collapse=" ") |
|
| 126 |
## } |
|
| 127 |
## } |
|
| 128 | ||
| 129 | ! |
ep <- ep + 1 |
| 130 |
} |
|
| 131 | ! |
return(paste(cmd.expand, collapse = "")) |
| 132 |
} else {
|
|
| 133 | ! |
return(cmd) # no hyphens to expand |
| 134 |
} |
|
| 135 |
} |
|
| 136 | ||
| 137 | ||
| 138 |
# handle starting values and fixed parameters on rhs |
|
| 139 |
lav_mplus_cmd_fix_start <- function(cmd) {
|
|
| 140 | ! |
cmd.parse <- c() |
| 141 | ! |
ep <- 1L |
| 142 | ||
| 143 |
# support ESEM-like syntax: F BY a1* a2* |
|
| 144 |
# The easy path: putting in 1s before we proceed on parsing |
|
| 145 |
# Mar2023 bugfix: support parenthesis after * in case a parameter constraint comes next |
|
| 146 | ! |
cmd <- gsub("([A-z]+\\w*)\\s*\\*(?=\\s+\\(?[A-z]+|\\s*$)", "\\1*1", cmd, perl = TRUE)
|
| 147 | ||
| 148 | ! |
if ((fixed.starts <- gregexpr("[\\w\\.\\-$]+\\s*([@*])\\s*[\\w\\.\\-]+", cmd, perl = TRUE)[[1]])[1L] > 0) { # shouldn't it be \\*, not * ?! Come back to this.
|
| 149 | ! |
for (f in 1:length(fixed.starts)) {
|
| 150 |
# capture above obtains the fixed/start character (@ or *), whereas match obtains the full regex match |
|
| 151 | ! |
opchar <- substr(cmd, attr(fixed.starts, "capture.start")[f], attr(fixed.starts, "capture.start")[f] + attr(fixed.starts, "capture.length")[f] - 1) |
| 152 | ||
| 153 |
# match arguments around asterisk/at symbol |
|
| 154 | ! |
argsplit <- strsplit(substr(cmd, fixed.starts[f], fixed.starts[f] + attr(fixed.starts, "match.length")[f] - 1), paste0("\\s*", ifelse(opchar == "*", "\\*", opchar), "\\s*"), perl = TRUE)[[1]]
|
| 155 | ! |
v_pre <- argsplit[1] |
| 156 | ! |
v_post <- argsplit[2] |
| 157 | ||
| 158 | ! |
if (suppressWarnings(is.na(as.numeric(v_pre)))) { # fixed.starts value post-multiplier
|
| 159 | ! |
var <- v_pre |
| 160 | ! |
val <- v_post |
| 161 | ! |
} else if (suppressWarnings(is.na(as.numeric(v_post)))) { # starting value pre-multiplier
|
| 162 | ! |
var <- v_post |
| 163 | ! |
val <- v_pre |
| 164 |
} else {
|
|
| 165 | ! |
lav_msg_stop( |
| 166 | ! |
gettext("Cannot parse Mplus fixed/starts values specification:"),
|
| 167 | ! |
v_pre, v_post) |
| 168 |
} |
|
| 169 | ||
| 170 | ! |
if (opchar == "@") {
|
| 171 | ! |
cmd.parse[ep] <- lav_mplus_join_regex(cmd, paste0(val, "*", var, sep = ""), fixed.starts, f) |
| 172 | ! |
ep <- ep + 1L |
| 173 |
} else {
|
|
| 174 | ! |
cmd.parse[ep] <- lav_mplus_join_regex(cmd, paste0("start(", val, ")*", var, sep = ""), fixed.starts, f)
|
| 175 | ! |
ep <- ep + 1L |
| 176 |
} |
|
| 177 |
} |
|
| 178 | ! |
return(paste(cmd.parse, collapse = "")) |
| 179 |
} else {
|
|
| 180 | ! |
return(cmd) |
| 181 |
} |
|
| 182 |
} |
|
| 183 | ||
| 184 |
lav_mplus_cmd_constraints <- function(cmd) {
|
|
| 185 |
# Allow cmd to have newlines embedded. In this case, split on newlines, and loop over and parse each chunk |
|
| 186 |
# Dump leading and trailing newlines, which contain no information about constraints, but may add dummy elements to vector after strsplit |
|
| 187 |
# Maybe return LHS and RHS parsed command where constraints only appear on the RHS, whereas the LHS contains only parameters. |
|
| 188 |
# Example: LHS is v1 v2 v3 and RHS is con1*v1 con2*v2 con3*v3 |
|
| 189 | ||
| 190 | ! |
cmd.split <- strsplit(cmd, "\n")[[1]] |
| 191 | ||
| 192 |
# drop empty lines (especially leading newline) |
|
| 193 | ! |
cmd.split <- if (length(emptyPos <- which(cmd.split == "")) > 0L) {
|
| 194 | ! |
cmd.split[-1 * emptyPos] |
| 195 |
} else {
|
|
| 196 | ! |
cmd.split |
| 197 |
} |
|
| 198 | ||
| 199 |
# Create a version of the command with no modifiers (constraints, starting values, etc.) specifications. |
|
| 200 |
# This is useful for syntax that uses the params on the LHS and with a modified RHS. Example: v1 ~~ conB*v1 |
|
| 201 | ! |
cmd.nomodifiers <- paste0(gsub("(start\\([^\\)]+\\)\\*|[\\d\\-\\.]+\\*)", "", cmd.split, perl = TRUE), collapse = " ") # peel off premultiplication
|
| 202 | ! |
cmd.nomodifiers <- gsub("\\([^\\)]+\\)", "", cmd.nomodifiers, perl = TRUE)
|
| 203 | ||
| 204 | ! |
cmd.tojoin <- c() # will store all chunks divided by newlines, which will be joined at the end. |
| 205 | ||
| 206 |
# iterate over each newline segment |
|
| 207 | ! |
for (n in 1:length(cmd.split)) {
|
| 208 |
# in principle, now that we respect newlines, parens should only be of length 1, since Mplus syntax dictates newlines for each use of parentheses for constraints |
|
| 209 | ! |
if ((parens <- gregexpr("(?<!start)\\(([^\\)]+)\\)", cmd.split[n], perl = TRUE)[[1L]])[1L] > 0) { # match parentheses, but not start()
|
| 210 |
# the syntax chunk after all parentheses have been matched |
|
| 211 | ! |
cmd.expand <- c() |
| 212 | ||
| 213 | ! |
for (p in 1:length(parens)) {
|
| 214 |
# string within the constraint parentheses |
|
| 215 | ! |
constraints <- substr(cmd.split[n], attr(parens, "capture.start")[p], attr(parens, "capture.start")[p] + attr(parens, "capture.length")[p] - 1) |
| 216 | ||
| 217 |
# Divide constraints on spaces to determine number of constraints to parse. Use lav_mplus_trim to avoid problem of user including leading/trailing spaces within parentheses. |
|
| 218 | ! |
con.split <- strsplit(lav_mplus_trim(constraints), "\\s+", perl = TRUE)[[1]] |
| 219 | ||
| 220 |
# if Mplus uses a purely numeric constraint, then add ".con" prefix to be consistent with R naming. |
|
| 221 | ! |
con.split <- sapply(con.split, function(x) {
|
| 222 | ! |
if (!suppressWarnings(is.na(as.numeric(x)))) {
|
| 223 | ! |
make.names(paste0(".con", x))
|
| 224 |
} else {
|
|
| 225 | ! |
x |
| 226 |
} |
|
| 227 |
}) |
|
| 228 | ||
| 229 |
# determine the parameters that precede the parentheses (either first character for p == 1 or character after preceding parentheses) |
|
| 230 | ! |
prestrStart <- ifelse(p > 1, attr(parens, "capture.start")[p - 1] + attr(parens, "capture.length")[p - 1] + 1, 1) |
| 231 | ||
| 232 |
# obtain the parameters that precede the parentheses, divide into arguments on spaces |
|
| 233 |
# use lav_mplus_trim here because first char after prestrStart for p > 1 will probably be a space |
|
| 234 | ! |
precmd.split <- strsplit(lav_mplus_trim(substr(cmd.split[n], prestrStart, parens[p] - 1)), "\\s+", perl = TRUE)[[1]] |
| 235 | ||
| 236 |
# peel off any potential LHS arguments, such as F1 BY |
|
| 237 | ! |
precmdLHSOp <- which(tolower(precmd.split) %in% c("by", "with", "on"))
|
| 238 | ! |
if (any(precmdLHSOp)) {
|
| 239 | ! |
lhsop <- paste0(precmd.split[1:precmdLHSOp[1L]], " ", collapse = " ") # join lhs and op as a single string, add trailing space so that paste with expanded RHS is right. |
| 240 | ! |
rhs <- precmd.split[(precmdLHSOp + 1):length(precmd.split)] |
| 241 |
} else {
|
|
| 242 | ! |
lhsop <- "" |
| 243 | ! |
rhs <- precmd.split |
| 244 |
} |
|
| 245 | ||
| 246 | ! |
if (length(con.split) > 1L) {
|
| 247 |
# several constraints listed within parentheses. Example: F1 BY X1 X2 X3 X4 (C2 C3 C4) |
|
| 248 |
# thus, backwards match the constraints to parameters |
|
| 249 | ||
| 250 |
# restrict parameters to backwards match to be of the same length as number of constraints |
|
| 251 | ! |
rhs.backmatch <- rhs[(length(rhs) - length(con.split) + 1):length(rhs)] |
| 252 | ||
| 253 | ! |
rhs.expand <- c() |
| 254 | ||
| 255 |
# check that no mean or scale markers are part of the rhs param to expand |
|
| 256 | ! |
if ((preMark.match <- regexpr("^\\s*[\\[\\{]", rhs.backmatch[1L], perl = TRUE))[1L] > 0) {
|
| 257 | ! |
preMark <- substr(rhs.backmatch[1L], preMark.match[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L] - 1) |
| 258 | ! |
rhs.backmatch[1L] <- substr(rhs.backmatch[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L], nchar(rhs.backmatch[1L])) |
| 259 |
} else {
|
|
| 260 | ! |
preMark <- "" |
| 261 |
} |
|
| 262 | ||
| 263 | ! |
if ((postMark.match <- regexpr("[\\]\\}]\\s*$", rhs.backmatch[length(rhs.backmatch)], perl = TRUE))[1L] > 0) {
|
| 264 | ! |
postMark <- substr(rhs.backmatch[length(rhs.backmatch)], postMark.match[1L], nchar(rhs.backmatch[length(rhs.backmatch)])) |
| 265 | ! |
rhs.backmatch[length(rhs.backmatch)] <- substr(rhs.backmatch[length(rhs.backmatch)], 1, postMark.match[1L] - 1) |
| 266 |
} else {
|
|
| 267 | ! |
postMark <- "" |
| 268 |
} |
|
| 269 | ||
| 270 | ||
| 271 |
# pre-multiply each parameter with each corresponding constraint |
|
| 272 | ! |
for (i in 1:length(rhs.backmatch)) {
|
| 273 | ! |
rhs.expand[i] <- paste0(con.split[i], "*", rhs.backmatch[i]) |
| 274 |
} |
|
| 275 | ||
| 276 |
# join rhs as string and add back in mean/scale operator, if present |
|
| 277 | ! |
rhs.expand <- paste0(preMark, paste(rhs.expand, collapse = " "), postMark) |
| 278 | ||
| 279 |
# if there were params that preceded the backwards match, then add these back to the syntax |
|
| 280 |
# append this syntax to the parsed command, cmd.expand |
|
| 281 | ! |
if (length(rhs) - length(con.split) > 0L) {
|
| 282 | ! |
cmd.expand <- c(cmd.expand, paste(lhsop, paste(rhs[1:(length(rhs) - length(con.split))], collapse = " "), rhs.expand)) |
| 283 |
} else {
|
|
| 284 | ! |
cmd.expand <- c(cmd.expand, paste0(lhsop, rhs.expand)) |
| 285 |
} |
|
| 286 |
} else {
|
|
| 287 |
# should be able to reduce redundancy with above |
|
| 288 | ||
| 289 |
# all parameters on the right hand side are to be equated |
|
| 290 |
# thus, pre-multiply each parameter by the constraint |
|
| 291 | ||
| 292 |
# check that no mean or scale markers are part of the rhs param to expand |
|
| 293 |
# DUPE CODE FROM ABOVE. Make Function?! |
|
| 294 | ! |
if ((preMark.match <- regexpr("^\\s*[\\[\\{]", rhs[1L], perl = TRUE))[1L] > 0) {
|
| 295 | ! |
preMark <- substr(rhs[1L], preMark.match[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L] - 1) |
| 296 | ! |
rhs[1L] <- substr(rhs[1L], preMark.match[1L] + attr(preMark.match, "match.length")[1L], nchar(rhs[1L])) |
| 297 |
} else {
|
|
| 298 | ! |
preMark <- "" |
| 299 |
} |
|
| 300 | ||
| 301 | ! |
if ((postMark.match <- regexpr("[\\]\\}]\\s*$", rhs[length(rhs)], perl = TRUE))[1L] > 0) {
|
| 302 | ! |
postMark <- substr(rhs[length(rhs)], postMark.match[1L], nchar(rhs[length(rhs)])) |
| 303 | ! |
rhs[length(rhs)] <- substr(rhs[length(rhs)], 1, postMark.match[1L] - 1) |
| 304 |
} else {
|
|
| 305 | ! |
postMark <- "" |
| 306 |
} |
|
| 307 | ||
| 308 | ||
| 309 | ! |
rhs.expand <- c() |
| 310 | ! |
for (i in 1:length(rhs)) {
|
| 311 | ! |
rhs.expand[i] <- paste0(con.split[1L], "*", rhs[i]) |
| 312 |
} |
|
| 313 | ||
| 314 |
# join rhs as string |
|
| 315 | ! |
rhs.expand <- paste0(preMark, paste(rhs.expand, collapse = " "), postMark) |
| 316 | ||
| 317 | ! |
cmd.expand <- c(cmd.expand, paste0(lhsop, rhs.expand)) |
| 318 |
} |
|
| 319 |
} |
|
| 320 | ||
| 321 | ! |
cmd.tojoin[n] <- paste(cmd.expand, collapse = " ") |
| 322 |
} else {
|
|
| 323 | ! |
cmd.tojoin[n] <- cmd.split[n] |
| 324 |
} # no parens |
|
| 325 |
} |
|
| 326 | ||
| 327 |
# eliminate newlines in this function so that they don't mess up \\s+ splits downstream |
|
| 328 | ! |
toReturn <- paste(cmd.tojoin, collapse = " ") |
| 329 | ! |
attr(toReturn, "noModifiers") <- cmd.nomodifiers |
| 330 | ||
| 331 | ! |
return(toReturn) |
| 332 |
} |
|
| 333 | ||
| 334 |
lav_mplus_cmd_growth <- function(cmd) {
|
|
| 335 |
# can assume that any spaces between tscore and variable were stripped by lav_mplus_cmd_fix_start |
|
| 336 | ||
| 337 |
# verify that this is not a random slope |
|
| 338 | ! |
if (any(tolower(strsplit(cmd, "\\s+", perl = TRUE)[[1]]) %in% c("on", "at"))) {
|
| 339 | ! |
lav_msg_stop(gettext( |
| 340 | ! |
"lavaan does not support random slopes or individually varying |
| 341 | ! |
growth model time scores")) |
| 342 |
} |
|
| 343 | ||
| 344 | ! |
cmd.split <- strsplit(cmd, "\\s*\\|\\s*", perl = TRUE)[[1]] |
| 345 | ! |
if (!length(cmd.split) == 2) {
|
| 346 | ! |
lav_msg_stop(gettext("Unknown growth syntax:"), cmd)
|
| 347 |
} |
|
| 348 | ||
| 349 | ! |
lhs <- cmd.split[1] |
| 350 | ! |
lhs.split <- strsplit(lhs, "\\s+", perl = TRUE)[[1]] |
| 351 | ||
| 352 | ! |
rhs <- cmd.split[2] |
| 353 | ! |
rhs.split <- strsplit(rhs, "(\\*|\\s+)", perl = TRUE)[[1]] |
| 354 | ||
| 355 | ! |
if (length(rhs.split) %% 2 != 0) {
|
| 356 | ! |
lav_msg_stop(gettext( |
| 357 | ! |
"Number of variables and number of tscores does not match:"), rhs) |
| 358 |
} |
|
| 359 | ! |
tscores <- as.numeric(rhs.split[1:length(rhs.split) %% 2 != 0]) # pre-multipliers |
| 360 | ||
| 361 | ! |
vars <- rhs.split[1:length(rhs.split) %% 2 == 0] |
| 362 | ||
| 363 | ! |
cmd.expand <- c() |
| 364 | ||
| 365 | ! |
for (p in 0:(length(lhs.split) - 1)) {
|
| 366 | ! |
if (p == 0) {
|
| 367 |
# intercept |
|
| 368 | ! |
cmd.expand <- c(cmd.expand, paste(lhs.split[(p + 1)], "=~", paste("1*", vars, sep = "", collapse = " + ")))
|
| 369 |
} else {
|
|
| 370 | ! |
cmd.expand <- c(cmd.expand, paste(lhs.split[(p + 1)], "=~", paste(tscores^p, "*", vars, sep = "", collapse = " + "))) |
| 371 |
} |
|
| 372 |
} |
|
| 373 | ||
| 374 | ! |
return(cmd.expand) |
| 375 |
} |
|
| 376 | ||
| 377 |
# function to wrap long lines at a certain width, splitting on + symbols to be consistent with R syntax |
|
| 378 |
lav_mplus_cmd_wrap <- function(cmd, width = 90, exdent = 5) {
|
|
| 379 | ! |
result <- lapply(cmd, function(line) {
|
| 380 | ! |
if (nchar(line) > width) {
|
| 381 | ! |
split <- c() |
| 382 | ! |
spos <- 1L |
| 383 | ||
| 384 | ! |
plusMatch <- gregexpr("+", line, fixed = TRUE)[[1]]
|
| 385 | ! |
mpos <- 1L |
| 386 | ||
| 387 | ! |
if (plusMatch[1L] > 0L) {
|
| 388 |
# split after plus symbol |
|
| 389 | ! |
charsRemain <- nchar(line) |
| 390 | ! |
while (charsRemain > 0L) {
|
| 391 | ! |
toProcess <- substr(line, nchar(line) - charsRemain + 1, nchar(line)) |
| 392 | ! |
offset <- nchar(line) - charsRemain + 1 |
| 393 | ||
| 394 | ! |
if (nchar(remainder <- substr(line, offset, nchar(line))) <= (width - exdent)) {
|
| 395 |
# remainder of line fits within width -- no need to continue wrapping |
|
| 396 | ! |
split[spos] <- remainder |
| 397 | ! |
charsRemain <- 0 |
| 398 |
} else {
|
|
| 399 | ! |
wrapAt <- which(plusMatch < (width + offset - exdent)) |
| 400 | ! |
wrapAt <- wrapAt[length(wrapAt)] # at the final + |
| 401 | ||
| 402 | ! |
split[spos] <- substr(line, offset, plusMatch[wrapAt]) |
| 403 | ! |
charsRemain <- charsRemain - nchar(split[spos]) |
| 404 | ! |
spos <- spos + 1 |
| 405 |
} |
|
| 406 |
} |
|
| 407 | ||
| 408 |
# remove leading and trailing chars |
|
| 409 | ! |
split <- lav_mplus_trim(split) |
| 410 | ||
| 411 |
# handle exdent |
|
| 412 | ! |
split <- sapply(1:length(split), function(x) {
|
| 413 | ! |
if (x > 1) {
|
| 414 | ! |
paste0(paste(rep(" ", exdent), collapse = ""), split[x])
|
| 415 |
} else {
|
|
| 416 | ! |
split[x] |
| 417 |
} |
|
| 418 |
}) |
|
| 419 | ||
| 420 | ! |
return(split) |
| 421 |
} else {
|
|
| 422 | ! |
return(strwrap(line, width = width, exdent = exdent)) # convention strwrap when no + present |
| 423 |
} |
|
| 424 |
} else {
|
|
| 425 | ! |
return(line) |
| 426 |
} |
|
| 427 |
}) |
|
| 428 | ||
| 429 |
# bind together multi-line expansions into single vector |
|
| 430 | ! |
return(unname(do.call(c, result))) |
| 431 |
} |
|
| 432 | ||
| 433 |
lav_mplus_syntax_constraints <- function(syntax) {
|
|
| 434 |
# should probably pass in model syntax along with some tracking of which parameter labels are defined. |
|
| 435 | ||
| 436 |
# convert MODEL CONSTRAINT section to lavaan model syntax |
|
| 437 | ! |
syntax <- paste(lapply(lav_mplus_trim(strsplit(syntax, "\n")), function(x) {
|
| 438 | ! |
if (length(x) == 0L && is.character(x)) "" else x |
| 439 | ! |
}), collapse = "\n") |
| 440 | ||
| 441 |
# replace ! with # for comment lines. Also strip newline and replace with semicolon |
|
| 442 | ! |
syntax <- gsub("(\\s*)!(.+)\n", "\\1#\\2;", syntax, perl = TRUE)
|
| 443 | ||
| 444 |
# split into vector of strings |
|
| 445 |
# need to peel off leading or trailing newlines -- leads to parsing confusion downstream otherwise |
|
| 446 | ! |
syntax.split <- gsub("(^\n|\n$)", "", unlist(strsplit(syntax, ";")), perl = TRUE)
|
| 447 | ||
| 448 | ! |
constraint.out <- c() |
| 449 | ||
| 450 |
# TODO: Handle PLOT and LOOP syntax for model constraints. |
|
| 451 |
# TODO: Handle DO loop convention |
|
| 452 | ||
| 453 |
# first parse new parameters defined in MODEL CONSTRAINT into a vector |
|
| 454 | ! |
new.parameters <- c() # parameters that are defined in constraint section |
| 455 | ! |
if (length(new.con.lines <- grep("^\\s*NEW\\s*\\([^\\)]+\\)", syntax.split, perl = TRUE, ignore.case = TRUE)) > 0L) {
|
| 456 | ! |
for (cmd in syntax.split[new.con.lines]) {
|
| 457 |
# process new constraint definition |
|
| 458 | ! |
new.con <- regexpr("^\\s*NEW\\s*\\(([^\\)]+)\\)", cmd, perl = TRUE, ignore.case = TRUE)
|
| 459 | ! |
if (new.con[1L] == -1) |
| 460 | ! |
lav_msg_stop(gettext("Unable to parse names of new contraints"))
|
| 461 | ! |
new.con <- substr(cmd, attr(new.con, "capture.start"), attr(new.con, "capture.start") + attr(new.con, "capture.length") - 1L) |
| 462 | ! |
new.con <- lav_mplus_expand_cmd(new.con) # allow for hyphen expansion |
| 463 | ! |
new.parameters <- c(new.parameters, strsplit(lav_mplus_trim(new.con), "\\s+", perl = TRUE)[[1L]]) |
| 464 |
} |
|
| 465 | ||
| 466 | ! |
syntax.split <- syntax.split[-1L * new.con.lines] # drop out these lines |
| 467 | ! |
parameters.undefined <- new.parameters # to be used below to handle ambiguity of equation versus definition |
| 468 |
} |
|
| 469 | ||
| 470 | ! |
for (cmd in syntax.split) {
|
| 471 | ! |
if (grepl("^\\s*#", cmd, perl = TRUE)) { # comment line
|
| 472 | ! |
constraint.out <- c(constraint.out, gsub("\n", "", cmd, fixed = TRUE)) # drop any newlines
|
| 473 | ! |
} else if (grepl("^\\s+$", cmd, perl = TRUE)) {
|
| 474 |
# do nothing, just a space line |
|
| 475 |
} else {
|
|
| 476 |
# constraint proper |
|
| 477 | ! |
cmd <- gsub("**", "^", cmd, fixed = TRUE) # handle exponent
|
| 478 | ||
| 479 |
# lower case the math operations supported by Mplus to be consistent with R |
|
| 480 |
# match all math operators, then lower case each and rejoin string |
|
| 481 | ! |
maths <- gregexpr("(SQRT|LOG|LOG10|EXP|ABS|SIN|COS|TAN|ASIN|ACOS|ATAN)\\s*\\(", cmd, perl = TRUE)[[1L]]
|
| 482 | ! |
if (maths[1L] > 0) {
|
| 483 | ! |
maths.replace <- c() |
| 484 | ! |
ep <- 1 |
| 485 | ||
| 486 | ! |
for (i in 1:length(maths)) {
|
| 487 | ! |
operator <- tolower(substr(cmd, attr(maths, "capture.start")[i], attr(maths, "capture.start")[i] + attr(maths, "capture.length")[i] - 1)) |
| 488 | ! |
maths.replace[ep] <- lav_mplus_join_regex(cmd, operator, maths, i, matchLength = "capture.length") # only match operator, not opening ( |
| 489 | ! |
ep <- ep + 1 |
| 490 |
} |
|
| 491 | ! |
cmd <- paste(maths.replace, collapse = "") |
| 492 |
} |
|
| 493 | ||
| 494 |
# equating some lhs and rhs: could reflect definition of new parameter |
|
| 495 | ! |
if ((equals <- regexpr("=", cmd, fixed = TRUE))[1L] > 0) {
|
| 496 | ! |
lhs <- lav_mplus_trim(substr(cmd, 1, equals - 1)) |
| 497 | ! |
rhs <- lav_mplus_trim(substr(cmd, equals + attr(equals, "match.length"), nchar(cmd))) |
| 498 | ||
| 499 |
# possibility of lhs or rhs containing the single variable to be equated |
|
| 500 | ! |
if (regexpr("\\s+", lhs, perl = TRUE)[1L] > 0L) {
|
| 501 | ! |
def <- rhs |
| 502 | ! |
body <- lhs |
| 503 | ! |
} else if (regexpr("\\s+", rhs, perl = TRUE)[1L] > 0L) {
|
| 504 | ! |
def <- lhs |
| 505 | ! |
body <- rhs |
| 506 |
} else {
|
|
| 507 |
# warning("Can't figure out which side of constraint defines a parameter")
|
|
| 508 |
# this would occur for simple rel5 = rel2 sort of syntax |
|
| 509 | ! |
def <- lhs |
| 510 | ! |
body <- rhs |
| 511 |
} |
|
| 512 | ||
| 513 |
# must decide whether this is a new parameter (:=) or equation of exising labels (==) |
|
| 514 |
# alternatively, could be zero, as in 0 = x + y |
|
| 515 |
# this is tricky, because mplus doesn't differentiate definition from equation |
|
| 516 |
# consequently, could confuse the issue as in ex5.20 |
|
| 517 |
# NEW(rel2 rel5 stan3 stan6); |
|
| 518 |
# rel2 = lam2**2*vf1/(lam2**2*vf1 + ve2); |
|
| 519 |
# rel5 = lam5**2*vf2/(lam5**2*vf2 + ve5); |
|
| 520 |
# rel5 = rel2; |
|
| 521 | ||
| 522 |
# for now, only define a new constraint if it's not already defined |
|
| 523 |
# otherwise equate |
|
| 524 | ! |
if (def %in% new.parameters && def %in% parameters.undefined) {
|
| 525 | ! |
constraint.out <- c(constraint.out, paste(def, ":=", body)) |
| 526 | ! |
parameters.undefined <- parameters.undefined[!parameters.undefined == def] |
| 527 |
} else {
|
|
| 528 | ! |
constraint.out <- c(constraint.out, paste(def, "==", body)) |
| 529 |
} |
|
| 530 |
} else {
|
|
| 531 |
# inequality constraints -- paste as is |
|
| 532 | ! |
constraint.out <- c(constraint.out, cmd) |
| 533 |
} |
|
| 534 |
} |
|
| 535 |
} |
|
| 536 | ||
| 537 | ! |
wrap <- paste(lav_mplus_cmd_wrap(constraint.out, width = 90, exdent = 5), collapse = "\n") |
| 538 | ! |
return(wrap) |
| 539 |
} |
|
| 540 | ||
| 541 |
lav_mplus_syntax_model <- function(syntax) {
|
|
| 542 | ! |
if (is.character(syntax)) {
|
| 543 | ! |
if (length(syntax) > 1L) {
|
| 544 | ! |
syntax <- paste(syntax, collapse = "\n") |
| 545 |
} # concatenate into a long string separated by newlines |
|
| 546 |
} else {
|
|
| 547 | ! |
lav_msg_stop(gettext( |
| 548 | ! |
"lav_mplus_syntax_model accepts a single character string or |
| 549 | ! |
character vector containing all model syntax")) |
| 550 |
} |
|
| 551 | ||
| 552 |
# because this is now exposed as a function in the package, handle the case of the user passing in full .inp file as text |
|
| 553 |
# we should only be interested in the MODEL and MODEL CONSTRAINT sections |
|
| 554 | ! |
by_line <- strsplit(syntax, "\r?\n", perl = TRUE)[[1]] |
| 555 | ! |
inputHeaders <- grep("^\\s*(title:|data.*:|variable:|define:|analysis:|model.*:|output:|savedata:|plot:|montecarlo:)", by_line, ignore.case = TRUE, perl = TRUE)
|
| 556 | ! |
con_syntax <- c() |
| 557 | ! |
if (length(inputHeaders) > 0L) {
|
| 558 |
# warning("lav_mplus_syntax_model is intended to accept only the model section, not an entire .inp file. For the .inp file case, use lav_mplus_lavaan")
|
|
| 559 | ! |
parsed_syntax <- lav_mplus_text_sections(by_line, "local") |
| 560 | ||
| 561 |
# handle model constraint |
|
| 562 | ! |
if ("model.constraint" %in% names(parsed_syntax)) {
|
| 563 | ! |
con_syntax <- strsplit(lav_mplus_syntax_constraints(parsed_syntax$model.constraint), "\n")[[1]] |
| 564 |
} |
|
| 565 | ||
| 566 |
# just keep model syntax before continuing |
|
| 567 | ! |
syntax <- parsed_syntax$model |
| 568 |
} |
|
| 569 | ||
| 570 |
# initial strip of leading/trailing whitespace, which can interfere with splitting on spaces |
|
| 571 |
# strsplit generates character(0) for empty strings, which causes problems in paste because paste actually includes it as a literal |
|
| 572 |
# example: paste(list(character(0), "asdf", character(0)), collapse=" ") |
|
| 573 |
# thus, use lapply to convert these to empty strings first |
|
| 574 | ! |
syntax <- paste(lapply(lav_mplus_trim(strsplit(syntax, "\n")), function(x) {
|
| 575 | ! |
if (length(x) == 0L && is.character(x)) "" else x |
| 576 | ! |
}), collapse = "\n") |
| 577 | ||
| 578 |
# replace ! with # for comment lines. Also strip newline and replace with semicolon |
|
| 579 | ! |
syntax <- gsub("(\\s*)!(.+)\n*", "\\1#\\2;", syntax, perl = TRUE)
|
| 580 | ||
| 581 |
# new direction: retain newlines in parsed syntax until after constraints have been parsed |
|
| 582 | ||
| 583 |
# delete newlines |
|
| 584 |
# syntax <- gsub("\n", "", syntax, fixed=TRUE)
|
|
| 585 | ||
| 586 |
# replace semicolons with newlines prior to split (divide into commands) |
|
| 587 |
# syntax <- gsub(";", "\n", syntax, fixed=TRUE)
|
|
| 588 | ||
| 589 |
# split into vector of strings |
|
| 590 |
# syntax.split <- unlist( strsplit(syntax, "\n") ) |
|
| 591 | ! |
syntax.split <- lav_mplus_trim(unlist(strsplit(syntax, ";"))) |
| 592 | ||
| 593 |
# format of parTable to mimic. |
|
| 594 |
# 'data.frame': 34 obs. of 12 variables: |
|
| 595 |
# $ id : int 1 2 3 4 5 6 7 8 9 10 ... |
|
| 596 |
# $ lhs : chr "ind60" "ind60" "ind60" "dem60" ... |
|
| 597 |
# $ op : chr "=~" "=~" "=~" "=~" ... |
|
| 598 |
# $ rhs : chr "x1" "x2" "x3" "y1" ... |
|
| 599 |
# $ user : int 1 1 1 1 1 1 1 1 1 1 ... |
|
| 600 |
# $ group : int 1 1 1 1 1 1 1 1 1 1 ... |
|
| 601 |
# $ free : int 0 1 2 0 3 4 5 0 6 7 ... |
|
| 602 |
# $ ustart: num 1 NA NA 1 NA NA NA 1 NA NA ... |
|
| 603 |
# $ exo : int 0 0 0 0 0 0 0 0 0 0 ... |
|
| 604 |
# $ label : chr "" "" "" "" ... |
|
| 605 |
# $ eq.id : int 0 0 0 0 0 0 0 0 0 0 ... |
|
| 606 |
# $ unco : int 0 1 2 0 3 4 5 0 6 7 ... |
|
| 607 | ||
| 608 |
# vector of lavaan syntax |
|
| 609 | ! |
lavaan.out <- c() |
| 610 | ||
| 611 | ! |
for (cmd in syntax.split) {
|
| 612 | ! |
if (grepl("^\\s*#", cmd, perl = TRUE)) { # comment line
|
| 613 | ! |
lavaan.out <- c(lavaan.out, gsub("\n", "", cmd, fixed = TRUE)) # drop any newlines (otherwise done by lav_mplus_cmd_constraints)
|
| 614 | ! |
} else if (grepl("^\\s*$", cmd, perl = TRUE)) {
|
| 615 |
# do nothing, just a space or blank line |
|
| 616 |
} else {
|
|
| 617 |
# hyphen expansion |
|
| 618 | ! |
cmd <- lav_mplus_expand_cmd(cmd) |
| 619 | ||
| 620 |
# parse fixed parameters and starting values |
|
| 621 | ! |
cmd <- lav_mplus_cmd_fix_start(cmd) |
| 622 | ||
| 623 |
# parse any constraints here (avoid weird logic below) |
|
| 624 | ! |
cmd <- lav_mplus_cmd_constraints(cmd) |
| 625 | ||
| 626 | ! |
if ((op <- regexpr("\\s+(by|on|with|pwith)\\s+", cmd, ignore.case = TRUE, perl = TRUE))[1L] > 0) { # regressions, factors, covariances
|
| 627 | ||
| 628 | ! |
lhs <- substr(cmd, 1, op - 1) # using op takes match.start which will omit spaces before operator |
| 629 | ! |
rhs <- substr(cmd, op + attr(op, "match.length"), nchar(cmd)) |
| 630 | ! |
operator <- tolower(substr(cmd, attr(op, "capture.start"), attr(op, "capture.start") + attr(op, "capture.length") - 1)) |
| 631 | ||
| 632 | ! |
if (operator == "by") {
|
| 633 | ! |
lav.operator <- "=~" |
| 634 | ! |
} else if (operator == "with" || operator == "pwith") {
|
| 635 | ! |
lav.operator <- "~~" |
| 636 | ! |
} else if (operator == "on") {
|
| 637 | ! |
lav.operator <- "~" |
| 638 |
} |
|
| 639 | ||
| 640 |
# handle parameter combinations |
|
| 641 | ! |
lhs.split <- strsplit(lhs, "\\s+")[[1]] # lav_mplus_trim( |
| 642 | ||
| 643 |
# handle pwith syntax |
|
| 644 | ! |
if (operator == "pwith") {
|
| 645 |
# TODO: Figure out if pwith can be paired with constraints? |
|
| 646 | ||
| 647 | ! |
rhs.split <- strsplit(rhs, "\\s+")[[1]] # lav_mplus_trim( |
| 648 | ! |
if (length(lhs.split) != length(rhs.split)) {
|
| 649 | ! |
browser() |
| 650 | ! |
lav_msg_stop(gettext( |
| 651 | ! |
"PWITH command does not have the same number of arguments on |
| 652 | ! |
the left and right sides.")) |
| 653 |
} |
|
| 654 | ||
| 655 | ! |
cmd <- sapply(1:length(lhs.split), function(i) paste(lhs.split[i], lav.operator, rhs.split[i])) |
| 656 |
} else {
|
|
| 657 |
# insert plus signs on the rhs as long as it isn't preceded or followed by a plus already |
|
| 658 | ! |
rhs <- gsub("(?<!\\+)\\s+(?!\\+)", " + ", rhs, perl = TRUE)
|
| 659 | ||
| 660 | ! |
if (length(lhs.split) > 1L) {
|
| 661 |
# expand using possible combinations |
|
| 662 | ! |
cmd <- sapply(lhs.split, function(larg) {
|
| 663 | ! |
pair <- paste(larg, lav.operator, rhs) |
| 664 | ! |
return(pair) |
| 665 |
}) |
|
| 666 |
} else {
|
|
| 667 | ! |
cmd <- paste(lhs, lav.operator, rhs) |
| 668 |
} |
|
| 669 |
} |
|
| 670 | ! |
} else if ((means.scales <- regexpr("^\\s*([\\[\\{])([^\\]\\}]+)[\\]\\}]\\s*$", cmd, ignore.case = TRUE, perl = TRUE))[1L] > 0) { # intercepts/means or scales
|
| 671 |
# first capture is the operator: [ or {
|
|
| 672 | ! |
operator <- substr(cmd, attr(means.scales, "capture.start")[1L], attr(means.scales, "capture.start")[1L] + attr(means.scales, "capture.length")[1L] - 1) |
| 673 | ||
| 674 | ! |
params <- substr(cmd, attr(means.scales, "capture.start")[2L], attr(means.scales, "capture.start")[2L] + attr(means.scales, "capture.length")[2L] - 1) |
| 675 | ||
| 676 |
# obtain parameters with no modifiers specified for LHS |
|
| 677 | ! |
params.noModifiers <- sub("^\\s*[\\[\\{]([^\\]\\}]+)[\\]\\}]\\s*$", "\\1", attr(cmd, "noModifiers"), perl = TRUE)
|
| 678 | ||
| 679 | ! |
means.scales.split <- strsplit(params, "\\s+")[[1]] # lav_mplus_trim( |
| 680 | ! |
means.scales.noModifiers.split <- strsplit(params.noModifiers, "\\s+")[[1]] # lav_mplus_trim( |
| 681 | ||
| 682 | ! |
if (operator == "[") {
|
| 683 |
# Tricky syntax shift (and corresponding kludge). For means, need to put constraint on RHS as pre-multiplier of 1 (e.g., x1 ~ 5*1). |
|
| 684 |
# But lav_mplus_cmd_constraints returns constraints multiplied by parameters |
|
| 685 | ! |
cmd <- sapply(means.scales.split, function(v) {
|
| 686 |
# shift pre-multiplier |
|
| 687 | ! |
if ((premult <- regexpr("([^\\*]+\\*[^\\*]+)\\*([^\\*]+)", v, perl = TRUE))[1L] > 0) { # double modifier: label and constraint
|
| 688 | ! |
modifier <- substr(v, attr(premult, "capture.start")[1L], attr(premult, "capture.start")[1L] + attr(premult, "capture.length")[1L] - 1) |
| 689 | ! |
paramName <- substr(v, attr(premult, "capture.start")[2L], attr(premult, "capture.start")[2L] + attr(premult, "capture.length")[2L] - 1) |
| 690 | ! |
paste0(paramName, " ~ ", modifier, "*1") |
| 691 | ! |
} else if ((premult <- regexpr("([^\\*]+)\\*([^\\*]+)", v, perl = TRUE))[1L] > 0) {
|
| 692 | ! |
modifier <- substr(v, attr(premult, "capture.start")[1L], attr(premult, "capture.start")[1L] + attr(premult, "capture.length")[1L] - 1) |
| 693 | ! |
paramName <- substr(v, attr(premult, "capture.start")[2L], attr(premult, "capture.start")[2L] + attr(premult, "capture.length")[2L] - 1) |
| 694 | ! |
paste0(paramName, " ~ ", modifier, "*1") |
| 695 |
} else {
|
|
| 696 | ! |
paste(v, "~ 1") |
| 697 |
} |
|
| 698 |
}) |
|
| 699 | ! |
} else if (operator == "{") {
|
| 700 |
# only include constraints on RHS |
|
| 701 | ! |
cmd <- sapply(1:length(means.scales.split), function(v) paste(means.scales.noModifiers.split[v], "~*~", means.scales.split[v])) |
| 702 |
} else {
|
|
| 703 | ! |
lav_msg_stop(gettext("What's the operator?!"))
|
| 704 |
} |
|
| 705 | ! |
} else if (grepl("|", cmd, fixed = TRUE)) {
|
| 706 |
# expand growth modeling language |
|
| 707 | ! |
cmd <- lav_mplus_cmd_growth(cmd) |
| 708 |
} else { # no operator, no means, must be variance.
|
|
| 709 |
# cat("assuming vars: ", cmd, "\n")
|
|
| 710 | ||
| 711 | ! |
vars.lhs <- strsplit(attr(cmd, "noModifiers"), "\\s+")[[1]] # lav_mplus_trim( |
| 712 | ! |
vars.rhs <- strsplit(cmd, "\\s+")[[1]] # lav_mplus_trim( |
| 713 | ||
| 714 | ! |
cmd <- sapply(1:length(vars.lhs), function(v) paste(vars.lhs[v], "~~", vars.rhs[v])) |
| 715 |
} |
|
| 716 | ||
| 717 |
# handle threshold substitution: $ -> | |
|
| 718 | ! |
cmd <- gsub("$", "|", cmd, fixed = TRUE)
|
| 719 | ||
| 720 |
# if we have both starting/fixed values and constraints, these must be handled by separate commands. |
|
| 721 |
# starting and fixed values are already handled in the pipeline by this point, so should be evident in the command |
|
| 722 |
# bfi BY lab1*start(1)*bfi_1 ==> bfi BY lab1*bfi_1 + start(1)*bfi_1 |
|
| 723 | ! |
double_asterisks <- grepl("\\s*[\\w\\(\\)\\.]+\\*[\\w\\(\\)\\.]+\\*[\\w\\(\\)\\.]+", cmd, perl = TRUE)
|
| 724 | ||
| 725 | ! |
if (isTRUE(double_asterisks[1])) {
|
| 726 | ! |
ss <- strsplit(cmd, "*", fixed = TRUE)[[1]] |
| 727 | ! |
if (length(ss) != 3) {
|
| 728 | ! |
lav_msg_warn(gettext("problem interpreting double asterisk syntax:"),
|
| 729 | ! |
cmd) # sanity check on my logic |
| 730 |
} else {
|
|
| 731 | ! |
cmd <- paste0(ss[1], "*", ss[3], " + ", ss[2], "*", ss[3]) |
| 732 |
} |
|
| 733 |
} |
|
| 734 | ||
| 735 | ! |
lavaan.out <- c(lavaan.out, cmd) |
| 736 |
} |
|
| 737 |
} |
|
| 738 | ||
| 739 |
# new threshold syntax shifts things to the form: |
|
| 740 |
# VAR | t1 + t2 + t3 (left to write ordering) |
|
| 741 |
# Parameter labels, fixed values, and starting values are tacked on in the usual way, like |
|
| 742 |
# VAR | 5*t1 + start(1.5)*t2 + par_label*t3 (left to write ordering) |
|
| 743 | ||
| 744 | ! |
thresh_lines <- grep("^\\s*[A-z]+\\w*\\|\\d+", lavaan.out, perl = TRUE)
|
| 745 | ! |
if (length(thresh_lines) > 0L) {
|
| 746 | ! |
thresh_vars <- unname(sub("^\\s*([A-z]+\\w*).*", "\\1", lavaan.out[thresh_lines], perl = TRUE))
|
| 747 | ! |
thresh_split <- split(thresh_lines, thresh_vars) |
| 748 | ! |
drop_elements <- c() |
| 749 | ! |
for (i in seq_along(thresh_split)) {
|
| 750 | ! |
this_set <- lavaan.out[thresh_split[[i]]] |
| 751 | ! |
tnum <- as.integer(sub("^\\s*[A-z]+\\w*\\|(\\d+)\\s*.*", "\\1", this_set))
|
| 752 | ! |
this_set <- this_set[order(tnum)] # ensure that threshold numbering matches ascending order |
| 753 | ! |
this_set <- sub("[^~]+\\s*~\\s*", "", this_set, perl = T) # drop variable and ~
|
| 754 | ||
| 755 |
# convert to new t1, t2 syntax by combining modifiers with threshold numbers |
|
| 756 | ! |
this_set <- sapply(seq_along(this_set), function(j) {
|
| 757 |
# gsub("[^~]+\\s*~\\s*([\\w\\.\\-]+\\*)*1", paste0("\\1t", j), this_set[j], perl=TRUE)
|
|
| 758 | ! |
gsub("([\\w\\.\\-]+\\*)*1", paste0("\\1t", j), this_set[j], perl = TRUE)
|
| 759 |
}) |
|
| 760 | ||
| 761 | ! |
new_str <- paste(names(thresh_split)[i], "|", paste(this_set, collapse = " + ")) |
| 762 |
# replace in model string on the first line having relevant syntax |
|
| 763 | ! |
lavaan.out[thresh_split[[i]][1]] <- new_str |
| 764 | ! |
drop_elements <- c(drop_elements, thresh_split[[i]][-1]) |
| 765 |
} |
|
| 766 | ! |
lavaan.out <- lavaan.out[-drop_elements] |
| 767 |
} |
|
| 768 | ||
| 769 | ||
| 770 |
# tack on constraint syntax, if included |
|
| 771 | ! |
lavaan.out <- c(lavaan.out, con_syntax) |
| 772 | ||
| 773 |
# for now, include a final lav_mplus_trim call since some arguments have leading/trailing space stripped. |
|
| 774 | ! |
wrap <- paste(lav_mplus_cmd_wrap(lavaan.out, width = 90, exdent = 5), collapse = "\n") # lav_mplus_trim( |
| 775 | ! |
return(wrap) |
| 776 |
} |
|
| 777 | ||
| 778 |
lav_mplus_lavaan <- function(inpfile, run = TRUE) {
|
|
| 779 | ! |
stopifnot(length(inpfile) == 1L) |
| 780 | ! |
stopifnot(grepl("\\.inp$", inpfile, ignore.case = TRUE))
|
| 781 | ! |
if (!file.exists(inpfile)) {
|
| 782 | ! |
lav_msg_stop(gettext("Could not find file:"), inpfile)
|
| 783 |
} |
|
| 784 | ||
| 785 |
# for future consideration. For now, require a .inp file |
|
| 786 |
# if (length(inpfile) == 1L && grepl("\\.inp$", inpfile)) {
|
|
| 787 |
# if (!file.exists(inpfile)) { stop("Could not find file: ", inpfile) }
|
|
| 788 |
# inpfile.text <- scan(inpfile, what="character", sep="\n", strip.white=FALSE, blank.lines.skip=FALSE, quiet=TRUE) |
|
| 789 |
# } else {
|
|
| 790 |
# #assume that inpfile itself is syntax (e.g., in a character vector) |
|
| 791 |
# inpfile.text <- inpfile |
|
| 792 |
# } |
|
| 793 | ||
| 794 | ! |
inpfile.text <- scan(inpfile, what = "character", sep = "\n", strip.white = FALSE, blank.lines.skip = FALSE, quiet = TRUE) |
| 795 | ! |
sections <- lav_mplus_text_sections(inpfile.text, inpfile) |
| 796 | ||
| 797 | ! |
mplus.inp <- list() |
| 798 | ||
| 799 | ! |
mplus.inp$title <- lav_mplus_trim(paste(sections$title, collapse = " ")) |
| 800 | ! |
mplus.inp$data <- lav_mplus_text_fields(sections$data, required = "file") |
| 801 | ! |
mplus.inp$variable <- lav_mplus_text_fields(sections$variable, required = "names") |
| 802 | ! |
mplus.inp$analysis <- lav_mplus_text_fields(sections$analysis) |
| 803 | ||
| 804 | ! |
meanstructure <- "default" # lavaan default |
| 805 | ! |
if (!is.null(mplus.inp$analysis$model)) {
|
| 806 | ! |
if (tolower(mplus.inp$analysis$model) == "nomeanstructure") {
|
| 807 | ! |
meanstructure <- FALSE |
| 808 |
} # explicitly disable mean structure |
|
| 809 |
} |
|
| 810 | ||
| 811 | ! |
information <- "default" # lavaan default |
| 812 | ! |
if (!is.null(mplus.inp$analysis$information)) {
|
| 813 | ! |
information <- tolower(mplus.inp$analysis$information) |
| 814 |
} |
|
| 815 | ||
| 816 | ! |
estimator <- "default" |
| 817 | ! |
if (!is.null(est <- mplus.inp$analysis$estimator)) {
|
| 818 |
# no memory of what this is up to.... |
|
| 819 | ! |
if (toupper(est) == "MUML") lav_msg_warn(gettext( |
| 820 | ! |
"Mplus does not support MUML estimator. Using default instead.")) |
| 821 | ! |
estimator <- est |
| 822 | ||
| 823 |
# march 2013: handle case where categorical data are specified, but ML-based estimator requested. |
|
| 824 |
# use WLSMV instead |
|
| 825 | ! |
if (!is.null(mplus.inp$variable$categorical) && toupper(substr(mplus.inp$analysis$estimator, 1, 2)) == "ML") {
|
| 826 | ! |
lav_msg_warn(gettext( |
| 827 | ! |
"Lavaan does not yet support ML-based estimation for categorical data. |
| 828 | ! |
Reverting to WLSMV")) |
| 829 | ! |
estimator <- "WLSMV" |
| 830 |
} |
|
| 831 |
} |
|
| 832 | ||
| 833 |
# expand hyphens in variable names and split into vector that will be the names for read.table |
|
| 834 | ! |
mplus.inp$variable$names <- strsplit(lav_mplus_expand_cmd(mplus.inp$variable$names), "\\s+", perl = TRUE)[[1]] |
| 835 | ||
| 836 |
# expand hyphens in categorical declaration |
|
| 837 | ! |
if (!is.null(mplus.inp$variable$categorical)) mplus.inp$variable$categorical <- strsplit(lav_mplus_expand_cmd(mplus.inp$variable$categorical), "\\s+", perl = TRUE)[[1]] |
| 838 | ||
| 839 |
# convert mplus syntax to lavaan syntax |
|
| 840 | ! |
mplus.inp$model <- lav_mplus_syntax_model(sections$model) |
| 841 | ||
| 842 |
# handle model constraint |
|
| 843 | ! |
if ("model.constraint" %in% names(sections)) {
|
| 844 | ! |
mplus.inp$model.constraint <- lav_mplus_syntax_constraints(sections$model.constraint) |
| 845 | ! |
mplus.inp$model <- paste(mplus.inp$model, mplus.inp$model.constraint, sep = "\n") |
| 846 |
} |
|
| 847 | ||
| 848 |
# read mplus data (and handle missing spec) |
|
| 849 | ! |
mplus.inp$data <- lav_mplus_path_data(mplus.inp, inpfile) |
| 850 | ||
| 851 |
# handle bootstrapping specification |
|
| 852 | ! |
se <- "default" |
| 853 | ! |
bootstrap <- 1000L |
| 854 | ! |
test <- "default" |
| 855 | ! |
if (!is.null(mplus.inp$analysis$bootstrap)) {
|
| 856 | ! |
boot.type <- "standard" |
| 857 |
# check whether standard versus residual bootstrap is specified |
|
| 858 | ! |
if ((boot.match <- regexpr("\\((\\w+)\\)", mplus.inp$analysis$bootstrap, perl = TRUE)) > 0L) {
|
| 859 | ! |
boot.type <- tolower(substr(mplus.inp$analysis$bootstrap, attr(boot.match, "capture.start"), attr(boot.match, "capture.start") + attr(boot.match, "capture.length") - 1L)) |
| 860 |
} |
|
| 861 | ||
| 862 | ! |
if (boot.type == "residual") test <- "Bollen.Stine" |
| 863 | ||
| 864 | ! |
se <- "bootstrap" |
| 865 | ||
| 866 | ! |
if ((nboot.match <- regexpr("^\\s*(\\d+)", mplus.inp$analysis$bootstrap, perl = TRUE)) > 0L) {
|
| 867 | ! |
bootstrap <- as.numeric(substr(mplus.inp$analysis$bootstrap, attr(nboot.match, "capture.start"), attr(nboot.match, "capture.start") + attr(nboot.match, "capture.length") - 1L)) |
| 868 |
} |
|
| 869 |
} |
|
| 870 | ||
| 871 | ! |
if (run) {
|
| 872 | ! |
fit <- sem(mplus.inp$model, data = mplus.inp$data, meanstructure = meanstructure, mimic = "Mplus", estimator = estimator, test = test, se = se, bootstrap = bootstrap, information = information) |
| 873 | ! |
fit@external <- list(mplus.inp = mplus.inp) |
| 874 |
} else {
|
|
| 875 | ! |
fit <- mplus.inp # just return the syntax outside of a lavaan object |
| 876 |
} |
|
| 877 | ||
| 878 | ! |
return(fit) |
| 879 |
} |
|
| 880 | ||
| 881 | ||
| 882 |
lav_mplus_text_fields <- function(section.text, required) {
|
|
| 883 | ! |
if (is.null(section.text)) {
|
| 884 | ! |
return(NULL) |
| 885 |
} |
|
| 886 | ||
| 887 |
# The parser breaks down when there is a line with a trailing comment because then splitting on semicolon will combine it with the following line |
|
| 888 |
# Thus, trim off trailing comments before initial split |
|
| 889 | ! |
section.text <- gsub("\\s*!.*$", "", section.text, perl = TRUE)
|
| 890 | ! |
section.split <- strsplit(paste(section.text, collapse = " "), ";", fixed = TRUE)[[1]] # split on semicolons |
| 891 | ! |
section.divide <- list() |
| 892 | ||
| 893 | ! |
for (cmd in section.split) {
|
| 894 | ! |
if (grepl("^\\s*!.*", cmd, perl = TRUE)) next # skip comment lines
|
| 895 | ! |
if (grepl("^\\s+$", cmd, perl = TRUE)) next # skip blank lines
|
| 896 | ||
| 897 |
# mplus is apparently tolerant of specifications that don't include IS/ARE/= |
|
| 898 |
# example: usevariables x1-x10; |
|
| 899 |
# thus, split on spaces and assume that first element is lhs, drop second element if IS/ARE/=, and assume remainder is rhs |
|
| 900 | ||
| 901 |
# but if user uses equals sign, then spaces will not always be present (e.g., usevariables=x1-x10) |
|
| 902 | ! |
if ((leadingEquals <- regexpr("^\\s*[A-Za-z]+[A-Za-z_-]*\\s*(=)", cmd[1L], perl = TRUE))[1L] > 0) {
|
| 903 | ! |
cmdName <- lav_mplus_trim(substr(cmd[1L], 1, attr(leadingEquals, "capture.start") - 1)) |
| 904 | ! |
cmdArgs <- lav_mplus_trim(substr(cmd[1L], attr(leadingEquals, "capture.start") + 1, nchar(cmd[1L]))) |
| 905 |
} else {
|
|
| 906 | ! |
cmd.spacesplit <- strsplit(lav_mplus_trim(cmd[1L]), "\\s+", perl = TRUE)[[1L]] |
| 907 | ||
| 908 | ! |
if (length(cmd.spacesplit) < 2L) {
|
| 909 |
# for future: make room for this function to prase things like just TECH13 (no rhs) |
|
| 910 |
} else {
|
|
| 911 | ! |
cmdName <- lav_mplus_trim(cmd.spacesplit[1L]) |
| 912 | ! |
if (length(cmd.spacesplit) > 2L && tolower(cmd.spacesplit[2L]) %in% c("is", "are")) {
|
| 913 | ! |
cmdArgs <- paste(cmd.spacesplit[3L:length(cmd.spacesplit)], collapse = " ") # remainder, removing is/are |
| 914 |
} else {
|
|
| 915 | ! |
cmdArgs <- paste(cmd.spacesplit[2L:length(cmd.spacesplit)], collapse = " ") # is/are not used, so just join rhs |
| 916 |
} |
|
| 917 |
} |
|
| 918 |
} |
|
| 919 | ||
| 920 | ! |
section.divide[[make.names(tolower(cmdName))]] <- cmdArgs |
| 921 |
} |
|
| 922 | ||
| 923 | ! |
if (!missing(required)) {
|
| 924 | ! |
stopifnot(all(required %in% names(section.divide))) |
| 925 |
} |
|
| 926 | ! |
return(section.divide) |
| 927 |
} |
|
| 928 | ||
| 929 |
# helper function |
|
| 930 |
lav_mplus_path_splitted <- function(abspath) {
|
|
| 931 |
# function to split path into path and filename |
|
| 932 |
# code adapted from R.utils filePath command |
|
| 933 | ! |
if (!is.character(abspath)) lav_msg_stop(gettext( |
| 934 | ! |
"Path not a character string")) |
| 935 | ! |
if (nchar(abspath) < 1 || is.na(abspath)) lav_msg_stop(gettext( |
| 936 | ! |
"Path is missing or of zero length")) |
| 937 | ||
| 938 | ! |
components <- strsplit(abspath, split = "[\\/]")[[1]] |
| 939 | ! |
lcom <- length(components) |
| 940 | ||
| 941 | ! |
stopifnot(lcom > 0) |
| 942 | ||
| 943 |
# the file is the last element in the list. In the case of length == 1, this will extract the only element. |
|
| 944 | ! |
relFilename <- components[lcom] |
| 945 | ! |
absolute <- FALSE |
| 946 | ||
| 947 | ! |
if (lcom == 1) {
|
| 948 | ! |
dirpart <- NA_character_ |
| 949 | ! |
} else if (lcom > 1) {
|
| 950 |
# drop the file from the list (the last element) |
|
| 951 | ! |
components <- components[-lcom] |
| 952 | ! |
dirpart <- do.call("file.path", as.list(components))
|
| 953 | ||
| 954 |
# if path begins with C:, /, //, or \\, then treat as absolute |
|
| 955 | ! |
if (grepl("^([A-Z]{1}:|/|//|\\\\)+.*$", dirpart, perl = TRUE)) absolute <- TRUE
|
| 956 |
} |
|
| 957 | ||
| 958 | ! |
return(list(directory = dirpart, filename = relFilename, absolute = absolute)) |
| 959 |
} |
|
| 960 | ||
| 961 |
lav_mplus_path_data <- function(mplus.inp, inpfile) {
|
|
| 962 |
# handle issue of lav_mplus_lavaan being called with an absolute path, whereas mplus has only a local data file |
|
| 963 | ! |
inpfile.split <- lav_mplus_path_splitted(inpfile) |
| 964 | ! |
datfile.split <- lav_mplus_path_splitted(mplus.inp$data$file) |
| 965 | ||
| 966 |
# if inp file target directory is non-empty, but mplus data is without directory, then append |
|
| 967 |
# inp file directory to mplus data. This ensures that R need not be in the working directory |
|
| 968 |
# to read the dat file. But if mplus data has an absolute directory, don't append |
|
| 969 | ||
| 970 |
# if mplus data directory is present and absolute, or if no directory in input file, just use filename as is |
|
| 971 | ! |
if (!is.na(datfile.split$directory) && datfile.split$absolute) {
|
| 972 | ! |
datFile <- mplus.inp$data$file |
| 973 |
} # just use mplus data filename if it has absolute path |
|
| 974 | ! |
else if (is.na(inpfile.split$directory)) {
|
| 975 | ! |
datFile <- mplus.inp$data$file |
| 976 |
} # just use mplus data filename if inp file is missing path (working dir) |
|
| 977 |
else {
|
|
| 978 | ! |
datFile <- file.path(inpfile.split$directory, mplus.inp$data$file) |
| 979 |
} # dat file path is relative or absent, and inp file directory is present |
|
| 980 | ||
| 981 | ! |
if (!file.exists(datFile)) {
|
| 982 | ! |
lav_msg_warn(gettext("Cannot find data file:"), datFile)
|
| 983 | ! |
return(NULL) |
| 984 |
} |
|
| 985 | ||
| 986 |
# handle missing is/are: |
|
| 987 | ! |
missList <- NULL |
| 988 | ! |
if (!is.null(missSpec <- mplus.inp$variable$missing)) {
|
| 989 | ! |
expandMissVec <- function(missStr) {
|
| 990 |
# sub-function to obtain a vector of all missing values within a set of parentheses |
|
| 991 | ! |
missSplit <- strsplit(missStr, "\\s+")[[1L]] |
| 992 | ! |
missVals <- c() |
| 993 | ! |
for (f in missSplit) {
|
| 994 | ! |
if ((hyphenPos <- regexpr("\\d+(-)\\d+", f, perl = TRUE))[1L] > -1L) {
|
| 995 |
# expand hyphen |
|
| 996 | ! |
preHyphen <- substr(f, 1, attr(hyphenPos, "capture.start") - 1) |
| 997 | ! |
postHyphen <- substr(f, attr(hyphenPos, "capture.start") + 1, nchar(f)) |
| 998 | ! |
missVals <- c(missVals, as.character(seq(preHyphen, postHyphen))) |
| 999 |
} else {
|
|
| 1000 |
# append to vector |
|
| 1001 | ! |
missVals <- c(missVals, f) |
| 1002 |
} |
|
| 1003 |
} |
|
| 1004 | ! |
return(as.numeric(missVals)) |
| 1005 |
} |
|
| 1006 | ||
| 1007 | ! |
if (missSpec == "." || missSpec == "*") { # case 1: MISSING ARE|=|IS .;
|
| 1008 | ! |
na.strings <- missSpec |
| 1009 | ! |
} else if ((allMatch <- regexpr("\\s*ALL\\s*\\(([^\\)]+)\\)", missSpec, perl = TRUE))[1L] > -1L) { # case 2: use of ALL with parens
|
| 1010 | ! |
missStr <- lav_mplus_trim(substr(missSpec, attr(allMatch, "capture.start"), attr(allMatch, "capture.start") + attr(allMatch, "capture.length") - 1L)) |
| 1011 | ! |
na.strings <- expandMissVec(missStr) |
| 1012 |
} else { # case 3: specific missing values per variable
|
|
| 1013 |
# process each element |
|
| 1014 | ! |
missBlocks <- gregexpr("(?:(\\w+)\\s+\\(([^\\)]+)\\))+", missSpec, perl = TRUE)[[1]]
|
| 1015 | ! |
missList <- list() |
| 1016 | ||
| 1017 | ! |
if (missBlocks[1L] > -1L) {
|
| 1018 | ! |
for (i in 1:length(missBlocks)) {
|
| 1019 | ! |
vname <- substr(missSpec, attr(missBlocks, "capture.start")[i, 1L], attr(missBlocks, "capture.start")[i, 1L] + attr(missBlocks, "capture.length")[i, 1L] - 1L) |
| 1020 | ! |
vmiss <- substr(missSpec, attr(missBlocks, "capture.start")[i, 2L], attr(missBlocks, "capture.start")[i, 2L] + attr(missBlocks, "capture.length")[i, 2L] - 1L) |
| 1021 | ||
| 1022 | ! |
vnameHyphen <- regexpr("(\\w+)-(\\w+)", vname, perl = TRUE)[1L]
|
| 1023 | ! |
if (vnameHyphen > -1L) {
|
| 1024 |
# lookup against variable names |
|
| 1025 | ! |
vstart <- which(mplus.inp$variable$names == substr(vname, attr(vnameHyphen, "capture.start")[1L], attr(vnameHyphen, "capture.start")[1L] + attr(vnameHyphen, "capture.length")[1L] - 1L)) |
| 1026 | ! |
vend <- which(mplus.inp$variable$names == substr(vname, attr(vnameHyphen, "capture.start")[2L], attr(vnameHyphen, "capture.start")[2L] + attr(vnameHyphen, "capture.length")[2L] - 1L)) |
| 1027 | ! |
if (length(vstart) == 0L || length(vend) == 0L) {
|
| 1028 | ! |
lav_msg_stop(gettext("Unable to lookup missing variable list: "),
|
| 1029 | ! |
vname) |
| 1030 |
} |
|
| 1031 |
# I suppose start or finish could be mixed up |
|
| 1032 | ! |
if (vstart > vend) {
|
| 1033 | ! |
vstart.orig <- vstart |
| 1034 | ! |
vstart <- vend |
| 1035 | ! |
vend <- vstart.orig |
| 1036 |
} |
|
| 1037 | ! |
vname <- mplus.inp$variable$names[vstart:vend] |
| 1038 |
} |
|
| 1039 | ||
| 1040 | ! |
missVals <- expandMissVec(vmiss) |
| 1041 | ||
| 1042 | ! |
for (j in 1:length(vname)) {
|
| 1043 | ! |
missList[[vname[j]]] <- missVals |
| 1044 |
} |
|
| 1045 |
} |
|
| 1046 |
} else {
|
|
| 1047 | ! |
lav_msg_stop(gettext("I don't understand this missing specification:"),
|
| 1048 | ! |
missSpec) |
| 1049 |
} |
|
| 1050 |
} |
|
| 1051 |
} else {
|
|
| 1052 | ! |
na.strings <- "NA" |
| 1053 |
} |
|
| 1054 | ||
| 1055 | ! |
if (!is.null(missList)) {
|
| 1056 | ! |
dat <- read.table(datFile, header = FALSE, col.names = mplus.inp$variable$names, colClasses = "numeric") |
| 1057 |
# loop over variables in missList and set missing values to NA |
|
| 1058 | ! |
dat[, names(missList)] <- lapply(names(missList), function(vmiss) {
|
| 1059 | ! |
dat[which(dat[, vmiss] %in% missList[[vmiss]]), vmiss] <- NA |
| 1060 | ! |
return(dat[, vmiss]) |
| 1061 |
}) |
|
| 1062 | ||
| 1063 | ! |
names(dat) <- mplus.inp$variable$names # loses these from the lapply |
| 1064 |
} else {
|
|
| 1065 | ! |
dat <- read.table(datFile, header = FALSE, col.names = mplus.inp$variable$names, na.strings = na.strings, colClasses = "numeric") |
| 1066 |
} |
|
| 1067 | ||
| 1068 | ||
| 1069 |
# TODO: support covariance/mean+cov inputs |
|
| 1070 | ||
| 1071 |
# store categorical variables as ordered factors |
|
| 1072 | ! |
if (!is.null(mplus.inp$variable$categorical)) {
|
| 1073 | ! |
dat[, c(mplus.inp$variable$categorical)] <- lapply(dat[, c(mplus.inp$variable$categorical), drop = FALSE], ordered) |
| 1074 |
} |
|
| 1075 | ||
| 1076 | ! |
return(dat) |
| 1077 |
} |
|
| 1078 | ||
| 1079 | ||
| 1080 |
lav_mplus_text_sections <- function(inpfile.text, filename) {
|
|
| 1081 | ! |
inputHeaders <- grep("^\\s*(title:|data.*:|variable:|define:|analysis:|model.*:|output:|savedata:|plot:|montecarlo:)", inpfile.text, ignore.case = TRUE, perl = TRUE)
|
| 1082 | ||
| 1083 | ! |
stopifnot(length(inputHeaders) > 0L) |
| 1084 | ||
| 1085 | ! |
mplus.sections <- list() |
| 1086 | ||
| 1087 | ! |
for (h in 1:length(inputHeaders)) {
|
| 1088 | ! |
sectionEnd <- ifelse(h < length(inputHeaders), inputHeaders[h + 1] - 1, length(inpfile.text)) |
| 1089 | ! |
section <- inpfile.text[inputHeaders[h]:sectionEnd] |
| 1090 | ! |
sectionName <- lav_mplus_trim(sub("^([^:]+):.*$", "\\1", section[1L], perl = TRUE)) # obtain text before the colon
|
| 1091 | ||
| 1092 |
# dump section name from input syntax |
|
| 1093 | ! |
section[1L] <- sub("^[^:]+:(.*)$", "\\1", section[1L], perl = TRUE)
|
| 1094 | ||
| 1095 | ! |
mplus.sections[[make.names(tolower(sectionName))]] <- section |
| 1096 |
} |
|
| 1097 | ||
| 1098 | ! |
return(mplus.sections) |
| 1099 |
} |
| 1 |
# the multivariate normal distribution + missing values |
|
| 2 |
# (so-called 'FIML') |
|
| 3 | ||
| 4 |
# 1) loglikelihood (from raw data, or sample statitics) |
|
| 5 |
# 2) derivatives with respect to mu, Sigma, vech(Sigma) |
|
| 6 |
# 3) casewise scores with respect to mu, vech(Sigma), mu + vech(Sigma) |
|
| 7 |
# 4) hessian of mu + vech(Sigma) |
|
| 8 |
# 5) (unit) information of mu + vech(Sigma) |
|
| 9 |
# 5a: (unit) expected information |
|
| 10 |
# 5b: (unit) observed information |
|
| 11 |
# 5c: (unit) first.order information |
|
| 12 |
# 5d: lav_mvnorm_missing_information_both (both observed + first.order) |
|
| 13 | ||
| 14 |
# 6) inverted information h0 mu + vech(Sigma) |
|
| 15 |
# 6a: / |
|
| 16 |
# 6b: / |
|
| 17 |
# 6c: / |
|
| 18 |
# 7) ACOV h0 mu + vech(Sigma) |
|
| 19 |
# 7a: 1/N * inverted expected information |
|
| 20 |
# 7b: 1/N * inverted observed information |
|
| 21 |
# 7c: 1/N * inverted first-order information |
|
| 22 |
# 7d: sandwich acov |
|
| 23 | ||
| 24 |
# 10) additional functions |
|
| 25 |
# - lav_mvnorm_missing_impute_pattern |
|
| 26 |
# - lav_mvnorm_missing_estep |
|
| 27 | ||
| 28 | ||
| 29 |
# YR 09 Feb 2016: first version |
|
| 30 |
# YR 19 Mar 2017: 10) |
|
| 31 |
# YR 03 Okt 2018: a few functions gain a wt= argument |
|
| 32 |
# YR 01 Jul 2018: first_order functions gain cluster.idx= argument |
|
| 33 | ||
| 34 | ||
| 35 |
# 1) likelihood |
|
| 36 | ||
| 37 |
# 1a: input is raw data |
|
| 38 |
# - two strategies: 1) using missing patterns (pattern = TRUE) |
|
| 39 |
# 2) truly case per case (pattern = FALSE) |
|
| 40 |
# depending on the sample size, missing patterns, etc... one can be |
|
| 41 |
# (much) faster than the other |
|
| 42 |
lav_mvnorm_missing_loglik_data <- function(Y = NULL, |
|
| 43 |
Mu = NULL, |
|
| 44 |
wt = NULL, |
|
| 45 |
Sigma = NULL, |
|
| 46 |
x.idx = integer(0L), |
|
| 47 |
casewise = FALSE, |
|
| 48 |
pattern = TRUE, |
|
| 49 |
Sinv.method = "eigen", |
|
| 50 |
log2pi = TRUE, |
|
| 51 |
minus.two = FALSE) {
|
|
| 52 | ! |
if (pattern) {
|
| 53 | ! |
llik <- lav_mvnorm_missing_llik_pattern( |
| 54 | ! |
Y = Y, wt = wt, Mu = Mu, |
| 55 | ! |
Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, |
| 56 | ! |
log2pi = log2pi, minus.two = minus.two |
| 57 |
) |
|
| 58 |
} else {
|
|
| 59 | ! |
llik <- lav_mvnorm_missing_llik_casewise( |
| 60 | ! |
Y = Y, wt = wt, Mu = Mu, |
| 61 | ! |
Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, |
| 62 | ! |
log2pi = log2pi, minus.two = minus.two |
| 63 |
) |
|
| 64 |
} |
|
| 65 | ||
| 66 | ! |
if (casewise) {
|
| 67 | ! |
loglik <- llik |
| 68 |
} else {
|
|
| 69 | ! |
loglik <- sum(llik, na.rm = TRUE) |
| 70 |
} |
|
| 71 | ||
| 72 | ! |
loglik |
| 73 |
} |
|
| 74 | ||
| 75 |
# 1b: input are sample statistics (mean, cov, N) per pattern |
|
| 76 |
lav_mvnorm_missing_loglik_samplestats <- function(Yp = NULL, |
|
| 77 |
Mu = NULL, |
|
| 78 |
Sigma = NULL, |
|
| 79 |
x.idx = integer(0L), |
|
| 80 |
x.mean = NULL, |
|
| 81 |
x.cov = NULL, |
|
| 82 |
Sinv.method = "eigen", |
|
| 83 |
log2pi = TRUE, |
|
| 84 |
minus.two = FALSE) {
|
|
| 85 | 684x |
LOG.2PI <- log(2 * pi) |
| 86 | 684x |
pat.N <- length(Yp) |
| 87 | 684x |
P <- length(Yp[[1]]$var.idx) |
| 88 | ||
| 89 |
# global inverse + logdet |
|
| 90 | 684x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 91 | 684x |
S = Sigma, logdet = TRUE, |
| 92 | 684x |
Sinv.method = Sinv.method |
| 93 |
) |
|
| 94 | 684x |
Sigma.logdet <- attr(Sigma.inv, "logdet") |
| 95 | ||
| 96 |
# DIST/logdet per pattern |
|
| 97 | 684x |
DIST <- logdet <- P.LOG.2PI <- numeric(pat.N) |
| 98 | ||
| 99 |
# for each pattern, compute sigma.inv/logdet; compute DIST for all |
|
| 100 |
# observations of this pattern |
|
| 101 | 684x |
for (p in seq_len(pat.N)) {
|
| 102 |
# observed variables for this pattern |
|
| 103 | 1748x |
var.idx <- Yp[[p]]$var.idx |
| 104 | ||
| 105 |
# missing values for this pattern |
|
| 106 | 1748x |
na.idx <- which(!var.idx) |
| 107 | ||
| 108 |
# constant |
|
| 109 | 1748x |
P.LOG.2PI[p] <- sum(var.idx) * LOG.2PI * Yp[[p]]$freq |
| 110 | ||
| 111 |
# invert Sigma for this pattern |
|
| 112 | 1748x |
if (length(na.idx) > 0L) {
|
| 113 | 1064x |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 114 | 1064x |
S.inv = Sigma.inv, |
| 115 | 1064x |
rm.idx = na.idx, logdet = TRUE, S.logdet = Sigma.logdet |
| 116 |
) |
|
| 117 | 1064x |
logdet[p] <- attr(sigma.inv, "logdet") * Yp[[p]]$freq |
| 118 |
} else {
|
|
| 119 | 684x |
sigma.inv <- Sigma.inv |
| 120 | 684x |
logdet[p] <- Sigma.logdet * Yp[[p]]$freq |
| 121 |
} |
|
| 122 | ||
| 123 | 1748x |
TT <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx]) |
| 124 | 1748x |
DIST[p] <- sum(sigma.inv * TT) * Yp[[p]]$freq |
| 125 |
} |
|
| 126 | ||
| 127 |
# loglikelihood all data |
|
| 128 | 684x |
if (log2pi) {
|
| 129 | 40x |
loglik <- sum(-(P.LOG.2PI + logdet + DIST) / 2) |
| 130 |
} else {
|
|
| 131 | 644x |
loglik <- sum(-(logdet + DIST) / 2) |
| 132 |
} |
|
| 133 | ||
| 134 | 684x |
if (minus.two) {
|
| 135 | 644x |
loglik <- -2 * loglik |
| 136 |
} |
|
| 137 | ||
| 138 |
# x.idx |
|
| 139 | 684x |
if (length(x.idx) > 0L) {
|
| 140 | 30x |
stopifnot(!is.null(x.cov)) |
| 141 |
# Note: x.cov should be identical to Sigma[x.idx, x.idx] |
|
| 142 |
# so we don't really need x.cov |
|
| 143 | 30x |
N <- sum(sapply(Yp, "[[", "freq")) |
| 144 | 30x |
loglik.x <- lav_mvnorm_h1_loglik_samplestats( |
| 145 | 30x |
sample.cov = x.cov, |
| 146 | 30x |
sample.nobs = N |
| 147 |
) |
|
| 148 | ||
| 149 | 30x |
loglik <- loglik - loglik.x |
| 150 |
} |
|
| 151 | ||
| 152 | 684x |
loglik |
| 153 |
} |
|
| 154 | ||
| 155 |
## casewise loglikelihoods |
|
| 156 | ||
| 157 |
# casewise Sinv.method |
|
| 158 |
lav_mvnorm_missing_llik_casewise <- function(Y = NULL, |
|
| 159 |
wt = NULL, |
|
| 160 |
Mu = NULL, |
|
| 161 |
Sigma = NULL, |
|
| 162 |
x.idx = integer(0L), |
|
| 163 |
Sinv.method = "eigen", |
|
| 164 |
log2pi = TRUE, |
|
| 165 |
minus.two = FALSE) {
|
|
| 166 | ! |
P <- NCOL(Y) |
| 167 | ! |
LOG.2PI <- log(2 * pi) |
| 168 | ! |
Mu <- as.numeric(Mu) |
| 169 | ! |
if (!is.null(wt)) {
|
| 170 | ! |
N <- sum(wt) |
| 171 |
} else {
|
|
| 172 | ! |
N <- NROW(Y) |
| 173 |
} |
|
| 174 | ! |
NY <- NROW(Y) |
| 175 | ||
| 176 |
# global inverse + logdet |
|
| 177 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 178 | ! |
S = Sigma, logdet = TRUE, |
| 179 | ! |
Sinv.method = Sinv.method |
| 180 |
) |
|
| 181 | ! |
Sigma.logdet <- attr(Sigma.inv, "logdet") |
| 182 | ||
| 183 |
# subtract Mu |
|
| 184 | ! |
Yc <- t(t(Y) - Mu) |
| 185 | ||
| 186 |
# DIST/logdet per case |
|
| 187 | ! |
DIST <- logdet <- P.LOG.2PI <- rep(as.numeric(NA), NY) |
| 188 | ||
| 189 |
# missing pattern per case |
|
| 190 | ! |
OBS <- !is.na(Y) |
| 191 | ! |
P.i <- rowSums(OBS) |
| 192 | ||
| 193 |
# constant |
|
| 194 | ! |
P.LOG.2PI <- P.i * LOG.2PI |
| 195 | ||
| 196 |
# complete cases first (only an advantage if we have mostly complete |
|
| 197 |
# observations) |
|
| 198 | ! |
other.idx <- seq_len(NY) |
| 199 | ! |
complete.idx <- which(P.i == P) |
| 200 | ! |
if (length(complete.idx) > 0L) {
|
| 201 | ! |
other.idx <- other.idx[-complete.idx] |
| 202 | ! |
DIST[complete.idx] <- |
| 203 | ! |
rowSums(Yc[complete.idx, , drop = FALSE] %*% Sigma.inv * |
| 204 | ! |
Yc[complete.idx, , drop = FALSE]) |
| 205 | ! |
logdet[complete.idx] <- Sigma.logdet |
| 206 |
} |
|
| 207 | ||
| 208 |
# non-complete cases |
|
| 209 | ! |
for (i in other.idx) {
|
| 210 | ! |
na.idx <- which(!OBS[i, ]) |
| 211 | ||
| 212 |
# catch empty cases |
|
| 213 | ! |
if (length(na.idx) == P) next |
| 214 | ||
| 215 |
# invert Sigma for this pattern |
|
| 216 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 217 | ! |
S.inv = Sigma.inv, |
| 218 | ! |
rm.idx = na.idx, logdet = TRUE, S.logdet = Sigma.logdet |
| 219 |
) |
|
| 220 | ! |
logdet[i] <- attr(sigma.inv, "logdet") |
| 221 | ||
| 222 |
# distance for this case |
|
| 223 | ! |
DIST[i] <- sum(sigma.inv * crossprod(Yc[i, OBS[i, ], drop = FALSE])) |
| 224 |
} |
|
| 225 | ||
| 226 |
# compute casewise loglikelihoods |
|
| 227 | ! |
if (log2pi) {
|
| 228 | ! |
llik <- -(P.LOG.2PI + logdet + DIST) / 2 |
| 229 |
} else {
|
|
| 230 | ! |
llik <- -(logdet + DIST) / 2 |
| 231 |
} |
|
| 232 | ||
| 233 |
# minus.two |
|
| 234 | ! |
if (minus.two) {
|
| 235 | ! |
llik <- -2 * llik |
| 236 |
} |
|
| 237 | ||
| 238 |
# weights? |
|
| 239 | ! |
if (!is.null(wt)) {
|
| 240 | ! |
llik <- llik * wt |
| 241 |
} |
|
| 242 | ||
| 243 |
# x.idx |
|
| 244 | ! |
if (length(x.idx) > 0L) {
|
| 245 | ! |
llik.x <- lav_mvnorm_missing_llik_casewise( |
| 246 | ! |
Y = Y[, x.idx, drop = FALSE], |
| 247 | ! |
wt = wt, Mu = Mu[x.idx], |
| 248 | ! |
Sigma = Sigma[x.idx, x.idx, drop = FALSE], |
| 249 | ! |
x.idx = integer(0L), Sinv.method = Sinv.method, |
| 250 | ! |
log2pi = log2pi, minus.two = minus.two |
| 251 |
) |
|
| 252 | ! |
llik <- llik - llik.x |
| 253 |
} |
|
| 254 | ||
| 255 | ! |
llik |
| 256 |
} |
|
| 257 | ||
| 258 |
# pattern-based, but casewise loglikelihoods |
|
| 259 |
lav_mvnorm_missing_llik_pattern <- function(Y = NULL, |
|
| 260 |
Mp = NULL, |
|
| 261 |
wt = NULL, |
|
| 262 |
Mu = NULL, |
|
| 263 |
Sigma = NULL, |
|
| 264 |
x.idx = integer(0L), |
|
| 265 |
Sinv.method = "eigen", |
|
| 266 |
log2pi = TRUE, |
|
| 267 |
minus.two = FALSE) {
|
|
| 268 | ! |
P <- NCOL(Y) |
| 269 | ! |
LOG.2PI <- log(2 * pi) |
| 270 | ! |
Mu <- as.numeric(Mu) |
| 271 | ! |
if (!is.null(wt)) {
|
| 272 | ! |
N <- sum(wt) |
| 273 |
} else {
|
|
| 274 | ! |
N <- NROW(Y) |
| 275 |
} |
|
| 276 | ! |
NY <- NROW(Y) |
| 277 | ||
| 278 |
# global inverse + logdet |
|
| 279 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 280 | ! |
S = Sigma, logdet = TRUE, |
| 281 | ! |
Sinv.method = Sinv.method |
| 282 |
) |
|
| 283 | ! |
Sigma.logdet <- attr(Sigma.inv, "logdet") |
| 284 | ||
| 285 |
# subtract Mu |
|
| 286 | ! |
Yc <- t(t(Y) - Mu) |
| 287 | ||
| 288 |
# DIST/logdet per case |
|
| 289 | ! |
DIST <- logdet <- P.LOG.2PI <- rep(as.numeric(NA), NY) |
| 290 | ||
| 291 |
# missing patterns |
|
| 292 | ! |
if (is.null(Mp)) {
|
| 293 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 294 |
} |
|
| 295 | ||
| 296 |
# for each pattern, compute sigma.inv/logdet; compute DIST for all |
|
| 297 |
# observations of this pattern |
|
| 298 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 299 |
# observed values for this pattern |
|
| 300 | ! |
var.idx <- Mp$pat[p, ] |
| 301 | ||
| 302 |
# missing values for this pattern |
|
| 303 | ! |
na.idx <- which(!var.idx) |
| 304 | ||
| 305 |
# identify cases with this pattern |
|
| 306 | ! |
case.idx <- Mp$case.idx[[p]] |
| 307 | ||
| 308 |
# constant |
|
| 309 | ! |
P.LOG.2PI[case.idx] <- sum(var.idx) * LOG.2PI |
| 310 | ||
| 311 |
# invert Sigma for this pattern |
|
| 312 | ! |
if (length(na.idx) > 0L) {
|
| 313 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 314 | ! |
S.inv = Sigma.inv, |
| 315 | ! |
rm.idx = na.idx, logdet = TRUE, S.logdet = Sigma.logdet |
| 316 |
) |
|
| 317 | ! |
logdet[case.idx] <- attr(sigma.inv, "logdet") |
| 318 |
} else {
|
|
| 319 | ! |
sigma.inv <- Sigma.inv |
| 320 | ! |
logdet[case.idx] <- Sigma.logdet |
| 321 |
} |
|
| 322 | ||
| 323 | ! |
if (Mp$freq[p] == 1L) {
|
| 324 | ! |
DIST[case.idx] <- sum(sigma.inv * |
| 325 | ! |
crossprod(Yc[case.idx, var.idx, drop = FALSE])) |
| 326 |
} else {
|
|
| 327 | ! |
DIST[case.idx] <- |
| 328 | ! |
rowSums(Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv * |
| 329 | ! |
Yc[case.idx, var.idx, drop = FALSE]) |
| 330 |
} |
|
| 331 |
} |
|
| 332 | ||
| 333 |
# compute casewise loglikelihoods |
|
| 334 | ! |
if (log2pi) {
|
| 335 | ! |
llik <- -(P.LOG.2PI + logdet + DIST) / 2 |
| 336 |
} else {
|
|
| 337 | ! |
llik <- -(logdet + DIST) / 2 |
| 338 |
} |
|
| 339 | ||
| 340 |
# minus.two |
|
| 341 | ! |
if (minus.two) {
|
| 342 | ! |
llik <- -2 * llik |
| 343 |
} |
|
| 344 | ||
| 345 |
# weights? |
|
| 346 | ! |
if (!is.null(wt)) {
|
| 347 | ! |
llik <- llik * wt |
| 348 |
} |
|
| 349 | ||
| 350 |
# x.idx -- using casewise (as patterns for Y may not be the same as |
|
| 351 |
# patterns for Y[,-x.idx]) |
|
| 352 | ! |
if (length(x.idx) > 0L) {
|
| 353 | ! |
llik.x <- lav_mvnorm_missing_llik_casewise( |
| 354 | ! |
Y = Y[, x.idx, drop = FALSE], |
| 355 | ! |
wt = wt, Mu = Mu[x.idx], |
| 356 | ! |
Sigma = Sigma[x.idx, x.idx, drop = FALSE], |
| 357 | ! |
x.idx = integer(0L), Sinv.method = Sinv.method, |
| 358 | ! |
log2pi = log2pi, minus.two = minus.two |
| 359 |
) |
|
| 360 | ! |
llik <- llik - llik.x |
| 361 |
} |
|
| 362 | ||
| 363 | ! |
llik |
| 364 |
} |
|
| 365 | ||
| 366 | ||
| 367 | ||
| 368 | ||
| 369 |
# 2. Derivatives |
|
| 370 | ||
| 371 |
# 2a: derivative logl with respect to mu |
|
| 372 |
lav_mvnorm_missing_dlogl_dmu <- function(Y = NULL, |
|
| 373 |
wt = NULL, |
|
| 374 |
Mu = NULL, |
|
| 375 |
Sigma = NULL, |
|
| 376 |
x.idx = integer(0L), |
|
| 377 |
Sigma.inv = NULL, |
|
| 378 |
Sinv.method = "eigen") {
|
|
| 379 | ! |
SC <- lav_mvnorm_missing_scores_mu( |
| 380 | ! |
Y = Y, wt = wt, Mu = Mu, Sigma = Sigma, |
| 381 | ! |
x.idx = x.idx, Sigma.inv = Sigma.inv, Sinv.method = Sinv.method |
| 382 |
) |
|
| 383 | ||
| 384 | ! |
colSums(SC, na.rm = TRUE) |
| 385 |
} |
|
| 386 | ||
| 387 |
# 2abis: using samplestats |
|
| 388 |
lav_mvnorm_missing_dlogl_dmu_samplestats <- function(Yp = NULL, |
|
| 389 |
Mu = NULL, |
|
| 390 |
Sigma = NULL, |
|
| 391 |
x.idx = integer(0L), |
|
| 392 |
Sigma.inv = NULL, |
|
| 393 |
Sinv.method = "eigen") {
|
|
| 394 | ! |
pat.N <- length(Yp) |
| 395 | ! |
P <- length(Yp[[1]]$var.idx) |
| 396 | ||
| 397 | ! |
if (is.null(Sigma.inv)) {
|
| 398 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 399 | ! |
S = Sigma, logdet = FALSE, |
| 400 | ! |
Sinv.method = Sinv.method |
| 401 |
) |
|
| 402 |
} |
|
| 403 | ||
| 404 |
# dmu |
|
| 405 | ! |
dmu <- numeric(P) |
| 406 | ||
| 407 |
# for each pattern, compute sigma.inv |
|
| 408 | ! |
for (p in seq_len(pat.N)) {
|
| 409 |
# observed variables for this pattern |
|
| 410 | ! |
var.idx <- Yp[[p]]$var.idx |
| 411 | ||
| 412 |
# missing values for this pattern |
|
| 413 | ! |
na.idx <- which(!var.idx) |
| 414 | ||
| 415 |
# invert Sigma for this pattern |
|
| 416 | ! |
if (length(na.idx) > 0L) {
|
| 417 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 418 | ! |
S.inv = Sigma.inv, |
| 419 | ! |
rm.idx = na.idx, logdet = FALSE |
| 420 |
) |
|
| 421 |
} else {
|
|
| 422 | ! |
sigma.inv <- Sigma.inv |
| 423 |
} |
|
| 424 | ||
| 425 |
# dmu for this pattern |
|
| 426 | ! |
dmu.pattern <- as.numeric(sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx])) |
| 427 | ||
| 428 |
# update mu |
|
| 429 | ! |
dmu[var.idx] <- dmu[var.idx] + (dmu.pattern * Yp[[p]]$freq) |
| 430 |
} |
|
| 431 | ||
| 432 |
# fixed.x? |
|
| 433 | ! |
if (length(x.idx) > 0L) {
|
| 434 | ! |
dmu[x.idx] <- 0 |
| 435 |
} |
|
| 436 | ||
| 437 | ! |
dmu |
| 438 |
} |
|
| 439 | ||
| 440 | ||
| 441 | ||
| 442 |
# 2b: derivative logl with respect to Sigma (full matrix, ignoring symmetry) |
|
| 443 |
lav_mvnorm_missing_dlogl_dSigma <- function(Y = NULL, |
|
| 444 |
Mp = NULL, |
|
| 445 |
wt = NULL, |
|
| 446 |
Mu = NULL, |
|
| 447 |
Sigma = NULL, |
|
| 448 |
x.idx = integer(0L), |
|
| 449 |
Sigma.inv = NULL, |
|
| 450 |
Sinv.method = "eigen") {
|
|
| 451 | ! |
P <- NCOL(Y) |
| 452 | ! |
Mu <- as.numeric(Mu) |
| 453 | ! |
if (!is.null(wt)) {
|
| 454 | ! |
N <- sum(wt) |
| 455 |
} else {
|
|
| 456 | ! |
N <- NROW(Y) |
| 457 |
} |
|
| 458 | ! |
NY <- NROW(Y) |
| 459 | ||
| 460 | ! |
if (is.null(Sigma.inv)) {
|
| 461 |
# invert Sigma |
|
| 462 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 463 | ! |
S = Sigma, logdet = FALSE, |
| 464 | ! |
Sinv.method = Sinv.method |
| 465 |
) |
|
| 466 |
} |
|
| 467 | ||
| 468 |
# subtract Mu |
|
| 469 | ! |
Yc <- t(t(Y) - Mu) |
| 470 | ||
| 471 |
# dvechSigma |
|
| 472 | ! |
dSigma <- matrix(0, P, P) |
| 473 | ||
| 474 |
# missing patterns |
|
| 475 | ! |
if (is.null(Mp)) {
|
| 476 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 477 |
} |
|
| 478 | ||
| 479 |
# for each pattern |
|
| 480 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 481 |
# observed values for this pattern |
|
| 482 | ! |
var.idx <- Mp$pat[p, ] |
| 483 | ||
| 484 |
# missing values for this pattern |
|
| 485 | ! |
na.idx <- which(!var.idx) |
| 486 | ||
| 487 |
# cases with this pattern |
|
| 488 | ! |
case.idx <- Mp$case.idx[[p]] |
| 489 | ||
| 490 |
# invert Sigma for this pattern |
|
| 491 | ! |
if (length(na.idx) > 0L) {
|
| 492 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 493 | ! |
S.inv = Sigma.inv, |
| 494 | ! |
rm.idx = na.idx, logdet = FALSE |
| 495 |
) |
|
| 496 |
} else {
|
|
| 497 | ! |
sigma.inv <- Sigma.inv |
| 498 |
} |
|
| 499 | ||
| 500 | ! |
if (!is.null(wt)) {
|
| 501 | ! |
FREQ <- sum(wt[case.idx]) |
| 502 |
} else {
|
|
| 503 | ! |
FREQ <- Mp$freq[p] |
| 504 |
} |
|
| 505 | ||
| 506 | ! |
if (length(case.idx) > 1L) {
|
| 507 | ! |
if (!is.null(wt)) {
|
| 508 | ! |
out <- stats::cov.wt(Y[case.idx, var.idx, drop = FALSE], |
| 509 | ! |
wt = wt[Mp$case.idx[[p]]], method = "ML" |
| 510 |
) |
|
| 511 | ! |
SY <- out$cov |
| 512 | ! |
MY <- out$center |
| 513 | ! |
W.tilde <- SY + tcrossprod(MY - Mu[var.idx]) |
| 514 |
} else {
|
|
| 515 | ! |
W.tilde <- crossprod(Yc[case.idx, var.idx, drop = FALSE]) / FREQ |
| 516 |
} |
|
| 517 |
} else {
|
|
| 518 | ! |
W.tilde <- tcrossprod(Yc[case.idx, var.idx]) |
| 519 |
} |
|
| 520 | ||
| 521 |
# dSigma for this pattern |
|
| 522 | ! |
dSigma.pattern <- matrix(0, P, P) |
| 523 | ! |
dSigma.pattern[var.idx, var.idx] <- -(1 / 2) * (sigma.inv - |
| 524 | ! |
(sigma.inv %*% W.tilde %*% sigma.inv)) |
| 525 | ||
| 526 |
# update dSigma |
|
| 527 | ! |
dSigma <- dSigma + (dSigma.pattern * FREQ) |
| 528 |
} |
|
| 529 | ||
| 530 |
# fixed.x? |
|
| 531 | ! |
if (length(x.idx) > 0L) {
|
| 532 | ! |
dSigma[x.idx, x.idx] <- 0 |
| 533 |
} |
|
| 534 | ||
| 535 | ! |
dSigma |
| 536 |
} |
|
| 537 | ||
| 538 |
# 2bbis: using samplestats |
|
| 539 |
lav_mvnorm_missing_dlogl_dSigma_samplestats <- function(Yp = NULL, |
|
| 540 |
Mu = NULL, |
|
| 541 |
Sigma = NULL, |
|
| 542 |
x.idx = integer(0L), |
|
| 543 |
Sigma.inv = NULL, |
|
| 544 |
Sinv.method = "eigen") {
|
|
| 545 | ! |
pat.N <- length(Yp) |
| 546 | ! |
P <- length(Yp[[1]]$var.idx) |
| 547 | ||
| 548 | ! |
if (is.null(Sigma.inv)) {
|
| 549 |
# invert Sigma |
|
| 550 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 551 | ! |
S = Sigma, logdet = FALSE, |
| 552 | ! |
Sinv.method = Sinv.method |
| 553 |
) |
|
| 554 |
} |
|
| 555 | ||
| 556 |
# dvechSigma |
|
| 557 | ! |
dSigma <- matrix(0, P, P) |
| 558 | ||
| 559 |
# for each pattern |
|
| 560 | ! |
for (p in seq_len(pat.N)) {
|
| 561 |
# observed variables for this pattern |
|
| 562 | ! |
var.idx <- Yp[[p]]$var.idx |
| 563 | ||
| 564 |
# missing values for this pattern |
|
| 565 | ! |
na.idx <- which(!var.idx) |
| 566 | ||
| 567 |
# invert Sigma for this pattern |
|
| 568 | ! |
if (length(na.idx) > 0L) {
|
| 569 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 570 | ! |
S.inv = Sigma.inv, |
| 571 | ! |
rm.idx = na.idx, logdet = FALSE |
| 572 |
) |
|
| 573 |
} else {
|
|
| 574 | ! |
sigma.inv <- Sigma.inv |
| 575 |
} |
|
| 576 | ||
| 577 | ! |
W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx]) |
| 578 | ||
| 579 |
# dSigma for this pattern |
|
| 580 | ! |
dSigma.pattern <- matrix(0, P, P) |
| 581 | ! |
dSigma.pattern[var.idx, var.idx] <- -(1 / 2) * (sigma.inv - |
| 582 | ! |
(sigma.inv %*% W.tilde %*% sigma.inv)) |
| 583 | ||
| 584 |
# update dSigma |
|
| 585 | ! |
dSigma <- dSigma + (dSigma.pattern * Yp[[p]]$freq) |
| 586 |
} |
|
| 587 | ||
| 588 |
# fixed.x? |
|
| 589 | ! |
if (length(x.idx) > 0L) {
|
| 590 | ! |
dSigma[x.idx, x.idx] <- 0 |
| 591 |
} |
|
| 592 | ||
| 593 | ! |
dSigma |
| 594 |
} |
|
| 595 | ||
| 596 | ||
| 597 |
# 2c: derivative logl with respect to vech(Sigma) |
|
| 598 |
lav_mvnorm_missing_dlogl_dvechSigma <- function(Y = NULL, |
|
| 599 |
wt = NULL, |
|
| 600 |
Mu = NULL, |
|
| 601 |
x.idx = integer(0L), |
|
| 602 |
Sigma = NULL, |
|
| 603 |
Sigma.inv = NULL, |
|
| 604 |
Sinv.method = "eigen") {
|
|
| 605 | ! |
dSigma <- lav_mvnorm_missing_dlogl_dSigma( |
| 606 | ! |
Y = Y, wt = wt, Mu = Mu, |
| 607 | ! |
Sigma = Sigma, x.idx = x.idx, Sigma.inv = Sigma.inv, |
| 608 | ! |
Sinv.method = Sinv.method |
| 609 |
) |
|
| 610 | ||
| 611 | ! |
dvechSigma <- as.numeric(lav_matrix_duplication_pre( |
| 612 | ! |
as.matrix(lav_matrix_vec(dSigma)) |
| 613 |
)) |
|
| 614 | ||
| 615 | ! |
dvechSigma |
| 616 |
} |
|
| 617 | ||
| 618 |
# 2cbis: using samplestats |
|
| 619 |
lav_mvnorm_missing_dlogl_dvechSigma_samplestats <- |
|
| 620 |
function(Yp = NULL, |
|
| 621 |
Mu = NULL, |
|
| 622 |
Sigma = NULL, |
|
| 623 |
x.idx = integer(0L), |
|
| 624 |
Sigma.inv = NULL, |
|
| 625 |
Sinv.method = "eigen") {
|
|
| 626 | ! |
pat.N <- length(Yp) |
| 627 | ! |
P <- length(Yp[[1]]$var.idx) |
| 628 | ||
| 629 | ! |
if (is.null(Sigma.inv)) {
|
| 630 |
# invert Sigma |
|
| 631 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 632 | ! |
S = Sigma, logdet = FALSE, |
| 633 | ! |
Sinv.method = Sinv.method |
| 634 |
) |
|
| 635 |
} |
|
| 636 | ||
| 637 |
# dvechSigma |
|
| 638 | ! |
dvechSigma <- numeric(P * (P + 1) / 2) |
| 639 | ||
| 640 |
# for each pattern |
|
| 641 | ! |
for (p in seq_len(pat.N)) {
|
| 642 |
# observed variables for this pattern |
|
| 643 | ! |
var.idx <- Yp[[p]]$var.idx |
| 644 | ||
| 645 |
# missing values for this pattern |
|
| 646 | ! |
na.idx <- which(!var.idx) |
| 647 | ||
| 648 |
# invert Sigma for this pattern |
|
| 649 | ! |
if (length(na.idx) > 0L) {
|
| 650 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 651 | ! |
S.inv = Sigma.inv, |
| 652 | ! |
rm.idx = na.idx, logdet = FALSE |
| 653 |
) |
|
| 654 |
} else {
|
|
| 655 | ! |
sigma.inv <- Sigma.inv |
| 656 |
} |
|
| 657 | ||
| 658 | ! |
W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx]) |
| 659 | ||
| 660 |
# dSigma for this pattern |
|
| 661 | ! |
dSigma.pattern <- matrix(0, P, P) |
| 662 | ! |
dSigma.pattern[var.idx, var.idx] <- -(1 / 2) * (sigma.inv - |
| 663 | ! |
(sigma.inv %*% W.tilde %*% sigma.inv)) |
| 664 | ||
| 665 |
# fixed.x? |
|
| 666 | ! |
if (length(x.idx) > 0L) {
|
| 667 | ! |
dSigma.pattern[x.idx, x.idx] <- 0 |
| 668 |
} |
|
| 669 | ||
| 670 |
# convert to vechSigma |
|
| 671 | ! |
dvechSigma.pattern <- as.numeric(lav_matrix_duplication_pre( |
| 672 | ! |
as.matrix(lav_matrix_vec(dSigma.pattern)) |
| 673 |
)) |
|
| 674 | ||
| 675 |
# update dvechSigma |
|
| 676 | ! |
dvechSigma <- dvechSigma + (dvechSigma.pattern * Yp[[p]]$freq) |
| 677 |
} |
|
| 678 | ||
| 679 | ! |
dvechSigma |
| 680 |
} |
|
| 681 | ||
| 682 | ||
| 683 | ||
| 684 | ||
| 685 |
# 3. Casewise scores |
|
| 686 | ||
| 687 |
# 3a: casewise scores with respect to mu |
|
| 688 |
lav_mvnorm_missing_scores_mu <- function(Y = NULL, |
|
| 689 |
wt = NULL, |
|
| 690 |
Mp = NULL, |
|
| 691 |
Mu = NULL, |
|
| 692 |
Sigma = NULL, |
|
| 693 |
x.idx = integer(0L), |
|
| 694 |
Sigma.inv = NULL, |
|
| 695 |
Sinv.method = "eigen") {
|
|
| 696 | ! |
P <- NCOL(Y) |
| 697 | ! |
Mu <- as.numeric(Mu) |
| 698 | ! |
if (!is.null(wt)) {
|
| 699 | ! |
N <- sum(wt) |
| 700 |
} else {
|
|
| 701 | ! |
N <- NROW(Y) |
| 702 |
} |
|
| 703 | ! |
NY <- NROW(Y) |
| 704 | ||
| 705 | ! |
if (is.null(Sigma.inv)) {
|
| 706 |
# invert Sigma |
|
| 707 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 708 | ! |
S = Sigma, logdet = FALSE, |
| 709 | ! |
Sinv.method = Sinv.method |
| 710 |
) |
|
| 711 |
} |
|
| 712 | ||
| 713 |
# missing patterns |
|
| 714 | ! |
if (is.null(Mp)) {
|
| 715 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 716 |
} |
|
| 717 | ||
| 718 |
# subtract Mu |
|
| 719 | ! |
Yc <- t(t(Y) - Mu) |
| 720 | ||
| 721 |
# dmu per case |
|
| 722 | ! |
dmu <- matrix(as.numeric(NA), NY, P) |
| 723 | ||
| 724 |
# for each pattern, compute sigma.inv |
|
| 725 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 726 |
# observed values for this pattern |
|
| 727 | ! |
var.idx <- Mp$pat[p, ] |
| 728 | ||
| 729 |
# missing values for this pattern |
|
| 730 | ! |
na.idx <- which(!var.idx) |
| 731 | ||
| 732 | ! |
case.idx <- Mp$case.idx[[p]] |
| 733 | ||
| 734 |
# invert Sigma for this pattern |
|
| 735 | ! |
if (length(na.idx) > 0L) {
|
| 736 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 737 | ! |
S.inv = Sigma.inv, |
| 738 | ! |
rm.idx = na.idx, logdet = FALSE |
| 739 |
) |
|
| 740 |
} else {
|
|
| 741 | ! |
sigma.inv <- Sigma.inv |
| 742 |
} |
|
| 743 | ||
| 744 |
# compute dMu for all observations of this pattern |
|
| 745 | ! |
dmu[case.idx, var.idx] <- |
| 746 | ! |
Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv |
| 747 |
} |
|
| 748 | ||
| 749 |
# weights |
|
| 750 | ! |
if (!is.null(wt)) {
|
| 751 | ! |
dmu <- dmu * wt |
| 752 |
} |
|
| 753 | ||
| 754 |
# fixed.x? |
|
| 755 | ! |
if (length(x.idx) > 0L) {
|
| 756 | ! |
dmu[, x.idx] <- 0 |
| 757 |
} |
|
| 758 | ||
| 759 | ! |
dmu |
| 760 |
} |
|
| 761 | ||
| 762 |
# 3b: casewise scores with respect to vech(Sigma) |
|
| 763 |
lav_mvnorm_missing_scores_vech_sigma <- function(Y = NULL, |
|
| 764 |
wt = NULL, |
|
| 765 |
Mp = NULL, |
|
| 766 |
Mu = NULL, |
|
| 767 |
Sigma = NULL, |
|
| 768 |
x.idx = integer(0L), |
|
| 769 |
Sigma.inv = NULL, |
|
| 770 |
Sinv.method = "eigen") {
|
|
| 771 | ! |
P <- NCOL(Y) |
| 772 | ! |
Mu <- as.numeric(Mu) |
| 773 | ! |
if (!is.null(wt)) {
|
| 774 | ! |
N <- sum(wt) |
| 775 |
} else {
|
|
| 776 | ! |
N <- NROW(Y) |
| 777 |
} |
|
| 778 | ! |
NY <- NROW(Y) |
| 779 | ||
| 780 | ! |
if (is.null(Sigma.inv)) {
|
| 781 |
# invert Sigma |
|
| 782 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 783 | ! |
S = Sigma, logdet = FALSE, |
| 784 | ! |
Sinv.method = Sinv.method |
| 785 |
) |
|
| 786 |
} |
|
| 787 | ||
| 788 |
# for the tcrossprod |
|
| 789 | ! |
idx1 <- lav_matrix_vech_col_idx(P) |
| 790 | ! |
idx2 <- lav_matrix_vech_row_idx(P) |
| 791 | ||
| 792 |
# vech(Sigma.inv) |
|
| 793 | ! |
iSigma <- lav_matrix_vech(Sigma.inv) |
| 794 | ||
| 795 |
# missing patterns |
|
| 796 | ! |
if (is.null(Mp)) {
|
| 797 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 798 |
} |
|
| 799 | ||
| 800 |
# subtract Mu |
|
| 801 | ! |
Yc <- t(t(Y) - Mu) |
| 802 | ||
| 803 |
# SC |
|
| 804 | ! |
SC <- matrix(as.numeric(NA), nrow = NY, ncol = length(iSigma)) |
| 805 | ||
| 806 |
# for each pattern |
|
| 807 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 808 |
# observed values for this pattern |
|
| 809 | ! |
var.idx <- Mp$pat[p, ] |
| 810 | ||
| 811 |
# missing values for this pattern |
|
| 812 | ! |
na.idx <- which(!var.idx) |
| 813 | ||
| 814 |
# cases with this pattern |
|
| 815 | ! |
case.idx <- Mp$case.idx[[p]] |
| 816 | ||
| 817 |
# invert Sigma for this pattern |
|
| 818 | ! |
if (length(na.idx) > 0L) {
|
| 819 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 820 | ! |
S.inv = Sigma.inv, |
| 821 | ! |
rm.idx = na.idx, logdet = FALSE |
| 822 |
) |
|
| 823 | ! |
tmp <- matrix(0, P, P) |
| 824 | ! |
tmp[var.idx, var.idx] <- sigma.inv |
| 825 | ! |
isigma <- lav_matrix_vech(tmp) |
| 826 |
} else {
|
|
| 827 | ! |
sigma.inv <- Sigma.inv |
| 828 | ! |
isigma <- iSigma |
| 829 |
} |
|
| 830 | ||
| 831 |
# postmultiply these cases with sigma.inv |
|
| 832 | ! |
Yc[case.idx, var.idx] <- Yc[case.idx, var.idx] %*% sigma.inv |
| 833 | ||
| 834 |
# tcrossprod |
|
| 835 | ! |
SC[case.idx, ] <- Yc[case.idx, idx1] * Yc[case.idx, idx2] |
| 836 | ||
| 837 |
# substract isigma from each row |
|
| 838 | ! |
SC[case.idx, ] <- t(t(SC[case.idx, , drop = FALSE]) - isigma) |
| 839 |
} |
|
| 840 | ||
| 841 |
# adjust for vech |
|
| 842 | ! |
SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2 |
| 843 | ||
| 844 |
# weights |
|
| 845 | ! |
if (!is.null(wt)) {
|
| 846 | ! |
SC <- SC * wt |
| 847 |
} |
|
| 848 | ||
| 849 |
# fixed.x? |
|
| 850 | ! |
if (length(x.idx) > 0L) {
|
| 851 | ! |
SC[, lav_matrix_vech_which_idx(n = P, idx = x.idx)] <- 0 |
| 852 |
} |
|
| 853 | ||
| 854 | ! |
SC |
| 855 |
} |
|
| 856 | ||
| 857 |
# 3c: casewise scores with respect to mu + vech(Sigma) |
|
| 858 |
lav_mvnorm_missing_scores_mu_vech_sigma <- function(Y = NULL, |
|
| 859 |
Mp = NULL, |
|
| 860 |
wt = NULL, |
|
| 861 |
Mu = NULL, |
|
| 862 |
Sigma = NULL, |
|
| 863 |
x.idx = integer(0L), |
|
| 864 |
Sigma.inv = NULL, |
|
| 865 |
Sinv.method = "eigen") {
|
|
| 866 | 18x |
P <- NCOL(Y) |
| 867 | 18x |
Mu <- as.numeric(Mu) |
| 868 | 18x |
if (!is.null(wt)) {
|
| 869 | ! |
N <- sum(wt) |
| 870 |
} else {
|
|
| 871 | 18x |
N <- NROW(Y) |
| 872 |
} |
|
| 873 | 18x |
NY <- NROW(Y) |
| 874 | ||
| 875 | 18x |
if (is.null(Sigma.inv)) {
|
| 876 |
# invert Sigma |
|
| 877 | 18x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 878 | 18x |
S = Sigma, logdet = FALSE, |
| 879 | 18x |
Sinv.method = Sinv.method |
| 880 |
) |
|
| 881 |
} |
|
| 882 | ||
| 883 |
# for the tcrossprod |
|
| 884 | 18x |
idx1 <- lav_matrix_vech_col_idx(P) |
| 885 | 18x |
idx2 <- lav_matrix_vech_row_idx(P) |
| 886 | ||
| 887 |
# vech(Sigma.inv) |
|
| 888 | 18x |
iSigma <- lav_matrix_vech(Sigma.inv) |
| 889 | ||
| 890 |
# missing patterns |
|
| 891 | 18x |
if (is.null(Mp)) {
|
| 892 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 893 |
} |
|
| 894 | ||
| 895 |
# subtract Mu |
|
| 896 | 18x |
Yc <- t(t(Y) - Mu) |
| 897 | ||
| 898 |
# dmu per case |
|
| 899 | 18x |
dmu <- matrix(as.numeric(NA), NY, P) |
| 900 | ||
| 901 |
# SC |
|
| 902 | 18x |
SC <- matrix(as.numeric(NA), nrow = NY, ncol = length(iSigma)) |
| 903 | ||
| 904 |
# for each pattern, compute Yc %*% sigma.inv |
|
| 905 | 18x |
for (p in seq_len(Mp$npatterns)) {
|
| 906 |
# observed values for this pattern |
|
| 907 | 18x |
var.idx <- Mp$pat[p, ] |
| 908 | ||
| 909 |
# missing values for this pattern |
|
| 910 | 18x |
na.idx <- which(!var.idx) |
| 911 | ||
| 912 |
# cases with this pattern |
|
| 913 | 18x |
case.idx <- Mp$case.idx[[p]] |
| 914 | ||
| 915 |
# invert Sigma for this pattern |
|
| 916 | 18x |
if (length(na.idx) > 0L) {
|
| 917 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 918 | ! |
S.inv = Sigma.inv, |
| 919 | ! |
rm.idx = na.idx, logdet = FALSE |
| 920 |
) |
|
| 921 | ! |
tmp <- matrix(0, P, P) |
| 922 | ! |
tmp[var.idx, var.idx] <- sigma.inv |
| 923 | ! |
isigma <- lav_matrix_vech(tmp) |
| 924 |
} else {
|
|
| 925 | 18x |
sigma.inv <- Sigma.inv |
| 926 | 18x |
isigma <- iSigma |
| 927 |
} |
|
| 928 | ||
| 929 |
# compute dMu for all observations of this pattern |
|
| 930 | 18x |
dmu[case.idx, var.idx] <- |
| 931 | 18x |
Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv |
| 932 | ||
| 933 |
# postmultiply these cases with sigma.inv |
|
| 934 | 18x |
Yc[case.idx, var.idx] <- Yc[case.idx, var.idx] %*% sigma.inv |
| 935 | ||
| 936 |
# tcrossprod |
|
| 937 | 18x |
SC[case.idx, ] <- Yc[case.idx, idx1] * Yc[case.idx, idx2] |
| 938 | ||
| 939 |
# substract isigma from each row |
|
| 940 | 18x |
SC[case.idx, ] <- t(t(SC[case.idx, , drop = FALSE]) - isigma) |
| 941 |
} |
|
| 942 | ||
| 943 |
# adjust for vech |
|
| 944 | 18x |
SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2 |
| 945 | ||
| 946 | 18x |
out <- cbind(dmu, SC) |
| 947 | ||
| 948 |
# weights |
|
| 949 | 18x |
if (!is.null(wt)) {
|
| 950 | ! |
out <- out * wt |
| 951 |
} |
|
| 952 | ||
| 953 |
# fixed.x? |
|
| 954 | 18x |
if (length(x.idx) > 0L) {
|
| 955 | 18x |
not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx, |
| 956 |
#diagonal = !correlation, |
|
| 957 | 18x |
add.idx.at.start = TRUE) |
| 958 | 18x |
out[, not.x] <- 0 |
| 959 |
} |
|
| 960 | ||
| 961 | 18x |
out |
| 962 |
} |
|
| 963 | ||
| 964 | ||
| 965 |
# 4) Hessian of logl |
|
| 966 |
lav_mvnorm_missing_logl_hessian_data <- function(Y = NULL, |
|
| 967 |
Mp = NULL, |
|
| 968 |
wt = NULL, |
|
| 969 |
Mu = NULL, |
|
| 970 |
Sigma = NULL, |
|
| 971 |
x.idx = integer(0L), |
|
| 972 |
Sinv.method = "eigen", |
|
| 973 |
Sigma.inv = NULL) {
|
|
| 974 |
# missing patterns |
|
| 975 | ! |
Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt) |
| 976 | ||
| 977 | ! |
lav_mvnorm_missing_logl_hessian_samplestats( |
| 978 | ! |
Yp = Yp, Mu = Mu, |
| 979 | ! |
Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, |
| 980 | ! |
Sigma.inv = Sigma.inv |
| 981 |
) |
|
| 982 |
} |
|
| 983 | ||
| 984 |
lav_mvnorm_missing_logl_hessian_samplestats <- |
|
| 985 |
function(Yp = NULL, |
|
| 986 |
# wt not needed |
|
| 987 |
Mu = NULL, |
|
| 988 |
Sigma = NULL, |
|
| 989 |
x.idx = integer(0L), |
|
| 990 |
Sinv.method = "eigen", |
|
| 991 |
Sigma.inv = NULL) {
|
|
| 992 | 70x |
pat.N <- length(Yp) |
| 993 | 70x |
P <- length(Yp[[1]]$var.idx) |
| 994 | ||
| 995 | 70x |
if (is.null(Sigma.inv)) {
|
| 996 | 70x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 997 | 70x |
S = Sigma, logdet = FALSE, |
| 998 | 70x |
Sinv.method = Sinv.method |
| 999 |
) |
|
| 1000 |
} |
|
| 1001 | ||
| 1002 | 70x |
H11 <- matrix(0, P, P) |
| 1003 | 70x |
H21 <- matrix(0, P * (P + 1) / 2, P) |
| 1004 | 70x |
H22 <- matrix(0, P * (P + 1) / 2, P * (P + 1) / 2) |
| 1005 | ||
| 1006 |
# for each pattern, compute sigma.inv |
|
| 1007 | 70x |
for (p in seq_len(pat.N)) {
|
| 1008 |
# observed variables |
|
| 1009 | 118x |
var.idx <- Yp[[p]]$var.idx |
| 1010 | 118x |
pat.freq <- Yp[[p]]$freq |
| 1011 | ||
| 1012 |
# missing values for this pattern |
|
| 1013 | 118x |
na.idx <- which(!var.idx) |
| 1014 | ||
| 1015 |
# invert Sigma for this pattern |
|
| 1016 | 118x |
if (length(na.idx) > 0L) {
|
| 1017 | 48x |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 1018 | 48x |
S.inv = Sigma.inv, |
| 1019 | 48x |
rm.idx = na.idx, logdet = FALSE |
| 1020 |
) |
|
| 1021 |
} else {
|
|
| 1022 | 70x |
sigma.inv <- Sigma.inv |
| 1023 |
} |
|
| 1024 | ||
| 1025 | 118x |
S.inv <- matrix(0, P, P) |
| 1026 | 118x |
S.inv[var.idx, var.idx] <- sigma.inv |
| 1027 | ||
| 1028 | 118x |
tmp21 <- matrix(0, P, 1) |
| 1029 | 118x |
tmp21[var.idx, 1] <- sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx]) |
| 1030 | ||
| 1031 | 118x |
W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx]) |
| 1032 | 118x |
AAA <- (sigma.inv %*% |
| 1033 | 118x |
(2 * W.tilde - Sigma[var.idx, var.idx, drop = FALSE]) %*% |
| 1034 | 118x |
sigma.inv) |
| 1035 | 118x |
tmp22 <- matrix(0, P, P) |
| 1036 | 118x |
tmp22[var.idx, var.idx] <- AAA |
| 1037 | ||
| 1038 | 118x |
i11 <- S.inv |
| 1039 | 118x |
i21 <- lav_matrix_duplication_pre(tmp21 %x% S.inv) |
| 1040 |
# if (lav_use_lavaanC()) {
|
|
| 1041 |
# i22 <- lavaanC::m_kronecker_dup_pre_post(S.inv, tmp22, 0.5) |
|
| 1042 |
# } else {
|
|
| 1043 | 118x |
i22 <- (1 / 2) * lav_matrix_duplication_pre_post(S.inv %x% tmp22) |
| 1044 |
# } |
|
| 1045 | 118x |
H11 <- H11 + pat.freq * i11 |
| 1046 | 118x |
H21 <- H21 + pat.freq * i21 |
| 1047 | 118x |
H22 <- H22 + pat.freq * i22 |
| 1048 |
} |
|
| 1049 | ||
| 1050 | 70x |
H12 <- t(H21) |
| 1051 | ||
| 1052 | 70x |
out <- -1 * rbind( |
| 1053 | 70x |
cbind(H11, H12), |
| 1054 | 70x |
cbind(H21, H22) |
| 1055 |
) |
|
| 1056 | ||
| 1057 |
# fixed.x? |
|
| 1058 | 70x |
if (length(x.idx) > 0L) {
|
| 1059 | 54x |
not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx, |
| 1060 |
#diagonal = !correlation, |
|
| 1061 | 54x |
add.idx.at.start = TRUE) |
| 1062 | 54x |
out[, not.x] <- 0 |
| 1063 | 54x |
out[not.x, ] <- 0 |
| 1064 |
} |
|
| 1065 | ||
| 1066 | 70x |
out |
| 1067 |
} |
|
| 1068 | ||
| 1069 | ||
| 1070 | ||
| 1071 | ||
| 1072 |
# 5) Information |
|
| 1073 | ||
| 1074 |
# 5a: expected unit information Mu and vech(Sigma) |
|
| 1075 |
# (only useful under MCAR) |
|
| 1076 |
# (old term: Abeta, expected) |
|
| 1077 |
lav_mvnorm_missing_information_expected <- function(Y = NULL, |
|
| 1078 |
Mp = NULL, |
|
| 1079 |
wt = NULL, |
|
| 1080 |
Mu = NULL, # unused |
|
| 1081 |
Sigma = NULL, |
|
| 1082 |
x.idx = integer(0L), |
|
| 1083 |
Sigma.inv = NULL, |
|
| 1084 |
Sinv.method = "eigen") {
|
|
| 1085 | 8x |
P <- NCOL(Y) |
| 1086 | ||
| 1087 | 8x |
if (is.null(Sigma.inv)) {
|
| 1088 | 8x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 1089 | 8x |
S = Sigma, logdet = FALSE, |
| 1090 | 8x |
Sinv.method = Sinv.method |
| 1091 |
) |
|
| 1092 |
} |
|
| 1093 | ||
| 1094 |
# missing patterns |
|
| 1095 | 8x |
if (is.null(Mp)) {
|
| 1096 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 1097 |
} |
|
| 1098 | ||
| 1099 |
# N |
|
| 1100 | 8x |
if (!is.null(wt)) {
|
| 1101 | ! |
if (length(Mp$empty.idx) > 0L) {
|
| 1102 | ! |
N <- sum(wt) - sum(wt[Mp$empty.idx]) |
| 1103 |
} else {
|
|
| 1104 | ! |
N <- sum(wt) |
| 1105 |
} |
|
| 1106 |
} else {
|
|
| 1107 | 8x |
N <- sum(Mp$freq) # removed empty cases! |
| 1108 |
} |
|
| 1109 | ||
| 1110 | 8x |
I11 <- matrix(0, P, P) |
| 1111 | 8x |
I22 <- matrix(0, P * (P + 1) / 2, P * (P + 1) / 2) |
| 1112 | ||
| 1113 |
# for each pattern, compute sigma.inv |
|
| 1114 | 8x |
for (p in seq_len(Mp$npatterns)) {
|
| 1115 |
# observed variables |
|
| 1116 | 14x |
var.idx <- Mp$pat[p, ] |
| 1117 | ||
| 1118 |
# missing values for this pattern |
|
| 1119 | 14x |
na.idx <- which(!var.idx) |
| 1120 | ||
| 1121 |
# invert Sigma for this pattern |
|
| 1122 | 14x |
if (length(na.idx) > 0L) {
|
| 1123 | 6x |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 1124 | 6x |
S.inv = Sigma.inv, |
| 1125 | 6x |
rm.idx = na.idx, logdet = FALSE |
| 1126 |
) |
|
| 1127 |
} else {
|
|
| 1128 | 8x |
sigma.inv <- Sigma.inv |
| 1129 |
} |
|
| 1130 | ||
| 1131 | 14x |
S.inv <- matrix(0, P, P) |
| 1132 | 14x |
S.inv[var.idx, var.idx] <- sigma.inv |
| 1133 | ||
| 1134 |
# if (lav_use_lavaanC()) {
|
|
| 1135 |
# S2.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5) |
|
| 1136 |
# } else {
|
|
| 1137 | 14x |
S2.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv) |
| 1138 |
# } |
|
| 1139 | ||
| 1140 | 14x |
if (!is.null(wt)) {
|
| 1141 | ! |
FREQ <- sum(wt[Mp$case.idx[[p]]]) |
| 1142 |
} else {
|
|
| 1143 | 14x |
FREQ <- Mp$freq[p] |
| 1144 |
} |
|
| 1145 | ||
| 1146 | 14x |
I11 <- I11 + FREQ * S.inv |
| 1147 | 14x |
I22 <- I22 + FREQ * S2.inv |
| 1148 |
} |
|
| 1149 | ||
| 1150 | 8x |
out <- lav_matrix_bdiag(I11, I22) / N |
| 1151 | ||
| 1152 |
# fixed.x? |
|
| 1153 | 8x |
if (length(x.idx) > 0L) {
|
| 1154 | 6x |
not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx, |
| 1155 |
# diagonal = !correlation, |
|
| 1156 | 6x |
add.idx.at.start = TRUE) |
| 1157 | 6x |
out[not.x, ] <- 0 |
| 1158 | 6x |
out[, not.x] <- 0 |
| 1159 |
} |
|
| 1160 | ||
| 1161 | 8x |
out |
| 1162 |
} |
|
| 1163 | ||
| 1164 |
# 5b: unit observed information Mu and vech(Sigma) from raw data |
|
| 1165 |
# (old term: Abeta, observed) |
|
| 1166 |
lav_mvnorm_missing_information_observed_data <- function(Y = NULL, |
|
| 1167 |
Mp = NULL, |
|
| 1168 |
wt = NULL, |
|
| 1169 |
Mu = NULL, |
|
| 1170 |
Sigma = NULL, |
|
| 1171 |
x.idx = integer(0L), |
|
| 1172 |
Sinv.method = "eigen", |
|
| 1173 |
Sigma.inv = NULL) {
|
|
| 1174 |
# missing patterns |
|
| 1175 | ! |
if (is.null(Mp)) {
|
| 1176 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 1177 |
} |
|
| 1178 | ||
| 1179 |
# N |
|
| 1180 | ! |
if (!is.null(wt)) {
|
| 1181 | ! |
if (length(Mp$empty.idx) > 0L) {
|
| 1182 | ! |
N <- sum(wt) - sum(wt[Mp$empty.idx]) |
| 1183 |
} else {
|
|
| 1184 | ! |
N <- sum(wt) |
| 1185 |
} |
|
| 1186 |
} else {
|
|
| 1187 | ! |
N <- sum(Mp$freq) # removed empty cases! |
| 1188 |
} |
|
| 1189 | ||
| 1190 |
# observed information |
|
| 1191 | ! |
observed <- lav_mvnorm_missing_logl_hessian_data( |
| 1192 | ! |
Y = Y, Mp = Mp, wt = wt, |
| 1193 | ! |
Mu = Mu, Sigma = Sigma, x.idx = x.idx, |
| 1194 | ! |
Sinv.method = Sinv.method, Sigma.inv = Sigma.inv |
| 1195 |
) |
|
| 1196 | ||
| 1197 | ! |
-observed / N |
| 1198 |
} |
|
| 1199 | ||
| 1200 |
# 5b-bis: unit observed information Mu and vech(Sigma) from samplestats |
|
| 1201 |
lav_mvnorm_missing_information_observed_samplestats <- |
|
| 1202 |
function(Yp = NULL, |
|
| 1203 |
# wt not needed |
|
| 1204 |
Mu = NULL, |
|
| 1205 |
Sigma = NULL, |
|
| 1206 |
x.idx = integer(0L), |
|
| 1207 |
Sinv.method = "eigen", |
|
| 1208 |
Sigma.inv = NULL) {
|
|
| 1209 | 70x |
N <- sum(sapply(Yp, "[[", "freq")) # implicitly: removed empty cases! |
| 1210 | ||
| 1211 |
# observed information |
|
| 1212 | 70x |
observed <- lav_mvnorm_missing_logl_hessian_samplestats( |
| 1213 | 70x |
Yp = Yp, Mu = Mu, |
| 1214 | 70x |
Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, |
| 1215 | 70x |
Sigma.inv = Sigma.inv |
| 1216 |
) |
|
| 1217 | ||
| 1218 | 70x |
-observed / N |
| 1219 |
} |
|
| 1220 | ||
| 1221 |
# 5c: unit first-order information Mu and vech(Sigma) from raw data |
|
| 1222 |
# (old term: Bbeta) |
|
| 1223 |
lav_mvnorm_missing_information_firstorder <- function(Y = NULL, |
|
| 1224 |
Mp = NULL, |
|
| 1225 |
wt = NULL, |
|
| 1226 |
cluster.idx = NULL, |
|
| 1227 |
Mu = NULL, |
|
| 1228 |
Sigma = NULL, |
|
| 1229 |
x.idx = integer(0L), |
|
| 1230 |
Sinv.method = "eigen", |
|
| 1231 |
Sigma.inv = NULL) {
|
|
| 1232 |
# missing patterns |
|
| 1233 | 18x |
if (is.null(Mp)) {
|
| 1234 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 1235 |
} |
|
| 1236 | ||
| 1237 |
# N |
|
| 1238 | 18x |
if (!is.null(wt)) {
|
| 1239 | ! |
if (length(Mp$empty.idx) > 0L) {
|
| 1240 | ! |
N <- sum(wt) - sum(wt[Mp$empty.idx]) |
| 1241 |
} else {
|
|
| 1242 | ! |
N <- sum(wt) |
| 1243 |
} |
|
| 1244 |
} else {
|
|
| 1245 | 18x |
N <- sum(Mp$freq) # removed empty cases! |
| 1246 |
} |
|
| 1247 | ||
| 1248 | 18x |
SC <- lav_mvnorm_missing_scores_mu_vech_sigma( |
| 1249 | 18x |
Y = Y, Mp = Mp, wt = wt, |
| 1250 | 18x |
Mu = Mu, Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, |
| 1251 | 18x |
Sigma.inv = Sigma.inv |
| 1252 |
) |
|
| 1253 | ||
| 1254 |
# handle clustering |
|
| 1255 | 18x |
if (!is.null(cluster.idx)) {
|
| 1256 |
# take the sum within each cluster |
|
| 1257 | ! |
SC <- rowsum(SC, group = cluster.idx, reorder = FALSE, na.rm = TRUE) |
| 1258 | ||
| 1259 |
# lower bias is number of clusters is not very high |
|
| 1260 | ! |
nC <- nrow(SC) |
| 1261 | ! |
correction.factor <- nC / (nC - 1) |
| 1262 | ! |
SC <- SC * sqrt(correction.factor) |
| 1263 |
} |
|
| 1264 | ||
| 1265 | 18x |
lav_matrix_crossprod(SC) / N |
| 1266 |
} |
|
| 1267 | ||
| 1268 |
# 5d: both unit first-order information and expected/observed information |
|
| 1269 |
# from raw data, in one go for efficiency |
|
| 1270 |
lav_mvnorm_missing_information_both <- function(Y = NULL, |
|
| 1271 |
Mp = NULL, |
|
| 1272 |
wt = NULL, |
|
| 1273 |
cluster.idx = NULL, |
|
| 1274 |
Mu = NULL, |
|
| 1275 |
Sigma = NULL, |
|
| 1276 |
x.idx = integer(0L), |
|
| 1277 |
Sinv.method = "eigen", |
|
| 1278 |
Sigma.inv = NULL, |
|
| 1279 |
information = "observed") {
|
|
| 1280 | ! |
P <- NCOL(Y) |
| 1281 | ! |
Mu <- as.numeric(Mu) |
| 1282 | ||
| 1283 | ! |
if (is.null(Sigma.inv)) {
|
| 1284 |
# invert Sigma |
|
| 1285 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 1286 | ! |
S = Sigma, logdet = FALSE, |
| 1287 | ! |
Sinv.method = Sinv.method |
| 1288 |
) |
|
| 1289 |
} |
|
| 1290 | ||
| 1291 |
# for the tcrossprod |
|
| 1292 | ! |
idx1 <- lav_matrix_vech_col_idx(P) |
| 1293 | ! |
idx2 <- lav_matrix_vech_row_idx(P) |
| 1294 | ||
| 1295 |
# vech(Sigma.inv) |
|
| 1296 | ! |
iSigma <- lav_matrix_vech(Sigma.inv) |
| 1297 | ||
| 1298 |
# missing patterns |
|
| 1299 | ! |
if (is.null(Mp)) {
|
| 1300 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 1301 |
} |
|
| 1302 | ||
| 1303 | ! |
if (information == "observed") {
|
| 1304 | ! |
Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt) |
| 1305 |
} |
|
| 1306 | ||
| 1307 |
# N |
|
| 1308 | ! |
if (!is.null(wt)) {
|
| 1309 | ! |
if (length(Mp$empty.idx) > 0L) {
|
| 1310 | ! |
N <- sum(wt) - sum(wt[Mp$empty.idx]) |
| 1311 |
} else {
|
|
| 1312 | ! |
N <- sum(wt) |
| 1313 |
} |
|
| 1314 |
} else {
|
|
| 1315 | ! |
N <- sum(Mp$freq) # removed empty cases! |
| 1316 |
} |
|
| 1317 | ||
| 1318 |
# subtract Mu |
|
| 1319 | ! |
Yc <- t(t(Y) - Mu) |
| 1320 | ||
| 1321 |
# dmu per case |
|
| 1322 | ! |
dmu <- matrix(as.numeric(NA), nrow = NROW(Y), ncol = P) |
| 1323 | ||
| 1324 |
# SC |
|
| 1325 | ! |
SC <- matrix(as.numeric(NA), nrow = NROW(Y), ncol = length(iSigma)) |
| 1326 | ||
| 1327 |
# expected/observed information |
|
| 1328 | ! |
I11 <- matrix(0, P, P) |
| 1329 | ! |
I22 <- matrix(0, P * (P + 1) / 2, P * (P + 1) / 2) |
| 1330 | ! |
if (information == "observed") {
|
| 1331 | ! |
I21 <- matrix(0, P * (P + 1) / 2, P) |
| 1332 |
} |
|
| 1333 | ||
| 1334 |
# for each pattern, compute Yc %*% sigma.inv |
|
| 1335 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 1336 |
# observed values for this pattern |
|
| 1337 | ! |
var.idx <- Mp$pat[p, ] |
| 1338 | ||
| 1339 |
# missing values for this pattern |
|
| 1340 | ! |
na.idx <- which(!var.idx) |
| 1341 | ||
| 1342 |
# cases with this pattern |
|
| 1343 | ! |
case.idx <- Mp$case.idx[[p]] |
| 1344 | ||
| 1345 |
# invert Sigma for this pattern |
|
| 1346 | ! |
if (length(na.idx) > 0L) {
|
| 1347 | ! |
sigma.inv <- lav_matrix_symmetric_inverse_update( |
| 1348 | ! |
S.inv = Sigma.inv, |
| 1349 | ! |
rm.idx = na.idx, logdet = FALSE |
| 1350 |
) |
|
| 1351 | ! |
tmp <- matrix(0, P, P) |
| 1352 | ! |
tmp[var.idx, var.idx] <- sigma.inv |
| 1353 | ! |
isigma <- lav_matrix_vech(tmp) |
| 1354 |
} else {
|
|
| 1355 | ! |
sigma.inv <- Sigma.inv |
| 1356 | ! |
isigma <- iSigma |
| 1357 |
} |
|
| 1358 | ||
| 1359 |
# information |
|
| 1360 | ! |
S.inv <- matrix(0, P, P) |
| 1361 | ! |
S.inv[var.idx, var.idx] <- sigma.inv |
| 1362 | ||
| 1363 | ! |
if (!is.null(wt)) {
|
| 1364 | ! |
FREQ <- sum(wt[case.idx]) |
| 1365 |
} else {
|
|
| 1366 | ! |
FREQ <- Mp$freq[p] |
| 1367 |
} |
|
| 1368 | ||
| 1369 | ! |
if (information == "expected") {
|
| 1370 |
# if (lav_use_lavaanC()) {
|
|
| 1371 |
# S2.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5) |
|
| 1372 |
# } else {
|
|
| 1373 | ! |
S2.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv) |
| 1374 |
# } |
|
| 1375 | ||
| 1376 | ! |
I11 <- I11 + FREQ * S.inv |
| 1377 | ! |
I22 <- I22 + FREQ * S2.inv |
| 1378 |
} else {
|
|
| 1379 | ! |
pat.freq <- Yp[[p]]$freq |
| 1380 | ||
| 1381 | ! |
tmp21 <- matrix(0, P, 1) |
| 1382 | ! |
tmp21[var.idx, 1] <- sigma.inv %*% (Yp[[p]]$MY - Mu[var.idx]) |
| 1383 | ||
| 1384 | ! |
W.tilde <- Yp[[p]]$SY + tcrossprod(Yp[[p]]$MY - Mu[var.idx]) |
| 1385 | ! |
AAA <- (sigma.inv %*% |
| 1386 | ! |
(2 * W.tilde - Sigma[var.idx, var.idx, drop = FALSE]) %*% |
| 1387 | ! |
sigma.inv) |
| 1388 | ! |
tmp22 <- matrix(0, P, P) |
| 1389 | ! |
tmp22[var.idx, var.idx] <- AAA |
| 1390 | ||
| 1391 | ! |
i11 <- S.inv |
| 1392 | ! |
i21 <- lav_matrix_duplication_pre(tmp21 %x% S.inv) |
| 1393 |
# if (lav_use_lavaanC()) {
|
|
| 1394 |
# i22 <- lavaanC::m_kronecker_dup_pre_post(S.inv, tmp22, 0.5) |
|
| 1395 |
# } else {
|
|
| 1396 | ! |
i22 <- (1 / 2) * lav_matrix_duplication_pre_post(S.inv %x% tmp22) |
| 1397 |
# } |
|
| 1398 | ||
| 1399 | ! |
I11 <- I11 + pat.freq * i11 |
| 1400 | ! |
I21 <- I21 + pat.freq * i21 |
| 1401 | ! |
I22 <- I22 + pat.freq * i22 |
| 1402 |
} |
|
| 1403 | ||
| 1404 |
# compute dMu for all observations of this pattern |
|
| 1405 | ! |
dmu[case.idx, var.idx] <- |
| 1406 | ! |
Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv |
| 1407 | ||
| 1408 |
# postmultiply these cases with sigma.inv |
|
| 1409 | ! |
Yc[case.idx, var.idx] <- Yc[case.idx, var.idx] %*% sigma.inv |
| 1410 | ||
| 1411 |
# tcrossprod |
|
| 1412 | ! |
SC[case.idx, ] <- Yc[case.idx, idx1] * Yc[case.idx, idx2] |
| 1413 | ||
| 1414 |
# substract isigma from each row |
|
| 1415 | ! |
SC[case.idx, ] <- t(t(SC[case.idx, , drop = FALSE]) - isigma) |
| 1416 |
} |
|
| 1417 | ||
| 1418 |
# adjust for vech |
|
| 1419 | ! |
SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2 |
| 1420 | ||
| 1421 |
# add dmu |
|
| 1422 | ! |
SC <- cbind(dmu, SC) |
| 1423 | ||
| 1424 |
# weights |
|
| 1425 | ! |
if (!is.null(wt)) {
|
| 1426 | ! |
SC <- SC * wt |
| 1427 |
} |
|
| 1428 | ||
| 1429 |
# fixed.x? |
|
| 1430 | ! |
if (length(x.idx) > 0L) {
|
| 1431 | ! |
not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx, |
| 1432 |
#diagonal = !correlation, |
|
| 1433 | ! |
add.idx.at.start = TRUE) |
| 1434 | ! |
SC[, not.x] <- 0 |
| 1435 |
} |
|
| 1436 | ||
| 1437 |
# handle clustering |
|
| 1438 | ! |
if (!is.null(cluster.idx)) {
|
| 1439 |
# take the sum within each cluster |
|
| 1440 | ! |
SC <- rowsum(SC, group = cluster.idx, reorder = FALSE, na.rm = TRUE) |
| 1441 | ||
| 1442 |
# lower bias is number of clusters is not very high |
|
| 1443 | ! |
nC <- nrow(SC) |
| 1444 | ! |
correction.factor <- nC / (nC - 1) |
| 1445 | ! |
SC <- SC * sqrt(correction.factor) |
| 1446 |
} |
|
| 1447 | ||
| 1448 |
# first order information |
|
| 1449 | ! |
Bbeta <- lav_matrix_crossprod(SC) / N |
| 1450 | ||
| 1451 |
# expected/observed information |
|
| 1452 | ! |
if (information == "expected") {
|
| 1453 | ! |
Abeta <- lav_matrix_bdiag(I11, I22) / N |
| 1454 |
} else {
|
|
| 1455 | ! |
Abeta <- rbind( |
| 1456 | ! |
cbind(I11, t(I21)), |
| 1457 | ! |
cbind(I21, I22) |
| 1458 | ! |
) / N |
| 1459 |
} |
|
| 1460 | ||
| 1461 |
# fixed.x? |
|
| 1462 | ! |
if (length(x.idx) > 0L) {
|
| 1463 | ! |
not.x <- lav_matrix_vech_which_idx(n = P, idx = x.idx, |
| 1464 |
# diagonal = !correlation, |
|
| 1465 | ! |
add.idx.at.start = TRUE) |
| 1466 | ! |
Abeta[not.x, ] <- 0 |
| 1467 | ! |
Abeta[, not.x] <- 0 |
| 1468 |
} |
|
| 1469 | ||
| 1470 | ! |
list(Abeta = Abeta, Bbeta = Bbeta) |
| 1471 |
} |
|
| 1472 | ||
| 1473 | ||
| 1474 |
# 6) inverted information h0 mu + vech(Sigma) |
|
| 1475 | ||
| 1476 |
# 6a: (unit) inverted expected information |
|
| 1477 |
# NOT USED: is not equal to solve(expected) |
|
| 1478 |
# (although it does converge to the same solution eventually) |
|
| 1479 |
# lav_mvnorm_missing_inverted_information_expected <- function(Y = NULL, |
|
| 1480 |
# Mp = NULL, |
|
| 1481 |
# Mu = NULL,# unused |
|
| 1482 |
# Sigma = NULL) {
|
|
| 1483 |
# P <- NCOL(Y) |
|
| 1484 |
# |
|
| 1485 |
# # missing patterns |
|
| 1486 |
# if(is.null(Mp)) {
|
|
| 1487 |
# Mp <- lav_data_missing_patterns(Y) |
|
| 1488 |
# } |
|
| 1489 |
# |
|
| 1490 |
# # N |
|
| 1491 |
# N <- sum(Mp$freq) # removed empty cases! |
|
| 1492 |
# |
|
| 1493 |
# I11 <- matrix(0, P, P) |
|
| 1494 |
# I22 <- matrix(0, P*(P+1)/2, P*(P+1)/2) |
|
| 1495 |
# |
|
| 1496 |
# # for each pattern |
|
| 1497 |
# for(p in seq_len(Mp$npatterns)) {
|
|
| 1498 |
# |
|
| 1499 |
# # observed variables |
|
| 1500 |
# var.idx <- Mp$pat[p,] |
|
| 1501 |
# |
|
| 1502 |
# sigma <- matrix(0, P, P) |
|
| 1503 |
# sigma[var.idx, var.idx] <- Sigma[var.idx, var.idx] |
|
| 1504 |
# sigma2 <- 2 * lav_matrix_duplication_ginv_pre_post(sigma %x% sigma) |
|
| 1505 |
# |
|
| 1506 |
# I11 <- I11 + Mp$freq[p] * sigma |
|
| 1507 |
# I22 <- I22 + Mp$freq[p] * sigma2 |
|
| 1508 |
# } |
|
| 1509 |
# |
|
| 1510 |
# lav_matrix_bdiag(I11, I22)/N |
|
| 1511 |
# } |
|
| 1512 | ||
| 1513 |
# 6b: / |
|
| 1514 | ||
| 1515 |
# 6c: / |
|
| 1516 | ||
| 1517 | ||
| 1518 |
# 7) ACOV h0 mu + vech(Sigma) |
|
| 1519 | ||
| 1520 |
# 7a: 1/N * inverted expected information |
|
| 1521 | ||
| 1522 |
# 7b: 1/N * inverted observed information |
|
| 1523 | ||
| 1524 |
# 7c: 1/N * inverted first-order information |
|
| 1525 | ||
| 1526 |
# 7d: sandwich acov |
|
| 1527 | ||
| 1528 | ||
| 1529 | ||
| 1530 |
# 10) other stuff |
|
| 1531 | ||
| 1532 |
# single imputation missing cells, under the normal model, pattern-based |
|
| 1533 |
# FIXME: add wt |
|
| 1534 |
lav_mvnorm_missing_impute_pattern <- function(Y = NULL, |
|
| 1535 |
Mp = NULL, |
|
| 1536 |
Mu = NULL, |
|
| 1537 |
Sigma = NULL, |
|
| 1538 |
Sigma.inv = NULL, |
|
| 1539 |
Sinv.method = "eigen") {
|
|
| 1540 | ! |
Mu <- as.numeric(Mu) |
| 1541 | ||
| 1542 |
# complete data |
|
| 1543 | ! |
Y.complete <- Y |
| 1544 | ||
| 1545 |
# missing patterns |
|
| 1546 | ! |
if (is.null(Mp)) {
|
| 1547 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 1548 |
} |
|
| 1549 | ||
| 1550 | ! |
if (is.null(Sigma.inv)) {
|
| 1551 |
# invert Sigma |
|
| 1552 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 1553 | ! |
S = Sigma, logdet = FALSE, |
| 1554 | ! |
Sinv.method = Sinv.method |
| 1555 |
) |
|
| 1556 |
} |
|
| 1557 | ||
| 1558 |
# subtract Mu |
|
| 1559 | ! |
Yc <- t(t(Y) - Mu) |
| 1560 | ||
| 1561 |
# fill in data per pattern |
|
| 1562 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 1563 |
# observed values for this pattern |
|
| 1564 | ! |
var.idx <- Mp$pat[p, ] |
| 1565 | ||
| 1566 |
# if complete, nothing to do |
|
| 1567 | ! |
if (all(var.idx)) {
|
| 1568 | ! |
next |
| 1569 |
} |
|
| 1570 | ||
| 1571 |
# missing values for this pattern |
|
| 1572 | ! |
na.idx <- which(!var.idx) |
| 1573 | ||
| 1574 |
# extract observed data for these (centered) cases |
|
| 1575 | ! |
Oc <- Yc[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE] |
| 1576 | ||
| 1577 |
# invert Sigma (Sigma_22, observed part only) for this pattern |
|
| 1578 | ! |
Sigma_22.inv <- try( |
| 1579 | ! |
lav_matrix_symmetric_inverse_update( |
| 1580 | ! |
S.inv = |
| 1581 | ! |
Sigma.inv, rm.idx = na.idx, logdet = FALSE |
| 1582 |
), |
|
| 1583 | ! |
silent = TRUE |
| 1584 |
) |
|
| 1585 | ! |
if (inherits(Sigma_22.inv, "try-error")) {
|
| 1586 | ! |
lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
|
| 1587 |
} |
|
| 1588 | ||
| 1589 |
# estimate missing values in this pattern |
|
| 1590 | ! |
Sigma_12 <- Sigma[!var.idx, var.idx, drop = FALSE] |
| 1591 | ! |
Y.missing <- t(Sigma_12 %*% Sigma_22.inv %*% t(Oc) + Mu[!var.idx]) |
| 1592 | ||
| 1593 |
# complete data for this pattern |
|
| 1594 | ! |
Y.complete[Mp$case.idx[[p]], !var.idx] <- Y.missing |
| 1595 |
} |
|
| 1596 | ||
| 1597 | ! |
Y.complete |
| 1598 |
} |
|
| 1599 | ||
| 1600 | ||
| 1601 |
# E-step: expectations of sum, sum of squares, sum of crossproducts |
|
| 1602 |
# plus correction |
|
| 1603 |
lav_mvnorm_missing_estep <- function(Y = NULL, |
|
| 1604 |
Mp = NULL, |
|
| 1605 |
wt = NULL, |
|
| 1606 |
Mu = NULL, |
|
| 1607 |
Sigma = NULL, |
|
| 1608 |
Sigma.inv = NULL, |
|
| 1609 |
Sinv.method = "eigen") {
|
|
| 1610 | 36x |
P <- NCOL(Y) |
| 1611 | 36x |
Mu <- as.numeric(Mu) |
| 1612 | ||
| 1613 |
# missing patterns |
|
| 1614 | 36x |
if (is.null(Mp)) {
|
| 1615 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 1616 |
} |
|
| 1617 | ||
| 1618 | 36x |
if (is.null(Sigma.inv)) {
|
| 1619 |
# invert Sigma |
|
| 1620 | 36x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 1621 | 36x |
S = Sigma, logdet = FALSE, |
| 1622 | 36x |
Sinv.method = Sinv.method |
| 1623 |
) |
|
| 1624 |
} |
|
| 1625 | ||
| 1626 |
# T1, T2 |
|
| 1627 | 36x |
T1 <- numeric(P) |
| 1628 | 36x |
T2 <- matrix(0, P, P) |
| 1629 | ||
| 1630 |
# update T1 and T2 per pattern |
|
| 1631 | 36x |
for (p in seq_len(Mp$npatterns)) {
|
| 1632 |
# observed values for this pattern |
|
| 1633 | 86x |
var.idx <- Mp$pat[p, ] |
| 1634 | ||
| 1635 |
# extract observed data |
|
| 1636 | 86x |
O <- Y[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE] |
| 1637 | ||
| 1638 |
# if complete, just compute first and second moments |
|
| 1639 | 86x |
if (all(var.idx)) {
|
| 1640 | 36x |
if (!is.null(wt)) {
|
| 1641 | ! |
WT <- wt[Mp$case.idx[[p]]] |
| 1642 | ! |
T1 <- T1 + colSums(WT * O) |
| 1643 | ! |
T2 <- T2 + crossprod(sqrt(WT) * O) |
| 1644 |
} else {
|
|
| 1645 |
# complete pattern |
|
| 1646 | 36x |
T1 <- T1 + colSums(O) |
| 1647 | 36x |
T2 <- T2 + crossprod(O) |
| 1648 |
} |
|
| 1649 | 36x |
next |
| 1650 |
} |
|
| 1651 | ||
| 1652 |
# missing values for this pattern |
|
| 1653 | 50x |
na.idx <- which(!var.idx) |
| 1654 | ||
| 1655 |
# partition Sigma (1=missing, 2=complete) |
|
| 1656 | 50x |
Sigma_11 <- Sigma[!var.idx, !var.idx, drop = FALSE] |
| 1657 | 50x |
Sigma_12 <- Sigma[!var.idx, var.idx, drop = FALSE] |
| 1658 | 50x |
Sigma_21 <- Sigma[var.idx, !var.idx, drop = FALSE] |
| 1659 | ||
| 1660 |
# invert Sigma (Sigma_22, observed part only) for this pattern |
|
| 1661 | 50x |
Sigma_22.inv <- try( |
| 1662 | 50x |
lav_matrix_symmetric_inverse_update( |
| 1663 | 50x |
S.inv = |
| 1664 | 50x |
Sigma.inv, rm.idx = na.idx, logdet = FALSE |
| 1665 |
), |
|
| 1666 | 50x |
silent = TRUE |
| 1667 |
) |
|
| 1668 | 50x |
if (inherits(Sigma_22.inv, "try-error")) {
|
| 1669 | ! |
lav_msg_stop(gettext("Sigma_22.inv cannot be inverted"))
|
| 1670 |
} |
|
| 1671 | ||
| 1672 |
# estimate missing values in this pattern |
|
| 1673 | 50x |
Oc <- t(t(O) - Mu[var.idx]) |
| 1674 | 50x |
Y.missing <- t(Sigma_12 %*% Sigma_22.inv %*% t(Oc) + Mu[!var.idx]) |
| 1675 | ||
| 1676 |
# complete data for this pattern |
|
| 1677 | 50x |
Y.complete <- matrix(0, Mp$freq[[p]], P) |
| 1678 | 50x |
Y.complete[, var.idx] <- O |
| 1679 | 50x |
Y.complete[, !var.idx] <- Y.missing |
| 1680 | ||
| 1681 | 50x |
if (!is.null(wt)) {
|
| 1682 | ! |
WT <- wt[Mp$case.idx[[p]]] |
| 1683 | ! |
T1.pat <- colSums(WT * Y.complete) |
| 1684 | ! |
T2.pat <- crossprod(sqrt(WT) * Y.complete) |
| 1685 |
} else {
|
|
| 1686 |
# 1. SUM `completed' pattern |
|
| 1687 | 50x |
T1.pat <- colSums(Y.complete) |
| 1688 | ||
| 1689 |
# 2. CROSSPROD `completed' pattern |
|
| 1690 | 50x |
T2.pat <- crossprod(Y.complete) |
| 1691 |
} |
|
| 1692 | ||
| 1693 |
# correction for missing cells: conditional covariances |
|
| 1694 | 50x |
T2.p11 <- Sigma_11 - (Sigma_12 %*% Sigma_22.inv %*% Sigma_21) |
| 1695 | 50x |
if (!is.null(wt)) {
|
| 1696 | ! |
T2.pat[!var.idx, !var.idx] <- |
| 1697 | ! |
T2.pat[!var.idx, !var.idx] + (T2.p11 * sum(WT)) |
| 1698 |
} else {
|
|
| 1699 | 50x |
T2.pat[!var.idx, !var.idx] <- |
| 1700 | 50x |
T2.pat[!var.idx, !var.idx] + (T2.p11 * Mp$freq[[p]]) |
| 1701 |
} |
|
| 1702 | ||
| 1703 |
# accumulate |
|
| 1704 | 50x |
T1 <- T1 + T1.pat |
| 1705 | 50x |
T2 <- T2 + T2.pat |
| 1706 |
} |
|
| 1707 | ||
| 1708 | 36x |
list(T1 = T1, T2 = T2) |
| 1709 |
} |
| 1 |
# utility functions |
|
| 2 |
# |
|
| 3 |
# initial version: YR 25/03/2009 |
|
| 4 | ||
| 5 |
# multivariate normal random number generation |
|
| 6 |
# replacement for MASS::mvrnorm for better cross-machine reproducibility |
|
| 7 |
# see: https://blog.djnavarro.net/posts/2025-05-18_multivariate-normal-sampling-floating-point/ |
|
| 8 |
# |
|
| 9 |
# the issue with MASS::mvrnorm is that it uses eigendecomposition with a |
|
| 10 |
# transformation matrix (sqrt(Lambda) Q') that is NOT invariant to eigenvector |
|
| 11 |
# sign flips. this leads to irreproducible results across machines even with |
|
| 12 |
# the same random seed. this implementation follows mvtnorm::rmvnorm which uses: |
|
| 13 |
# - eigen: Q sqrt(Lambda) Q' which IS invariant to sign flips (default) |
|
| 14 |
# - svd: similar to eigen, also invariant |
|
| 15 |
# - chol: unique factorization |
|
| 16 |
# eigen is the default to match MASS::mvrnorm's approach while fixing the |
|
| 17 |
# sign-flip issue with the invariant formula |
|
| 18 |
lav_mvrnorm <- function(n = 1, mu, Sigma, tol = 1e-06, empirical = FALSE, |
|
| 19 |
method = "eigen", checkSymmetry = TRUE, byrow = FALSE) {
|
|
| 20 | ! |
p <- length(mu) |
| 21 | ||
| 22 |
# check symmetry (like mvtnorm) |
|
| 23 | ! |
if (checkSymmetry && !isSymmetric(Sigma, |
| 24 | ! |
tol = sqrt(.Machine$double.eps), |
| 25 | ! |
check.attributes = FALSE |
| 26 |
)) {
|
|
| 27 | ! |
lav_msg_stop(gettext("'Sigma' must be a symmetric matrix in lav_mvrnorm"))
|
| 28 |
} |
|
| 29 | ||
| 30 |
# check dimensions (like mvtnorm) |
|
| 31 | ! |
if (p != nrow(Sigma)) {
|
| 32 | ! |
lav_msg_stop(gettext("incompatible arguments in lav_mvrnorm"))
|
| 33 |
} |
|
| 34 | ||
| 35 |
# compute transformation matrix R based on method (following mvtnorm exactly) |
|
| 36 | ! |
method <- match.arg(method, c("chol", "eigen", "svd"))
|
| 37 | ||
| 38 | ! |
R <- if (method == "eigen") {
|
| 39 | ! |
ev <- eigen(Sigma, symmetric = TRUE) |
| 40 | ! |
if (!all(ev$values >= -tol * abs(ev$values[1L]))) {
|
| 41 | ! |
warning("sigma is numerically not positive semidefinite")
|
| 42 |
} |
|
| 43 |
# Q sqrt(Lambda) Q' - invariant to sign flips |
|
| 44 | ! |
t(ev$vectors %*% (t(ev$vectors) * sqrt(pmax(ev$values, 0)))) |
| 45 | ! |
} else if (method == "svd") {
|
| 46 | ! |
s. <- svd(Sigma) |
| 47 | ! |
if (!all(s.$d >= -tol * abs(s.$d[1L]))) {
|
| 48 | ! |
warning("sigma is numerically not positive semidefinite")
|
| 49 |
} |
|
| 50 | ! |
t(s.$v %*% (t(s.$u) * sqrt(pmax(s.$d, 0)))) |
| 51 | ! |
} else if (method == "chol") {
|
| 52 | ! |
R <- chol(Sigma, pivot = TRUE) |
| 53 | ! |
R[, order(attr(R, "pivot"))] |
| 54 |
} |
|
| 55 | ||
| 56 |
# for names (fallback to dimnames of Sigma if mu has no names) |
|
| 57 | ! |
nm <- names(mu) |
| 58 | ! |
if (is.null(nm) && !is.null(dn <- dimnames(Sigma))) {
|
| 59 | ! |
nm <- dn[[1L]] |
| 60 |
} |
|
| 61 | ||
| 62 | ! |
if (empirical) {
|
| 63 |
# generate standard normal, then apply empirical transformation |
|
| 64 | ! |
X <- matrix(stats::rnorm(p * n), n, p, byrow = byrow) |
| 65 | ! |
X <- scale(X, center = TRUE, scale = FALSE) # center |
| 66 | ! |
X <- X %*% svd(X, nu = 0)$v # orthogonalize |
| 67 | ! |
X <- scale(X, center = FALSE, scale = TRUE) # unit variance |
| 68 | ||
| 69 |
# transform by R |
|
| 70 | ! |
X <- sweep(X %*% R, 2, mu, "+") |
| 71 | ! |
colnames(X) <- nm |
| 72 | ||
| 73 | ! |
if (n == 1) drop(X) else X |
| 74 |
} else {
|
|
| 75 |
# generate samples (following mvtnorm exactly) |
|
| 76 | ! |
X <- matrix(stats::rnorm(n * p), nrow = n, byrow = byrow) %*% R |
| 77 | ! |
X <- sweep(X, 2, mu, "+") |
| 78 | ! |
colnames(X) <- nm |
| 79 | ||
| 80 | ! |
if (n == 1) drop(X) else X |
| 81 |
} |
|
| 82 |
} |
|
| 83 | ||
| 84 |
# outlier detection based on inter-quartile range |
|
| 85 |
# same as boxplot.stats, but returning the indices (not the values) |
|
| 86 |
lav_sample_outlier_idx <- function(x, coef = 1.5) {
|
|
| 87 | ! |
if (coef < 0) {
|
| 88 | ! |
lav_msg_stop(gettext("'coef' must not be negative"))
|
| 89 |
} |
|
| 90 | ! |
stats <- stats::fivenum(x, na.rm = TRUE) |
| 91 | ! |
iqr <- diff(stats[c(2, 4)]) |
| 92 | ! |
if (coef == 0) {
|
| 93 | ! |
return(seq_len(length(x))) |
| 94 |
} else {
|
|
| 95 | ! |
out <- if (!is.na(iqr)) {
|
| 96 | ! |
which(x < (stats[2L] - coef * iqr) | x > (stats[4L] + coef * iqr)) |
| 97 |
} else {
|
|
| 98 | ! |
which(!is.finite(x)) |
| 99 |
} |
|
| 100 |
} |
|
| 101 | ! |
out |
| 102 |
} |
|
| 103 | ||
| 104 |
# sd with trimming |
|
| 105 |
lav_sample_trimmed_sd <- function(x, na.rm = TRUE, trim = 0) {
|
|
| 106 | ! |
if (isTRUE(na.rm)) {
|
| 107 | ! |
x <- x[!is.na(x)] |
| 108 |
} |
|
| 109 | ! |
n <- length(x) |
| 110 | ! |
if (trim > 0 && n) {
|
| 111 | ! |
if (is.complex(x)) {
|
| 112 | ! |
lav_msg_stop(gettext("trimmed means are not defined for complex data"))
|
| 113 |
} |
|
| 114 | ! |
if (anyNA(x)) {
|
| 115 | ! |
return(NA_real_) |
| 116 |
} |
|
| 117 | ! |
if (trim >= 0.5) {
|
| 118 | ! |
return(stats::median(x, na.rm = FALSE)) |
| 119 |
} |
|
| 120 | ! |
lo <- floor(n * trim) + 1 |
| 121 | ! |
hi <- n + 1 - lo |
| 122 | ! |
x <- sort.int(x, partial = unique(c(lo, hi)))[lo:hi] |
| 123 |
} |
|
| 124 | ! |
sd(x) |
| 125 |
} |
|
| 126 | ||
| 127 |
# mdist = Mahalanobis distance |
|
| 128 |
lav_sample_mdist <- function(Y, Mp = NULL, wt = NULL, |
|
| 129 |
Mu = NULL, Sigma = NULL, |
|
| 130 |
Sinv.method = "eigen", ginv = TRUE, |
|
| 131 |
rescale = FALSE) {
|
|
| 132 |
# check input |
|
| 133 | ! |
Y <- as.matrix(Y) |
| 134 | ! |
P <- NCOL(Y) |
| 135 | ! |
if (!is.null(wt)) {
|
| 136 | ! |
N <- sum(wt) |
| 137 |
} else {
|
|
| 138 | ! |
N <- NROW(Y) |
| 139 |
} |
|
| 140 | ! |
NY <- NROW(Y) |
| 141 | ||
| 142 |
# missing data? |
|
| 143 | ! |
missing.flag <- anyNA(Y) |
| 144 | ||
| 145 |
# missing patterns? |
|
| 146 | ! |
if (missing.flag && is.null(Mp)) {
|
| 147 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 148 |
} |
|
| 149 | ||
| 150 |
# no Mu? compute sample mean |
|
| 151 | ! |
if (is.null(Mu)) {
|
| 152 | ! |
Mu <- colMeans(Y, na.rm = TRUE) |
| 153 |
} |
|
| 154 | ||
| 155 |
# no Sigma? |
|
| 156 | ! |
if (is.null(Sigma)) {
|
| 157 | ! |
if (missing.flag) {
|
| 158 | ! |
out <- lav_mvnorm_missing_h1_estimate_moments( |
| 159 | ! |
Y = Y, Mp = Mp, |
| 160 | ! |
wt = wt |
| 161 |
) |
|
| 162 | ! |
Mu <- out$Mu |
| 163 | ! |
Sigma <- out$Sigma |
| 164 |
} else {
|
|
| 165 | ! |
if (!is.null(wt)) {
|
| 166 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 167 | ! |
Sigma <- out$cov |
| 168 | ! |
Mu <- out$center |
| 169 |
} else {
|
|
| 170 | ! |
Sigma <- stats::cov(Y, use = "pairwise") |
| 171 |
# rescale? |
|
| 172 | ! |
if (rescale) {
|
| 173 | ! |
Sigma <- ((N - 1) / N) * Sigma |
| 174 |
} |
|
| 175 |
} |
|
| 176 |
} |
|
| 177 |
} |
|
| 178 | ||
| 179 |
# subtract Mu |
|
| 180 | ! |
Yc <- t(t(Y) - Mu) |
| 181 | ||
| 182 |
# DIST per case |
|
| 183 | ! |
DIST <- rep(as.numeric(NA), NY) |
| 184 | ||
| 185 |
# invert Sigma |
|
| 186 | ! |
if (ginv) {
|
| 187 | ! |
Sigma.inv <- MASS::ginv(Sigma) |
| 188 |
} else {
|
|
| 189 | ! |
Sigma.inv <- |
| 190 | ! |
try( |
| 191 | ! |
lav_matrix_symmetric_inverse( |
| 192 | ! |
S = Sigma, logdet = FALSE, |
| 193 | ! |
Sinv.method = Sinv.method |
| 194 |
), |
|
| 195 | ! |
silent = TRUE |
| 196 |
) |
|
| 197 | ! |
if (inherits(Sigma.inv, "try-error")) {
|
| 198 | ! |
lav_msg_warn(gettext( |
| 199 | ! |
"problem computing distances: could not invert Sigma" |
| 200 |
)) |
|
| 201 | ! |
return(DIST) |
| 202 |
} |
|
| 203 |
} |
|
| 204 | ||
| 205 |
# complete data? |
|
| 206 | ! |
if (!missing.flag) {
|
| 207 |
# center factor scores |
|
| 208 | ! |
Y.c <- t(t(Y) - Mu) |
| 209 |
# Mahalobis distance |
|
| 210 | ! |
DIST <- rowSums((Y.c %*% Sigma.inv) * Y.c) |
| 211 | ||
| 212 |
# missing data? |
|
| 213 |
} else {
|
|
| 214 |
# for each pattern, compute sigma.inv; compute DIST for all |
|
| 215 |
# observations of this pattern |
|
| 216 | ! |
for (p in seq_len(Mp$npatterns)) {
|
| 217 |
# observed values for this pattern |
|
| 218 | ! |
var.idx <- Mp$pat[p, ] |
| 219 | ||
| 220 |
# missing values for this pattern |
|
| 221 | ! |
na.idx <- which(!var.idx) |
| 222 | ||
| 223 |
# identify cases with this pattern |
|
| 224 | ! |
case.idx <- Mp$case.idx[[p]] |
| 225 | ||
| 226 |
# invert Sigma for this pattern |
|
| 227 | ! |
if (length(na.idx) > 0L) {
|
| 228 | ! |
if (ginv) {
|
| 229 | ! |
sigma.inv <- MASS::ginv(Sigma[-na.idx, -na.idx, drop = FALSE]) |
| 230 |
} else {
|
|
| 231 | ! |
sigma.inv <- |
| 232 | ! |
lav_matrix_symmetric_inverse_update( |
| 233 | ! |
S.inv = Sigma.inv, |
| 234 | ! |
rm.idx = na.idx, logdet = FALSE |
| 235 |
) |
|
| 236 |
} |
|
| 237 |
} else {
|
|
| 238 | ! |
sigma.inv <- Sigma.inv |
| 239 |
} |
|
| 240 | ||
| 241 | ! |
if (Mp$freq[p] == 1L) {
|
| 242 | ! |
DIST[case.idx] <- sum(sigma.inv * |
| 243 | ! |
crossprod(Yc[case.idx, var.idx, drop = FALSE])) |
| 244 |
} else {
|
|
| 245 | ! |
DIST[case.idx] <- |
| 246 | ! |
rowSums(Yc[case.idx, var.idx, drop = FALSE] %*% sigma.inv * |
| 247 | ! |
Yc[case.idx, var.idx, drop = FALSE]) |
| 248 |
} |
|
| 249 |
} # patterns |
|
| 250 |
} # missing data |
|
| 251 | ||
| 252 |
# use weights? (no for now) |
|
| 253 |
# DIST <- DIST * wt |
|
| 254 | ||
| 255 | ! |
DIST |
| 256 |
} |
|
| 257 | ||
| 258 |
# convert correlation matrix + standard deviations to covariance matrix |
|
| 259 |
# based on cov2cor in package:stats |
|
| 260 |
lav_cor2cov <- function(R, sds, names = NULL) {
|
|
| 261 | 4x |
p <- (d <- dim(R))[1L] |
| 262 | 4x |
if (!is.numeric(R) || length(d) != 2L || p != d[2L]) {
|
| 263 | ! |
lav_msg_stop(gettext("'V' is not a square numeric matrix"))
|
| 264 |
} |
|
| 265 | ||
| 266 | 4x |
if (any(!is.finite(sds))) {
|
| 267 | ! |
lav_msg_warn(gettext( |
| 268 | ! |
"sds had 0 or NA entries; non-finite result is doubtful" |
| 269 |
)) |
|
| 270 |
} |
|
| 271 | ||
| 272 |
# if(sum(diag(R)) != p) |
|
| 273 |
# stop("The diagonal of a correlation matrix should be all ones.")
|
|
| 274 | ||
| 275 | 4x |
if (p != length(sds)) {
|
| 276 | ! |
lav_msg_stop(gettext("The standard deviation vector and correlation matrix
|
| 277 | ! |
have a different number of variables")) |
| 278 |
} |
|
| 279 | ||
| 280 | 4x |
S <- R |
| 281 | 4x |
S[] <- sds * R * rep(sds, each = p) |
| 282 | ||
| 283 |
# optionally, add names |
|
| 284 | 4x |
if (!is.null(names)) {
|
| 285 | ! |
stopifnot(length(names) == p) |
| 286 | ! |
rownames(S) <- colnames(S) <- names |
| 287 |
} |
|
| 288 | ||
| 289 | 4x |
S |
| 290 |
} |
|
| 291 | ||
| 292 |
# convert characters within single quotes to numeric vector |
|
| 293 |
# eg. s <- '3 4.3 8e-3 2.0' |
|
| 294 |
# x <- lav_char2num(s) |
|
| 295 |
lav_char2num <- function(s = "") {
|
|
| 296 |
# first, strip all ',' or ';' |
|
| 297 | 5x |
s. <- gsub(",", " ", s)
|
| 298 | 5x |
s. <- gsub(";", " ", s.)
|
| 299 | 5x |
tc <- textConnection(s.) |
| 300 | 5x |
x <- scan(tc, quiet = TRUE) |
| 301 | 5x |
close(tc) |
| 302 | 5x |
x |
| 303 |
} |
|
| 304 | ||
| 305 |
# create full matrix based on lower.tri or upper.tri elements; add names |
|
| 306 |
# always ROW-WISE!! |
|
| 307 |
lav_getcov <- function(x, lower = TRUE, diagonal = TRUE, sds = NULL, |
|
| 308 |
names = paste("V", 1:nvar, sep = "")) {
|
|
| 309 |
# check x and sds |
|
| 310 | 3x |
if (is.character(x)) x <- lav_char2num(x) |
| 311 | 2x |
if (is.character(sds)) sds <- lav_char2num(sds) |
| 312 | ||
| 313 | 3x |
nels <- length(x) |
| 314 | 3x |
if (lower) {
|
| 315 | 3x |
COV <- lav_matrix_lower2full(x, diagonal = diagonal) |
| 316 |
} else {
|
|
| 317 | ! |
COV <- lav_matrix_upper2full(x, diagonal = diagonal) |
| 318 |
} |
|
| 319 | 3x |
nvar <- ncol(COV) |
| 320 | ||
| 321 |
# if diagonal is false, assume unit diagonal |
|
| 322 | ! |
if (!diagonal) diag(COV) <- 1 |
| 323 | ||
| 324 |
# check if we have a sds argument |
|
| 325 | 3x |
if (!is.null(sds)) {
|
| 326 | 2x |
stopifnot(length(sds) == nvar) |
| 327 | 2x |
COV <- lav_cor2cov(COV, sds) |
| 328 |
} |
|
| 329 | ||
| 330 |
# names |
|
| 331 | 3x |
stopifnot(length(names) == nvar) |
| 332 | 3x |
rownames(COV) <- colnames(COV) <- names |
| 333 | ||
| 334 | 3x |
COV |
| 335 |
} |
|
| 336 | ||
| 337 |
lav_char2hash <- function(s = "") {
|
|
| 338 | 118x |
stopifnot(is.character(s)) |
| 339 | 118x |
nums <- utf8ToInt(paste(s, collapse = "\n")) |
| 340 | 118x |
rval <- 0x7EDCBA98L |
| 341 | 118x |
for (i in nums) {
|
| 342 | 40969x |
positions <- 1L + (bitwAnd(i, 15L)) |
| 343 | 40969x |
bitsR <- bitwShiftL(1L, positions) - 1L |
| 344 | 40969x |
wrap1 <- bitwShiftL(bitwAnd(bitsR, rval), 31L - positions) |
| 345 | 40969x |
wrap2 <- bitwShiftR(bitwAnd(bitwNot(bitsR), rval), positions) |
| 346 | 40969x |
saw <- bitwOr(wrap1, wrap2) |
| 347 | 40969x |
rval <- bitwXor(saw, i) |
| 348 |
} |
|
| 349 | 118x |
as.hexmode(rval) |
| 350 |
} |
|
| 351 | ||
| 352 |
# vectorize all (h0 or h1) sample statistics, in the same order |
|
| 353 |
# as Gamma |
|
| 354 |
lav_implied_to_vec <- function(implied = NULL, lavmodel = NULL, |
|
| 355 |
drop.list = TRUE) {
|
|
| 356 | ! |
ngroups <- lavmodel@ngroups |
| 357 | ||
| 358 | ! |
wls_obs <- vector("list", ngroups)
|
| 359 | ! |
for (g in seq_len(ngroups)) {
|
| 360 | ||
| 361 | ! |
var <- NULL |
| 362 | ! |
res.var <- NULL |
| 363 | ! |
if (lavmodel@conditional.x) {
|
| 364 | ! |
res.var <- diag(implied$res.cov[[g]]) |
| 365 | ! |
res.var <- res.var[res.var != 1] |
| 366 |
} else {
|
|
| 367 | ! |
var <- diag(implied$cov[[g]]) |
| 368 | ! |
var <- var[var != 1] |
| 369 |
} |
|
| 370 | ||
| 371 | ! |
wls_obs[[g]] <- lav_samplestats_wls_obs( |
| 372 |
# plain |
|
| 373 | ! |
mean.g = implied$mean[[g]], |
| 374 | ! |
cov.g = implied$cov[[g]], |
| 375 | ! |
var.g = var, |
| 376 | ! |
th.g = implied$th[[g]], |
| 377 | ! |
th.idx.g = lavmodel@th.idx[[g]], |
| 378 | ||
| 379 |
# conditional.x |
|
| 380 | ! |
res.int.g = implied$res.int[[g]], |
| 381 | ! |
res.cov.g = implied$res.cov[[g]], |
| 382 | ! |
res.var.g = res.var, |
| 383 | ! |
res.th.g = implied$res.th[[g]], |
| 384 | ! |
res.slopes.g = implied$res.slopes[[g]], |
| 385 | ! |
group.w.g = implied$group.w[[g]], |
| 386 | ||
| 387 |
# flags |
|
| 388 | ! |
categorical = lavmodel@categorical, |
| 389 | ! |
conditional.x = lavmodel@conditional.x, |
| 390 | ! |
meanstructure = lavmodel@meanstructure, |
| 391 | ! |
correlation = lavmodel@correlation, |
| 392 | ! |
slopestructure = lavmodel@conditional.x, |
| 393 | ! |
group.w.free = lavmodel@group.w.free |
| 394 |
) |
|
| 395 |
} |
|
| 396 | ||
| 397 | ! |
if (drop.list) {
|
| 398 | ! |
out <- unlist(wls_obs) |
| 399 |
} else {
|
|
| 400 | ! |
out <- wls_obs |
| 401 |
} |
|
| 402 | ||
| 403 | ! |
out |
| 404 |
} |
|
| 405 | ||
| 406 |
# given a vector of sample statistics, reconstruct implied |
|
| 407 |
# entries (cov, mean, th, res.cov, ...) |
|
| 408 |
lav_vec_to_implied <- function(x = NULL, lavmodel) {
|
|
| 409 | ||
| 410 | ! |
ngroups <- lavmodel@ngroups |
| 411 | ! |
implied <- list() |
| 412 | ||
| 413 | ! |
for (g in seq_len(ngroups)) {
|
| 414 | ||
| 415 |
# number of variables |
|
| 416 | ! |
nvar <- lavmodel@nvar[g] |
| 417 | ||
| 418 |
# if group.w.free, always comes first |
|
| 419 | ! |
if (lavmodel@group.w.free) {
|
| 420 | ! |
idx <- 1L |
| 421 | ! |
group.w <- x[idx] |
| 422 | ! |
x <- x[-idx] |
| 423 |
} else {
|
|
| 424 | ! |
group.w <- 1 |
| 425 |
} |
|
| 426 | ||
| 427 | ! |
if (lavmodel@categorical) {
|
| 428 |
# TODO |
|
| 429 | ! |
cat("\n NOT READY YET! \n")
|
| 430 |
} else {
|
|
| 431 |
# diag flag |
|
| 432 | ! |
diag_flag <- TRUE |
| 433 | ! |
if (lavmodel@correlation) {
|
| 434 | ! |
diag_flag <- FALSE |
| 435 |
} |
|
| 436 | ! |
if (lavmodel@conditional.x) {
|
| 437 |
# TODO |
|
| 438 | ! |
cat("\n NOT READY YET! \n")
|
| 439 |
} |
|
| 440 | ! |
if (lavmodel@meanstructure) {
|
| 441 | ! |
idx <- seq_len(nvar) |
| 442 | ! |
mean_g <- x[idx] |
| 443 | ! |
x <- x[-idx] |
| 444 |
} else {
|
|
| 445 | ! |
mean_g <- numeric(nvar) |
| 446 |
} |
|
| 447 | ! |
if (diag_flag) {
|
| 448 | ! |
idx <- seq_len( nvar * (nvar + 1) / 2 ) |
| 449 |
} else {
|
|
| 450 | ! |
idx <- seq_len( nvar * (nvar - 1) / 2 ) |
| 451 |
} |
|
| 452 | ! |
cov_g <- lav_matrix_vech_reverse(x[idx], diagonal = diag_flag) |
| 453 | ! |
x <- x[-idx] |
| 454 | ||
| 455 |
# fill in |
|
| 456 | ! |
implied$cov[[g]] <- cov_g |
| 457 | ! |
implied$mean[[g]] <- mean_g |
| 458 | ! |
implied$th[g] <- list(NULL) |
| 459 |
} |
|
| 460 | ||
| 461 | ! |
implied$group.w[[g]] <- group.w |
| 462 |
} |
|
| 463 | ||
| 464 | ! |
implied |
| 465 |
} |
| 1 |
# here, we compute various versions of the `information' matrix |
|
| 2 |
# NOTE: |
|
| 3 |
# 1) we ALWAYS compute the UNIT information (not the total information) |
|
| 4 |
# |
|
| 5 |
# 2) by default, we ignore the constraints (we deal with this when we |
|
| 6 |
# take the inverse later on) |
|
| 7 | ||
| 8 |
lav_model_information <- function(lavmodel = NULL, |
|
| 9 |
lavsamplestats = NULL, |
|
| 10 |
lavdata = NULL, |
|
| 11 |
lavimplied = NULL, |
|
| 12 |
lavh1 = NULL, |
|
| 13 |
Delta = NULL, |
|
| 14 |
lavcache = NULL, |
|
| 15 |
lavoptions = NULL, |
|
| 16 |
extra = FALSE, |
|
| 17 |
augmented = FALSE, |
|
| 18 |
inverted = FALSE, |
|
| 19 |
use.ginv = FALSE) {
|
|
| 20 | ||
| 21 | 137x |
information <- lavoptions$information[1] # ALWAYS used the first one |
| 22 |
# caller can control it |
|
| 23 | ||
| 24 |
# rotation? |
|
| 25 |
# if(!is.null(lavoptions$rotation) && lavoptions$rotation != "none") {
|
|
| 26 |
# use.ginv <- TRUE |
|
| 27 |
# } |
|
| 28 | ||
| 29 | 137x |
if (is.null(lavh1)) {
|
| 30 | ! |
lavh1 <- lav_h1_implied_logl( |
| 31 | ! |
lavdata = lavdata, |
| 32 | ! |
lavsamplestats = lavsamplestats, |
| 33 | ! |
lavoptions = lavoptions |
| 34 |
) |
|
| 35 |
} |
|
| 36 | ||
| 37 |
# compute information matrix |
|
| 38 | 137x |
if (information == "observed") {
|
| 39 | 72x |
if (lavsamplestats@missing.flag || lavdata@nlevels > 1L) {
|
| 40 | 68x |
group.weight <- FALSE |
| 41 |
} else {
|
|
| 42 | 4x |
group.weight <- TRUE |
| 43 |
} |
|
| 44 | 72x |
E <- lav_model_information_observed( |
| 45 | 72x |
lavmodel = lavmodel, |
| 46 | 72x |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 47 | 72x |
lavimplied = lavimplied, lavh1 = lavh1, |
| 48 | 72x |
lavcache = lavcache, group.weight = group.weight, |
| 49 | 72x |
lavoptions = lavoptions, extra = extra, |
| 50 | 72x |
augmented = augmented, inverted = inverted, use.ginv = use.ginv |
| 51 |
) |
|
| 52 | 65x |
} else if (information == "expected") {
|
| 53 | 64x |
E <- lav_model_information_expected( |
| 54 | 64x |
lavmodel = lavmodel, |
| 55 | 64x |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 56 | 64x |
lavimplied = lavimplied, lavh1 = lavh1, |
| 57 | 64x |
lavcache = lavcache, lavoptions = lavoptions, extra = extra, |
| 58 | 64x |
augmented = augmented, inverted = inverted, use.ginv = use.ginv |
| 59 |
) |
|
| 60 | 1x |
} else if (information == "first.order") {
|
| 61 | 1x |
E <- lav_model_information_firstorder( |
| 62 | 1x |
lavmodel = lavmodel, |
| 63 | 1x |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 64 | 1x |
lavimplied = lavimplied, lavh1 = lavh1, |
| 65 | 1x |
lavcache = lavcache, lavoptions = lavoptions, # extra = extra, |
| 66 | 1x |
check.pd = FALSE, |
| 67 | 1x |
augmented = augmented, inverted = inverted, use.ginv = use.ginv |
| 68 |
) |
|
| 69 |
} |
|
| 70 | ||
| 71 |
# information, augmented information, or inverted information |
|
| 72 | 137x |
E |
| 73 |
} |
|
| 74 | ||
| 75 |
# fisher/expected information |
|
| 76 |
# |
|
| 77 |
# information = Delta' I1 Delta, where I1 is the unit information of |
|
| 78 |
# the saturated model (evaluated either at the structured or unstructured |
|
| 79 |
# estimates) |
|
| 80 |
lav_model_information_expected <- function(lavmodel = NULL, |
|
| 81 |
lavsamplestats = NULL, |
|
| 82 |
lavdata = NULL, |
|
| 83 |
lavoptions = NULL, |
|
| 84 |
lavimplied = NULL, |
|
| 85 |
lavh1 = NULL, |
|
| 86 |
Delta = NULL, |
|
| 87 |
lavcache = NULL, |
|
| 88 |
extra = FALSE, |
|
| 89 |
augmented = FALSE, |
|
| 90 |
inverted = FALSE, |
|
| 91 |
use.ginv = FALSE) {
|
|
| 92 | 64x |
if (inverted) {
|
| 93 | 64x |
augmented <- TRUE |
| 94 |
} |
|
| 95 | ||
| 96 |
# 1. Delta |
|
| 97 | 64x |
if (is.null(Delta)) {
|
| 98 | 64x |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 99 |
} |
|
| 100 | ||
| 101 | ||
| 102 |
# 2. H1 information (single level) |
|
| 103 | 64x |
if (lavdata@nlevels == 1L) {
|
| 104 | 64x |
A1 <- lav_model_h1_information_expected( |
| 105 | 64x |
lavmodel = lavmodel, |
| 106 | 64x |
lavsamplestats = lavsamplestats, |
| 107 | 64x |
lavdata = lavdata, |
| 108 | 64x |
lavoptions = lavoptions, |
| 109 | 64x |
lavimplied = lavimplied, |
| 110 | 64x |
lavh1 = lavh1, |
| 111 | 64x |
lavcache = lavcache |
| 112 |
) |
|
| 113 |
} else {
|
|
| 114 |
# force conditional.x = FALSE |
|
| 115 | ! |
lavimplied <- lav_model_implied_cond2uncond(lavimplied) |
| 116 |
} |
|
| 117 | ||
| 118 |
# 3. compute Information per group |
|
| 119 | 64x |
Info.group <- vector("list", length = lavsamplestats@ngroups)
|
| 120 | 64x |
for (g in 1:lavsamplestats@ngroups) {
|
| 121 |
# note LISREL documentation suggests (Ng - 1) instead of Ng... |
|
| 122 | 68x |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 123 | ||
| 124 |
# multilevel |
|
| 125 | 68x |
if (lavdata@nlevels > 1L) {
|
| 126 |
# here, we assume only 2 levels, at [[1]] and [[2]] |
|
| 127 | ! |
if (lavoptions$h1.information[1] == "structured") {
|
| 128 | ! |
Sigma.W <- lavimplied$cov[[(g - 1) * 2 + 1]] |
| 129 | ! |
Mu.W <- lavimplied$mean[[(g - 1) * 2 + 1]] |
| 130 | ! |
Sigma.B <- lavimplied$cov[[(g - 1) * 2 + 2]] |
| 131 | ! |
Mu.B <- lavimplied$mean[[(g - 1) * 2 + 2]] |
| 132 |
} else {
|
|
| 133 | ! |
Sigma.W <- lavh1$implied$cov[[(g - 1) * 2 + 1]] |
| 134 | ! |
Mu.W <- lavh1$implied$mean[[(g - 1) * 2 + 1]] |
| 135 | ! |
Sigma.B <- lavh1$implied$cov[[(g - 1) * 2 + 2]] |
| 136 | ! |
Mu.B <- lavh1$implied$mean[[(g - 1) * 2 + 2]] |
| 137 |
} |
|
| 138 | ! |
Lp <- lavdata@Lp[[g]] |
| 139 | ||
| 140 | ! |
Info.g <- |
| 141 | ! |
lav_mvnorm_cluster_information_expected_delta( |
| 142 | ! |
Lp = Lp, |
| 143 | ! |
Delta = Delta[[g]], |
| 144 | ! |
Mu.W = Mu.W, |
| 145 | ! |
Sigma.W = Sigma.W, |
| 146 | ! |
Mu.B = Mu.B, |
| 147 | ! |
Sigma.B = Sigma.B, |
| 148 | ! |
Sinv.method = "eigen" |
| 149 |
) |
|
| 150 | ! |
Info.group[[g]] <- fg * Info.g |
| 151 |
} else {
|
|
| 152 |
# compute information for this group |
|
| 153 | 68x |
if (lavmodel@estimator %in% c("DWLS", "ULS")) {
|
| 154 |
# diagonal weight matrix |
|
| 155 | 4x |
Delta2 <- sqrt(A1[[g]]) * Delta[[g]] |
| 156 | 4x |
Info.group[[g]] <- fg * crossprod(Delta2) |
| 157 |
} else {
|
|
| 158 |
# full weight matrix |
|
| 159 |
# if (lav_use_lavaanC()) {
|
|
| 160 |
# # (i) use of m_crossprod with sparse matrix on the left: |
|
| 161 |
# # Info.group[[g]] <- fg * lavaanC::m_crossprod(Delta[[g]], |
|
| 162 |
# # lavaanC::m_prod(A1[[g]], Delta[[g]], "R"), "L") |
|
| 163 |
# # |
|
| 164 |
# # (ii) use of m_prod on transposed sparse first matrix, faster than (i): |
|
| 165 |
# Info.group[[g]] <- fg * lavaanC::m_prod(t(Delta[[g]]), |
|
| 166 |
# lavaanC::m_prod(A1[[g]], Delta[[g]], "R"), "L") |
|
| 167 |
# } else {
|
|
| 168 | 64x |
Info.group[[g]] <- |
| 169 | 64x |
fg * (crossprod(Delta[[g]], A1[[g]]) %*% Delta[[g]]) |
| 170 |
# } |
|
| 171 |
} |
|
| 172 |
} |
|
| 173 |
} # g |
|
| 174 | ||
| 175 |
# 4. assemble over groups |
|
| 176 | 64x |
Information <- Info.group[[1]] |
| 177 | 64x |
if (lavsamplestats@ngroups > 1) {
|
| 178 | 4x |
for (g in 2:lavsamplestats@ngroups) {
|
| 179 | 4x |
Information <- Information + Info.group[[g]] |
| 180 |
} |
|
| 181 |
} |
|
| 182 | ||
| 183 |
# 5. augmented information? |
|
| 184 | 64x |
if (augmented) {
|
| 185 | 64x |
Information <- |
| 186 | 64x |
lav_model_information_augment_invert( |
| 187 | 64x |
lavmodel = lavmodel, |
| 188 | 64x |
information = Information, |
| 189 | 64x |
inverted = inverted, |
| 190 | 64x |
use.ginv = use.ginv |
| 191 |
) |
|
| 192 |
} |
|
| 193 | ||
| 194 | 64x |
if (extra) {
|
| 195 | 4x |
attr(Information, "Delta") <- Delta |
| 196 | 4x |
attr(Information, "WLS.V") <- A1 # unweighted |
| 197 |
} |
|
| 198 | ||
| 199 |
# possibly augmented/inverted |
|
| 200 | 64x |
Information |
| 201 |
} |
|
| 202 | ||
| 203 |
# only for Mplus MLM |
|
| 204 |
lav_model_information_expected_MLM <- function(lavmodel = NULL, |
|
| 205 |
lavsamplestats = NULL, |
|
| 206 |
Delta = NULL, |
|
| 207 |
extra = FALSE, |
|
| 208 |
augmented = FALSE, |
|
| 209 |
inverted = FALSE, |
|
| 210 |
use.ginv = FALSE) {
|
|
| 211 | ! |
if (inverted) {
|
| 212 | ! |
augmented <- TRUE |
| 213 |
} |
|
| 214 | ||
| 215 | ! |
if (is.null(Delta)) {
|
| 216 | ! |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 217 |
} |
|
| 218 | ||
| 219 |
# compute A1 |
|
| 220 | ! |
A1 <- vector("list", length = lavsamplestats@ngroups)
|
| 221 | ! |
if (lavmodel@group.w.free) {
|
| 222 | ! |
GW <- unlist(lav_model_gw(lavmodel = lavmodel)) |
| 223 |
} |
|
| 224 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 225 | ! |
A1[[g]] <- lav_mvnorm_h1_information_expected( |
| 226 | ! |
sample.cov = lavsamplestats@cov[[g]], |
| 227 | ! |
sample.cov.inv = lavsamplestats@icov[[g]], |
| 228 | ! |
x.idx = lavsamplestats@x.idx[[g]] |
| 229 |
) |
|
| 230 |
# the same as GLS... (except for the N/N-1 scaling) |
|
| 231 | ! |
if (lavmodel@group.w.free) {
|
| 232 |
# unweight!! |
|
| 233 | ! |
a <- exp(GW[g]) / lavsamplestats@nobs[[g]] |
| 234 |
# a <- exp(GW[g]) * lavsamplestats@ntotal / lavsamplestats@nobs[[g]] |
|
| 235 | ! |
A1[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), A1[[g]]) |
| 236 |
} |
|
| 237 |
} |
|
| 238 | ||
| 239 |
# compute Information per group |
|
| 240 | ! |
Info.group <- vector("list", length = lavsamplestats@ngroups)
|
| 241 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 242 | ! |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 243 |
# compute information for this group |
|
| 244 | ! |
Info.group[[g]] <- fg * (t(Delta[[g]]) %*% A1[[g]] %*% Delta[[g]]) |
| 245 |
} |
|
| 246 | ||
| 247 |
# assemble over groups |
|
| 248 | ! |
Information <- Info.group[[1]] |
| 249 | ! |
if (lavsamplestats@ngroups > 1) {
|
| 250 | ! |
for (g in 2:lavsamplestats@ngroups) {
|
| 251 | ! |
Information <- Information + Info.group[[g]] |
| 252 |
} |
|
| 253 |
} |
|
| 254 | ||
| 255 |
# augmented information? |
|
| 256 | ! |
if (augmented) {
|
| 257 | ! |
Information <- |
| 258 | ! |
lav_model_information_augment_invert( |
| 259 | ! |
lavmodel = lavmodel, |
| 260 | ! |
information = Information, |
| 261 | ! |
inverted = inverted, |
| 262 | ! |
use.ginv = use.ginv |
| 263 |
) |
|
| 264 |
} |
|
| 265 | ||
| 266 | ! |
if (extra) {
|
| 267 | ! |
attr(Information, "Delta") <- Delta |
| 268 | ! |
attr(Information, "WLS.V") <- A1 # unweighted |
| 269 |
} |
|
| 270 | ||
| 271 | ! |
Information |
| 272 |
} |
|
| 273 | ||
| 274 | ||
| 275 |
lav_model_information_observed <- function(lavmodel = NULL, |
|
| 276 |
lavsamplestats = NULL, |
|
| 277 |
lavdata = NULL, |
|
| 278 |
lavimplied = NULL, |
|
| 279 |
lavh1 = NULL, |
|
| 280 |
lavcache = NULL, |
|
| 281 |
lavoptions = NULL, |
|
| 282 |
extra = FALSE, |
|
| 283 |
group.weight = TRUE, |
|
| 284 |
augmented = FALSE, |
|
| 285 |
inverted = FALSE, |
|
| 286 |
use.ginv = FALSE) {
|
|
| 287 | 72x |
if (inverted) {
|
| 288 | 72x |
augmented <- TRUE |
| 289 |
} |
|
| 290 | ||
| 291 |
# observed.information: |
|
| 292 |
# - "hessian": second derivative of objective function |
|
| 293 |
# - "h1": observed information matrix of saturated (h1) model, |
|
| 294 |
# pre- and post-multiplied by the jacobian of the model |
|
| 295 |
# parameters (Delta), usually evaluated at the structured |
|
| 296 |
# sample statistics (but this depends on the h1.information |
|
| 297 |
# option) |
|
| 298 | 72x |
if (!is.null(lavoptions) && |
| 299 | 72x |
!is.null(lavoptions$observed.information[1]) && |
| 300 | 72x |
lavoptions$observed.information[1] == "h1") {
|
| 301 | 48x |
observed.information <- "h1" |
| 302 |
} else {
|
|
| 303 | 24x |
observed.information <- "hessian" |
| 304 |
} |
|
| 305 | ||
| 306 |
# HESSIAN based |
|
| 307 | 72x |
if (observed.information == "hessian") {
|
| 308 | 24x |
Hessian <- lav_model_hessian( |
| 309 | 24x |
lavmodel = lavmodel, |
| 310 | 24x |
lavsamplestats = lavsamplestats, |
| 311 | 24x |
lavdata = lavdata, |
| 312 | 24x |
lavoptions = lavoptions, |
| 313 | 24x |
lavcache = lavcache, |
| 314 | 24x |
group.weight = group.weight, |
| 315 | 24x |
ceq.simple = FALSE |
| 316 |
) |
|
| 317 | ||
| 318 |
# NOTE! What is the relationship between the Hessian of the objective |
|
| 319 |
# function, and the `information' matrix (unit or total) |
|
| 320 | ||
| 321 |
# 1. in lavaan, we ALWAYS minimize, so the Hessian is already pos def |
|
| 322 |
# 2. currently, all estimators give unit information, except MML and PML |
|
| 323 |
# so, no need to divide by N |
|
| 324 | 24x |
Information <- Hessian |
| 325 | ||
| 326 |
# divide by 'N' for MML and PML |
|
| 327 | 24x |
if (lavmodel@estimator == "PML" || lavmodel@estimator == "MML") {
|
| 328 | ! |
Information <- Information / lavsamplestats@ntotal |
| 329 |
# HJ: Does this need to be divided by sum of weights instead? |
|
| 330 |
} |
|
| 331 | ||
| 332 |
# if multilevel, we should divide by 'J', the number of clusters |
|
| 333 | 24x |
if (lavdata@nlevels > 1L) {
|
| 334 | 4x |
NC <- 0 |
| 335 | 4x |
for (g in 1:lavsamplestats@ngroups) {
|
| 336 | 8x |
NC <- NC + lavdata@Lp[[g]]$nclusters[[2]] |
| 337 |
} |
|
| 338 | 4x |
Information <- Information * lavsamplestats@ntotal / NC |
| 339 |
} |
|
| 340 |
} |
|
| 341 | ||
| 342 |
# using 'observed h1 information' |
|
| 343 |
# we need DELTA and 'WLS.V' (=A1) |
|
| 344 | ||
| 345 | 72x |
if (observed.information == "h1" || extra) {
|
| 346 |
# 1. Delta |
|
| 347 | 48x |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 348 | ||
| 349 |
# 2. H1 information |
|
| 350 | ||
| 351 | 48x |
A1 <- lav_model_h1_information_observed( |
| 352 | 48x |
lavmodel = lavmodel, |
| 353 | 48x |
lavsamplestats = lavsamplestats, |
| 354 | 48x |
lavdata = lavdata, |
| 355 | 48x |
lavoptions = lavoptions, |
| 356 | 48x |
lavimplied = lavimplied, |
| 357 | 48x |
lavh1 = lavh1, |
| 358 | 48x |
lavcache = lavcache |
| 359 |
) |
|
| 360 |
} |
|
| 361 | ||
| 362 | 72x |
if (observed.information == "h1") {
|
| 363 |
# compute Information per group |
|
| 364 | 48x |
Info.group <- vector("list", length = lavsamplestats@ngroups)
|
| 365 | 48x |
for (g in 1:lavsamplestats@ngroups) {
|
| 366 | 48x |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 367 |
# compute information for this group |
|
| 368 | 48x |
if (lavmodel@estimator %in% c("DWLS", "ULS")) {
|
| 369 |
# diagonal weight matrix |
|
| 370 | ! |
Delta2 <- sqrt(A1[[g]]) * Delta[[g]] |
| 371 | ! |
Info.group[[g]] <- fg * crossprod(Delta2) |
| 372 |
} else {
|
|
| 373 |
# full weight matrix |
|
| 374 | 48x |
Info.group[[g]] <- |
| 375 | 48x |
fg * (crossprod(Delta[[g]], A1[[g]]) %*% Delta[[g]]) |
| 376 |
} |
|
| 377 |
} |
|
| 378 | ||
| 379 |
# assemble over groups |
|
| 380 | 48x |
Information <- Info.group[[1]] |
| 381 | 48x |
if (lavsamplestats@ngroups > 1) {
|
| 382 | ! |
for (g in 2:lavsamplestats@ngroups) {
|
| 383 | ! |
Information <- Information + Info.group[[g]] |
| 384 |
} |
|
| 385 |
} |
|
| 386 |
} |
|
| 387 | ||
| 388 |
# augmented information? |
|
| 389 | 72x |
if (augmented) {
|
| 390 | 72x |
Information <- |
| 391 | 72x |
lav_model_information_augment_invert( |
| 392 | 72x |
lavmodel = lavmodel, |
| 393 | 72x |
information = Information, |
| 394 | 72x |
inverted = inverted, |
| 395 | 72x |
use.ginv = use.ginv |
| 396 |
) |
|
| 397 |
} |
|
| 398 | ||
| 399 | 72x |
if (extra) {
|
| 400 | ! |
attr(Information, "Delta") <- Delta |
| 401 | ! |
attr(Information, "WLS.V") <- A1 |
| 402 |
} |
|
| 403 | ||
| 404 | 72x |
Information |
| 405 |
} |
|
| 406 | ||
| 407 |
# outer product of the case-wise scores (gradients) |
|
| 408 |
# HJ 18/10/23: Need to divide sum of crossproduct of individual log-likelihoods |
|
| 409 |
# by sum of weights rather than sample size. |
|
| 410 |
lav_model_information_firstorder <- function(lavmodel = NULL, |
|
| 411 |
lavsamplestats = NULL, |
|
| 412 |
lavdata = NULL, |
|
| 413 |
lavimplied = NULL, |
|
| 414 |
lavh1 = NULL, |
|
| 415 |
lavcache = NULL, |
|
| 416 |
lavoptions = NULL, |
|
| 417 |
check.pd = FALSE, |
|
| 418 |
extra = FALSE, |
|
| 419 |
augmented = FALSE, |
|
| 420 |
inverted = FALSE, |
|
| 421 |
use.ginv = FALSE) {
|
|
| 422 | 9x |
if (!lavmodel@estimator %in% c("ML", "PML")) {
|
| 423 | ! |
lav_msg_stop(gettext( |
| 424 | ! |
"information = \"first.order\" not available for estimator"), |
| 425 | ! |
sQuote(lavmodel@estimator)) |
| 426 |
} |
|
| 427 | ||
| 428 | 9x |
if (inverted) {
|
| 429 | ! |
augmented <- TRUE |
| 430 |
} |
|
| 431 | ||
| 432 | 9x |
B0.group <- vector("list", lavsamplestats@ngroups)
|
| 433 | ||
| 434 |
# 1. Delta |
|
| 435 | 9x |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 436 | ||
| 437 |
# 2. H1 information |
|
| 438 | 9x |
B1 <- lav_model_h1_information_firstorder( |
| 439 | 9x |
lavmodel = lavmodel, |
| 440 | 9x |
lavsamplestats = lavsamplestats, |
| 441 | 9x |
lavdata = lavdata, |
| 442 | 9x |
lavoptions = lavoptions, |
| 443 | 9x |
lavimplied = lavimplied, |
| 444 | 9x |
lavh1 = lavh1, |
| 445 | 9x |
lavcache = lavcache |
| 446 |
) |
|
| 447 | ||
| 448 |
# 3. compute Information per group |
|
| 449 | 9x |
Info.group <- vector("list", length = lavsamplestats@ngroups)
|
| 450 | 9x |
for (g in 1:lavsamplestats@ngroups) {
|
| 451 |
# unweighted (needed in lav_test?) |
|
| 452 | 9x |
B0.group[[g]] <- t(Delta[[g]]) %*% B1[[g]] %*% Delta[[g]] |
| 453 | ||
| 454 |
# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 455 | ||
| 456 |
# NOTE: UNSURE ABOUT THIS PART. WHAT IS THE ROLE OF fg? |
|
| 457 | ||
| 458 | 9x |
wt <- lavdata@weights[[g]] |
| 459 | 9x |
if (is.null(wt)) {
|
| 460 | 9x |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 461 |
} else {
|
|
| 462 | ! |
totalwt <- sum(unlist(lavdata@weights)) |
| 463 | ! |
fg <- sum(wt) / totalwt |
| 464 |
} |
|
| 465 | ||
| 466 |
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 467 | ||
| 468 |
# compute information for this group |
|
| 469 | 9x |
Info.group[[g]] <- fg * B0.group[[g]] |
| 470 |
} |
|
| 471 | ||
| 472 |
# 4. assemble over groups |
|
| 473 | 9x |
Information <- Info.group[[1]] |
| 474 | 9x |
if (lavsamplestats@ngroups > 1) {
|
| 475 | ! |
for (g in 2:lavsamplestats@ngroups) {
|
| 476 | ! |
Information <- Information + Info.group[[g]] |
| 477 |
} |
|
| 478 |
} |
|
| 479 | ||
| 480 |
# NOTE: for MML and PML, we get 'total' information (instead of unit) divide |
|
| 481 |
# by 'N' for MML and PML. For weighted sample, use the sum of weights |
|
| 482 |
# instead of sample size |
|
| 483 | ||
| 484 |
# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 485 | ||
| 486 | 9x |
if (lavmodel@estimator == "PML" || lavmodel@estimator == "MML") {
|
| 487 | ! |
if (length(lavdata@sampling.weights) == 0) {
|
| 488 | ! |
the_N <- lavsamplestats@ntotal |
| 489 |
} else {
|
|
| 490 | ! |
the_N <- sum(unlist(lavdata@weights)) |
| 491 |
} |
|
| 492 | ! |
Information <- Information / the_N |
| 493 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 494 | ! |
B0.group[[g]] <- B0.group[[g]] / the_N |
| 495 |
} |
|
| 496 |
} |
|
| 497 |
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 498 | ||
| 499 |
# augmented information? |
|
| 500 | 9x |
if (augmented) {
|
| 501 | ! |
Information <- |
| 502 | ! |
lav_model_information_augment_invert( |
| 503 | ! |
lavmodel = lavmodel, |
| 504 | ! |
information = Information, |
| 505 | ! |
check.pd = check.pd, |
| 506 | ! |
inverted = inverted, |
| 507 | ! |
use.ginv = use.ginv |
| 508 |
) |
|
| 509 |
} |
|
| 510 | ||
| 511 | 9x |
if (extra) {
|
| 512 | 8x |
attr(Information, "B0.group") <- B0.group |
| 513 | 8x |
attr(Information, "Delta") <- Delta |
| 514 | 8x |
attr(Information, "WLS.V") <- B1 |
| 515 |
} |
|
| 516 | ||
| 517 | 9x |
Information |
| 518 |
} |
|
| 519 | ||
| 520 | ||
| 521 |
# create augmented information matrix (if needed), and take the inverse |
|
| 522 |
# (if inverted = TRUE), returning only the [1:npar, 1:npar] elements |
|
| 523 |
# |
|
| 524 |
# rm.idx is used by lav_sam_step2_se; it used when the structural model |
|
| 525 |
# contains more parameters than the joint model; therefore, information |
|
| 526 |
# will be 'too small', and we need to remove some columns in H |
|
| 527 |
# |
|
| 528 |
lav_model_information_augment_invert <- function(lavmodel = NULL, |
|
| 529 |
information = NULL, |
|
| 530 |
inverted = FALSE, |
|
| 531 |
check.pd = FALSE, |
|
| 532 |
use.ginv = FALSE, |
|
| 533 |
rm.idx = integer(0L)) {
|
|
| 534 | 136x |
npar <- nrow(information) |
| 535 | 136x |
is.augmented <- FALSE |
| 536 | ||
| 537 |
# handle constraints |
|
| 538 | 136x |
if (nrow(lavmodel@con.jac) > 0L) {
|
| 539 | 90x |
H <- lavmodel@con.jac |
| 540 | 90x |
if (length(rm.idx) > 0L) {
|
| 541 | ! |
H <- H[, -rm.idx, drop = FALSE] |
| 542 |
} |
|
| 543 | 90x |
inactive.idx <- attr(H, "inactive.idx") |
| 544 | 90x |
lambda <- lavmodel@con.lambda # lagrangean coefs |
| 545 | 90x |
if (length(inactive.idx) > 0L) {
|
| 546 | 80x |
H <- H[-inactive.idx, , drop = FALSE] |
| 547 | 80x |
lambda <- lambda[-inactive.idx] |
| 548 |
} |
|
| 549 | 90x |
if (nrow(H) > 0L) {
|
| 550 | 15x |
is.augmented <- TRUE |
| 551 | 15x |
H0 <- matrix(0, nrow(H), nrow(H)) |
| 552 | 15x |
H10 <- matrix(0, ncol(information), nrow(H)) |
| 553 | 15x |
DL <- 2 * diag(lambda, nrow(H), nrow(H)) |
| 554 |
# FIXME: better include inactive + slacks?? |
|
| 555 |
# INFO <- information |
|
| 556 |
# or |
|
| 557 | 15x |
INFO <- information + crossprod(H) |
| 558 | 15x |
E3 <- rbind( |
| 559 | 15x |
cbind(INFO, H10, t(H)), |
| 560 | 15x |
cbind(t(H10), DL, H0), |
| 561 | 15x |
cbind(H, H0, H0) |
| 562 |
) |
|
| 563 | 15x |
information <- E3 |
| 564 |
} |
|
| 565 | 46x |
} else if (lavmodel@ceq.simple.only) {
|
| 566 | ! |
H <- t(lav_matrix_orthogonal_complement(lavmodel@ceq.simple.K)) |
| 567 | ! |
if (length(rm.idx) > 0L) {
|
| 568 | ! |
H <- H[, -rm.idx, drop = FALSE] |
| 569 |
} |
|
| 570 | ! |
if (nrow(H) > 0L) {
|
| 571 | ! |
is.augmented <- TRUE |
| 572 | ! |
H0 <- matrix(0, nrow(H), nrow(H)) |
| 573 | ! |
H10 <- matrix(0, ncol(information), nrow(H)) |
| 574 | ! |
INFO <- information + crossprod(H) |
| 575 | ! |
E2 <- rbind( |
| 576 | ! |
cbind(INFO, t(H)), |
| 577 | ! |
cbind(H, H0) |
| 578 |
) |
|
| 579 | ! |
information <- E2 |
| 580 |
} |
|
| 581 |
} |
|
| 582 | ||
| 583 | 136x |
if (check.pd) {
|
| 584 | ! |
eigvals <- eigen(information, |
| 585 | ! |
symmetric = TRUE, |
| 586 | ! |
only.values = TRUE |
| 587 | ! |
)$values |
| 588 | ! |
if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
|
| 589 | ! |
lav_msg_warn(gettext( |
| 590 | ! |
"information matrix is not positive definite; |
| 591 | ! |
the model may not be identified")) |
| 592 |
} |
|
| 593 |
} |
|
| 594 | ||
| 595 | 136x |
if (inverted) {
|
| 596 | 136x |
if (is.augmented) {
|
| 597 |
# note: default tol in MASS::ginv is sqrt(.Machine$double.eps) |
|
| 598 |
# which seems a bit too conservative |
|
| 599 |
# from 0.5-20, we changed this to .Machine$double.eps^(3/4) |
|
| 600 | 15x |
information <- |
| 601 | 15x |
try( |
| 602 | 15x |
MASS::ginv(information, |
| 603 | 15x |
tol = .Machine$double.eps^(3 / 4) |
| 604 | 15x |
)[1:npar, |
| 605 | 15x |
1:npar, |
| 606 | 15x |
drop = FALSE |
| 607 |
], |
|
| 608 | 15x |
silent = TRUE |
| 609 |
) |
|
| 610 |
} else {
|
|
| 611 | 121x |
if (use.ginv) {
|
| 612 | ! |
information <- try( |
| 613 | ! |
MASS::ginv(information, |
| 614 | ! |
tol = .Machine$double.eps^(3 / 4) |
| 615 |
), |
|
| 616 | ! |
silent = TRUE |
| 617 |
) |
|
| 618 |
} else {
|
|
| 619 | 121x |
information <- try(solve(information), silent = TRUE) |
| 620 |
} |
|
| 621 |
} |
|
| 622 |
} |
|
| 623 | ||
| 624 |
# augmented/inverted information |
|
| 625 | 136x |
information |
| 626 |
} |
|
| 627 | ||
| 628 |
lav_model_information_expected_2l <- function(lavmodel = NULL, |
|
| 629 |
lavsamplestats = NULL, |
|
| 630 |
lavdata = NULL, |
|
| 631 |
lavoptions = NULL, |
|
| 632 |
lavimplied = NULL, |
|
| 633 |
lavh1 = NULL, |
|
| 634 |
g = 1L) {
|
|
| 635 |
# see Yuan & Bentler (2002), p.549 top line |
|
| 636 |
# I.j = nj. Delta.mu' sigma.j.inv + |
|
| 637 |
# Delta.sigma.j' W.j Delta.sigma.j + |
|
| 638 |
# (nj-1) Delta.sigma.w' W.w Delta.sigma.w |
|
| 639 |
# |
|
| 640 |
# where |
|
| 641 |
# - sigma.j = sigma.w + n.j * sigma.b |
|
| 642 |
# - W.w = 1/2 * D'(sigma.w.inv %x% sigma.w.inv) D |
|
| 643 |
# - W.j = 1/2 * D'(sigma.j.inv %x% sigma.j.inv) D |
|
| 644 |
} |
| 1 |
lav_lavaan_step01_ovnames_initflat <- function(slotParTable = NULL, # nolint |
|
| 2 |
model = NULL, |
|
| 3 |
dotdotdot.parser = "new") {
|
|
| 4 |
# if slotPartable not NULL copy to flat.model |
|
| 5 |
# else |
|
| 6 |
# if model is of type character |
|
| 7 |
# parse model to flat.model |
|
| 8 |
# else if model is a formula (** warning **) |
|
| 9 |
# transform "~ x1 + x2 + x3" to character "f =~ x1 + x2 + x3", |
|
| 10 |
# and parse to flat.model |
|
| 11 |
# transform "y =~ x1 + x2 + x3" to character and parse to flat.model |
|
| 12 |
# something else : *** error *** |
|
| 13 |
# else if model is a lavaan object |
|
| 14 |
# extract flat.model from @parTable |
|
| 15 |
# else if model is a list |
|
| 16 |
# if bare minimum present (columns lhs, op, rhs, free) |
|
| 17 |
# flat.model = model |
|
| 18 |
# replace column block by column group (if present) |
|
| 19 |
# else |
|
| 20 |
# --> *** error *** |
|
| 21 |
# else |
|
| 22 |
# --> ***error*** |
|
| 23 |
# |
|
| 24 | ||
| 25 |
# 1a. get ov.names and ov.names.x (per group) -- needed for lav_lavdata() |
|
| 26 | 140x |
if (!is.null(slotParTable)) {
|
| 27 | ! |
flat.model <- slotParTable |
| 28 | 140x |
} else if (is.character(model)) {
|
| 29 | 47x |
if (is.null(dotdotdot.parser)) {
|
| 30 | ! |
flat.model <- lavParseModelString(model, parser = "new") |
| 31 |
} else {
|
|
| 32 | 47x |
flat.model <- lavParseModelString(model, parser = dotdotdot.parser) |
| 33 |
} |
|
| 34 | 93x |
} else if (inherits(model, "formula")) {
|
| 35 |
# two typical cases: |
|
| 36 |
# 1. regression type formula |
|
| 37 |
# 2. no quotes, e.g. f =~ x1 + x2 + x3 |
|
| 38 |
# TODO: this isn't a valid formula !!! |
|
| 39 | ! |
tmp <- as.character(model) |
| 40 | ! |
if (tmp[1] == "~" && length(tmp) == 2L) {
|
| 41 |
# looks like an unquoted single factor model f =~ something |
|
| 42 | ! |
lav_msg_warn( |
| 43 | ! |
gettext("model seems to be a formula;
|
| 44 | ! |
please enclose the model syntax between quotes")) |
| 45 |
# create model and hope for the best |
|
| 46 | ! |
model.bis <- paste("f =", paste(tmp, collapse = " "), sep = "")
|
| 47 | ! |
flat.model <- lavParseModelString(model.bis) |
| 48 | ! |
} else if (tmp[1] == "~" && length(tmp) == 3L) {
|
| 49 |
# looks like a (unquoted) regression formula |
|
| 50 | ! |
lav_msg_warn( |
| 51 | ! |
gettext("model seems to be a formula;
|
| 52 | ! |
please enclose the model syntax between quotes")) |
| 53 |
# create model and hope for the best |
|
| 54 | ! |
model.bis <- paste(tmp[2], tmp[1], tmp[3]) |
| 55 | ! |
flat.model <- lavParseModelString(model.bis) |
| 56 |
} else {
|
|
| 57 | ! |
lav_msg_stop( |
| 58 | ! |
gettext("model seems to be a formula;
|
| 59 | ! |
please enclose the model syntax between quotes")) |
| 60 |
} |
|
| 61 | 93x |
} else if (inherits(model, "lavaan")) {
|
| 62 |
# hm, a lavaan model; let's try to extract the parameter table |
|
| 63 |
# and see what happens |
|
| 64 | ! |
flat.model <- parTable(model) |
| 65 | 93x |
} else if (is.list(model)) {
|
| 66 |
# a list! perhaps a full parameter table, or an initial flat model, |
|
| 67 |
# or something else... |
|
| 68 | ||
| 69 |
# 1. flat.model already (output of lavParseModelString)? |
|
| 70 | 93x |
if (!is.null(model$lhs) && !is.null(model$op) && |
| 71 | 93x |
!is.null(model$rhs) && !is.null(model$mod.idx) && |
| 72 | 93x |
!is.null(attr(model, "modifiers"))) {
|
| 73 | ! |
flat.model <- model |
| 74 |
} |
|
| 75 | ||
| 76 |
# look for the bare minimum columns: lhs - op - rhs |
|
| 77 | 93x |
else if (!is.null(model$lhs) && !is.null(model$op) && |
| 78 | 93x |
!is.null(model$rhs) && !is.null(model$free)) {
|
| 79 |
# ok, we have something that looks like a parameter table |
|
| 80 | 93x |
flat.model <- model |
| 81 | ||
| 82 |
# fix semTools issue here? for auxiliary() which does not use |
|
| 83 |
# block column yet |
|
| 84 | 93x |
if (!is.null(flat.model$block)) {
|
| 85 | 93x |
nn <- length(flat.model$lhs) |
| 86 | 93x |
if (length(flat.model$block) != nn) {
|
| 87 | ! |
flat.model$block <- flat.model$group |
| 88 |
} |
|
| 89 | 93x |
if (any(is.na(flat.model$block))) {
|
| 90 | ! |
flat.model$block <- flat.model$group |
| 91 |
} |
|
| 92 | ! |
} else if (!is.null(flat.model$group)) {
|
| 93 | ! |
flat.model$block <- flat.model$group |
| 94 |
} |
|
| 95 |
} else {
|
|
| 96 | ! |
bare.minimum <- c("lhs", "op", "rhs", "free")
|
| 97 | ! |
missing.idx <- is.na(match(bare.minimum, names(model))) |
| 98 | ! |
lav_msg_stop( |
| 99 | ! |
gettextf("model is a list, but not a parameterTable?
|
| 100 | ! |
missing column(s) in parameter table: [%s]", |
| 101 | ! |
lav_msg_view(bare.minimum[missing.idx], "none"))) |
| 102 |
} |
|
| 103 |
} else {
|
|
| 104 | ! |
lav_msg_stop(gettext("model is NULL or not a valid type for it!"))
|
| 105 |
} |
|
| 106 | ||
| 107 |
# Ok, we got a flattened model; usually this a flat.model object, but it |
|
| 108 |
# could also be an already lavaanified parTable, or a bare-minimum list with |
|
| 109 |
# lhs/op/rhs/free elements |
|
| 110 | 140x |
flat.model |
| 111 |
} |
|
| 112 | ||
| 113 |
# this function is only needed for backwards compatibility: it falls back |
|
| 114 |
# to the old (<0.6-20) way of handling composites (defined by the '<~' operator) |
|
| 115 |
# we do this by substituting the '<~' operator by '~', and by creating |
|
| 116 |
# phantom latent variables for the LHS, and setting the residual variance |
|
| 117 |
# to zero |
|
| 118 |
# |
|
| 119 |
# For example: "f <~ 1*income + occup + educ" is replaced by: |
|
| 120 |
# "f =~ 0; f ~~ 0*f; f ~ 1*income + occup + educ" |
|
| 121 |
# |
|
| 122 |
lav_lavaan_step01_ovnames_composites <- function(flat.model = NULL) { # nolint
|
|
| 123 | ||
| 124 |
# get composite idx |
|
| 125 | ! |
c.idx <- which(flat.model$op == "<~") |
| 126 | ! |
if (length(c.idx) == 0L) {
|
| 127 | ! |
return(flat.model) |
| 128 |
} |
|
| 129 | ||
| 130 |
# flat.model info |
|
| 131 | ! |
nel <- length(flat.model$lhs) |
| 132 | ! |
flat.names <- names(flat.model) |
| 133 | ! |
c.names <- unique(flat.model$lhs[c.idx]) |
| 134 | ! |
nc <- length(c.names) |
| 135 | ! |
mod.val <- max(flat.model$mod.idx) |
| 136 | ||
| 137 |
# check block numbers |
|
| 138 | ! |
max.block <- max(flat.model$block) |
| 139 | ! |
if (max.block > 1L) {
|
| 140 | ! |
lav_msg_stop(gettext("composites = FALSE is not support when multiple blocks are supported; manually replace f <~ rhs by f =~ 0; f ~~ 0*f; f ~ rhs"))
|
| 141 |
} |
|
| 142 | ||
| 143 | ! |
block <- 1L |
| 144 | ||
| 145 |
# replace '<~' by '~' |
|
| 146 | ! |
flat.model$op[c.idx] <- "~" |
| 147 | ||
| 148 |
# add phantom latent variables |
|
| 149 | ! |
flat.model$lhs <- c(flat.model$lhs, c.names) |
| 150 | ! |
flat.model$op <- c(flat.model$op, rep("=~", nc))
|
| 151 | ! |
flat.model$rhs <- c(flat.model$rhs, c.names) |
| 152 | ! |
flat.model$fixed <- c(flat.model$fixed, rep("", nc))
|
| 153 | ! |
flat.model$mod.idx <- c(flat.model$mod.idx, rep(0L, nc)) |
| 154 | ! |
flat.model$block <- c(flat.model$block, rep(block, nc)) |
| 155 | ||
| 156 |
# fix residual variances |
|
| 157 | ! |
flat.model$lhs <- c(flat.model$lhs, c.names) |
| 158 | ! |
flat.model$op <- c(flat.model$op, rep("~~", nc))
|
| 159 | ! |
flat.model$rhs <- c(flat.model$rhs, c.names) |
| 160 | ! |
flat.model$fixed <- c(flat.model$fixed, rep("0", nc)) # just for show
|
| 161 | ! |
flat.model$mod.idx <- c(flat.model$mod.idx, mod.val + seq_len(nc)) |
| 162 | ! |
flat.model$block <- c(flat.model$block, rep(block, nc)) |
| 163 | ||
| 164 |
# extend the 'other' columns |
|
| 165 | ! |
other <- flat.names[!flat.names %in% c("lhs", "op", "rhs",
|
| 166 | ! |
"fixed", "mod.idx", "block")] |
| 167 | ! |
for (o in other) {
|
| 168 | ! |
if (is.character(flat.model[[o]])) {
|
| 169 | ! |
flat.model[[o]] <- c(flat.model[[o]], rep("", nc*2))
|
| 170 | ! |
} else if(is.integer(flat.model[[o]])) {
|
| 171 | ! |
flat.model[[o]] <- c(flat.model[[o]], rep(0L, nc*2)) |
| 172 |
} else {
|
|
| 173 | ! |
flat.model[[o]] <- c(flat.model[[o]], rep(as.numeric(NA), nc*2)) |
| 174 |
} |
|
| 175 |
} |
|
| 176 | ||
| 177 |
# add fixed values to the modifier attribute |
|
| 178 | ! |
attr(flat.model, "modifiers") <- c(attr(flat.model, "modifiers"), |
| 179 | ! |
rep(list(list(fixed = 0)), nc)) |
| 180 | ||
| 181 | ! |
flat.model |
| 182 |
} |
|
| 183 | ||
| 184 |
lav_lavaan_step01_ovnames_ovorder <- function(flat.model = NULL, # nolint |
|
| 185 |
ov.order = "model", |
|
| 186 |
data = NULL, |
|
| 187 |
sample.cov = NULL, |
|
| 188 |
slotData = NULL) { # nolint
|
|
| 189 |
# set ov.order in lowercase, check if it is "data" or "model", |
|
| 190 |
# if not *** error *** |
|
| 191 |
# if ov.order == "data" |
|
| 192 |
# try adapt flat.model via lav_partable_ov_from_data |
|
| 193 |
# (** warning ** if this fails) |
|
| 194 | ||
| 195 |
# new in 0.6-14 |
|
| 196 |
# if ov.order = "data", it would seem we need to intervene here; |
|
| 197 |
# ldw 1/3/2024: |
|
| 198 |
# we do this by adding an attribute "ovda" to flat.model and partable |
|
| 199 | 140x |
ov.order <- tolower(ov.order) |
| 200 | 140x |
if (ov.order == "data") {
|
| 201 | 2x |
flat.model.orig <- flat.model |
| 202 | 2x |
try( |
| 203 | 2x |
flat.model <- lav_partable_ov_from_data(flat.model, |
| 204 | 2x |
data = data, |
| 205 | 2x |
sample.cov = sample.cov, |
| 206 | 2x |
slotData = slotData |
| 207 |
), |
|
| 208 | 2x |
silent = TRUE |
| 209 |
) |
|
| 210 | 2x |
if (inherits(flat.model, "try-error")) {
|
| 211 | ! |
lav_msg_warn(gettext("ov.order = \"data\" setting failed;
|
| 212 | ! |
switching back to ov.order = \"model\"")) |
| 213 | ! |
flat.model <- flat.model.orig |
| 214 |
} |
|
| 215 | 138x |
} else if (ov.order != "model") {
|
| 216 | ! |
lav_msg_stop(gettext( |
| 217 | ! |
"ov.order= argument should be \"model\" (default) or \"data\"")) |
| 218 |
} |
|
| 219 | ||
| 220 | 140x |
flat.model |
| 221 |
} |
|
| 222 | ||
| 223 |
lav_lavaan_step01_ovnames_group <- function(flat.model = NULL, # nolint |
|
| 224 |
ngroups = 1L) {
|
|
| 225 |
# if "group :" appears in flat.model |
|
| 226 |
# tmp.group.values: set of names in corresponding right hand sides |
|
| 227 |
# copy flat.model without attributes and call lav_model_partable, |
|
| 228 |
# store result in tmp.lav |
|
| 229 |
# extract ov.names, ov.names.y, ov.names.x, lv.names from tmp.lav |
|
| 230 |
# via lav_partable_vnames |
|
| 231 |
# else |
|
| 232 |
# if flat.model$group not NULL and more then 1 group.value |
|
| 233 |
# extract group.values via lav_partable_group_values |
|
| 234 |
# extract, for each group.value, |
|
| 235 |
# ov.names, ov.names.y, ov.names.x, lv.names from flat.model |
|
| 236 |
# via lav_partable_vnames |
|
| 237 |
# else |
|
| 238 |
# extract ov.names, ov.names.y, ov.names.x, lv.names from flat.model |
|
| 239 |
# via lav_partable_vnames |
|
| 240 |
# |
|
| 241 |
# TODO: call lav_partable_vnames only ones and not for each type |
|
| 242 | ||
| 243 | 140x |
flat.model.2 <- NULL |
| 244 | 140x |
tmp.lav <- NULL |
| 245 | 140x |
group.values <- NULL |
| 246 | 140x |
ov.names <- character(0L) |
| 247 | 140x |
if (any(flat.model$op == ":" & tolower(flat.model$lhs) == "group")) {
|
| 248 |
# here, we only need to figure out: |
|
| 249 |
# - ngroups |
|
| 250 |
# - ov's per group |
|
| 251 |
# |
|
| 252 |
# - FIXME: we need a more efficient way, avoiding |
|
| 253 |
# lav_model_partable/lav_partable_vnames |
|
| 254 |
# |
|
| 255 | 2x |
group.idx <- which(flat.model$op == ":" & |
| 256 | 2x |
tolower(flat.model$lhs) == "group") |
| 257 |
# replace by 'group' (in case we got 'Group'): |
|
| 258 | 2x |
flat.model$lhs[group.idx] <- "group" |
| 259 | 2x |
tmp.group.values <- unique(flat.model$rhs[group.idx]) |
| 260 | 2x |
tmp.ngroups <- length(tmp.group.values) |
| 261 | ||
| 262 | 2x |
flat.model.2 <- flat.model |
| 263 | 2x |
attr(flat.model.2, "modifiers") <- NULL |
| 264 | 2x |
attr(flat.model.2, "constraints") <- NULL |
| 265 | 2x |
tmp.lav <- lav_model_partable(flat.model.2, ngroups = tmp.ngroups, warn = FALSE) |
| 266 | 2x |
ov.names <- ov.names.y <- ov.names.x <- lv.names <- vector("list",
|
| 267 | 2x |
length = tmp.ngroups |
| 268 |
) |
|
| 269 | 2x |
attr(tmp.lav, "vnames") <- lav_partable_vnames(tmp.lav, type = "*") |
| 270 | 2x |
for (g in seq_len(tmp.ngroups)) {
|
| 271 | 4x |
ov.names[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav, |
| 272 | 4x |
type = "ov", group = tmp.group.values[g] |
| 273 |
))) |
|
| 274 | 4x |
ov.names.y[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav, |
| 275 | 4x |
type = "ov.nox", group = tmp.group.values[g] |
| 276 |
))) |
|
| 277 | 4x |
ov.names.x[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav, |
| 278 | 4x |
type = "ov.x", group = tmp.group.values[g] |
| 279 |
))) |
|
| 280 | 4x |
lv.names[[g]] <- unique(unlist(lav_partable_vnames(tmp.lav, |
| 281 | 4x |
type = "lv", group = tmp.group.values[g] |
| 282 |
))) |
|
| 283 |
} |
|
| 284 | 138x |
} else if (!is.null(flat.model$group)) {
|
| 285 |
# user-provided full partable with group column! |
|
| 286 | 93x |
attr(flat.model, "vnames") <- lav_partable_vnames(flat.model, type = "*") |
| 287 | 93x |
ngroups <- lav_partable_ngroups(flat.model) |
| 288 | 93x |
if (ngroups > 1L) {
|
| 289 | 4x |
group.values <- lav_partable_group_values(flat.model) |
| 290 | 4x |
ov.names <- ov.names.y <- ov.names.x <- lv.names <- vector("list",
|
| 291 | 4x |
length = ngroups |
| 292 |
) |
|
| 293 | 4x |
for (g in seq_len(ngroups)) {
|
| 294 |
# collapsed over levels (if any) |
|
| 295 | 8x |
ov.names[[g]] <- unique(unlist(lav_partable_vnames(flat.model, |
| 296 | 8x |
type = "ov", group = group.values[g] |
| 297 |
))) |
|
| 298 | 8x |
ov.names.y[[g]] <- unique(unlist(lav_partable_vnames(flat.model, |
| 299 | 8x |
type = "ov.nox", group = group.values[g] |
| 300 |
))) |
|
| 301 | 8x |
ov.names.x[[g]] <- unique(unlist(lav_partable_vnames(flat.model, |
| 302 | 8x |
type = "ov.x", group = group.values[g] |
| 303 |
))) |
|
| 304 | 8x |
lv.names[[g]] <- unique(unlist(lav_partable_vnames(flat.model, |
| 305 | 8x |
type = "lv", group = group.values[g] |
| 306 |
))) |
|
| 307 |
} |
|
| 308 |
} else {
|
|
| 309 | 89x |
ov.names <- lav_partable_vnames(flat.model, type = "ov") |
| 310 | 89x |
ov.names.y <- lav_partable_vnames(flat.model, type = "ov.nox") |
| 311 | 89x |
ov.names.x <- lav_partable_vnames(flat.model, type = "ov.x") |
| 312 | 89x |
lv.names <- lav_partable_vnames(flat.model, type = "lv") |
| 313 |
} |
|
| 314 |
} else {
|
|
| 315 |
# collapse over levels (if any) |
|
| 316 | 45x |
attr(flat.model, "vnames") <- lav_partable_vnames(flat.model, type = "*") |
| 317 | 45x |
ov.names <- unique(unlist(lav_partable_vnames(flat.model, type = "ov"))) |
| 318 | 45x |
ov.names.y <- unique(unlist(lav_partable_vnames(flat.model, |
| 319 | 45x |
type = "ov.nox"))) |
| 320 | 45x |
ov.names.x <- unique(unlist(lav_partable_vnames(flat.model, type = "ov.x"))) |
| 321 | 45x |
lv.names <- unique(unlist(lav_partable_vnames(flat.model, type = "lv"))) |
| 322 |
} |
|
| 323 | ||
| 324 |
# sanity check (new in 0.6-8): do we have any ov.names? |
|
| 325 |
# detect early |
|
| 326 | 140x |
if (length(unlist(ov.names)) == 0L) {
|
| 327 | ! |
lav_msg_stop( |
| 328 | ! |
gettext("ov.names is empty: model does not refer to any observed
|
| 329 | ! |
variables; check your syntax.")) |
| 330 |
} |
|
| 331 | ||
| 332 | 140x |
list( |
| 333 | 140x |
flat.model = flat.model, |
| 334 | 140x |
ov.names = ov.names, |
| 335 | 140x |
ov.names.x = ov.names.x, |
| 336 | 140x |
ov.names.y = ov.names.y, |
| 337 | 140x |
lv.names = lv.names, |
| 338 | 140x |
group.values = group.values, |
| 339 | 140x |
ngroups = ngroups |
| 340 |
) |
|
| 341 |
} |
|
| 342 | ||
| 343 |
lav_lavaan_step01_ovnames_checklv <- function( # nolint |
|
| 344 |
lv.names = character(0L), |
|
| 345 |
ov.names = character(0L), |
|
| 346 |
data = NULL, |
|
| 347 |
sample.cov = NULL, |
|
| 348 |
dotdotdot = NULL, |
|
| 349 |
slotOptions = NULL) { # nolint
|
|
| 350 | ||
| 351 |
# latent variable names should not appear in the subset of the data |
|
| 352 |
# that is formed by merging ov+lv names --> **warning** |
|
| 353 |
# latent interactions are not supported ---> *** error *** |
|
| 354 | ||
| 355 | 140x |
if (is.null(data) && is.null(sample.cov)) {
|
| 356 | 63x |
return(invisible(NULL)) |
| 357 |
} |
|
| 358 | ||
| 359 |
# handle for lv.names that are also observed variables (new in 0.6-6) |
|
| 360 | 77x |
lv.lv.names <- unique(unlist(lv.names)) |
| 361 | 77x |
ov.ov.names <- unique(unlist(ov.names)) |
| 362 | 77x |
if (length(lv.lv.names) > 0L) {
|
| 363 | ||
| 364 |
# get data-based variable names |
|
| 365 | 29x |
data_names <- character(0L) |
| 366 | 29x |
if (!is.null(data)) {
|
| 367 | 21x |
data_names <- names(data) |
| 368 | 8x |
} else if (!is.null(sample.cov)) {
|
| 369 | 8x |
data_names <- rownames(sample.cov) |
| 370 |
} |
|
| 371 | ||
| 372 |
# create subset of variable names, based on the model |
|
| 373 | 29x |
model_names <- unique(c(ov.ov.names, lv.lv.names)) |
| 374 | 29x |
subset_names <- data_names[data_names %in% model_names] |
| 375 | 29x |
bad.idx <- which(lv.lv.names %in% subset_names) |
| 376 | ||
| 377 | 29x |
if (length(bad.idx) > 0L) {
|
| 378 | ! |
if (!is.null(dotdotdot$check.lv.names) && |
| 379 | ! |
!dotdotdot$check.lv.names) {
|
| 380 |
# ignore it, user switched this check off -- new in 0.6-7 |
|
| 381 |
} else {
|
|
| 382 | ! |
lav_msg_warn(gettextf( |
| 383 | ! |
"Some latent variable names collide with observed variable names in |
| 384 | ! |
the dataset: %s. Please provide alternative names for the latent |
| 385 | ! |
variables, or switch off this check using check.lv.names = FALSE", |
| 386 | ! |
paste(lv.lv.names[bad.idx], collapse = " ")) |
| 387 |
) |
|
| 388 |
} |
|
| 389 |
} |
|
| 390 |
} |
|
| 391 | ||
| 392 |
# sanity check: we do not support latent interaction yet (using the :) |
|
| 393 | 77x |
lv.int.idx <- which(grepl(":", lv.lv.names))
|
| 394 | 77x |
if (length(lv.int.idx) > 0L) {
|
| 395 | ! |
if (!is.null(dotdotdot$check.lv.interaction) && |
| 396 | ! |
!dotdotdot$check.lv.interaction) {
|
| 397 |
# ignore, user (or sam) switched this check off - new in 0.6-16 |
|
| 398 | ! |
} else if (!is.null(slotOptions) && !slotOptions$check.lv.interaction) {
|
| 399 |
# ignore |
|
| 400 |
} else {
|
|
| 401 | ! |
lav_msg_stop(gettextf( |
| 402 | ! |
"Interaction terms involving latent variables (%s) are not supported. |
| 403 | ! |
Either use the sam() function, or consider using the modsem package.", |
| 404 | ! |
lv.lv.names[lv.int.idx[1]])) |
| 405 |
} |
|
| 406 |
} |
|
| 407 | ||
| 408 | 77x |
invisible(NULL) |
| 409 |
} |
|
| 410 | ||
| 411 |
lav_lavaan_step01_ovnames_namesl <- function(data = NULL, # nolint |
|
| 412 |
cluster = NULL, |
|
| 413 |
flat.model = NULL, |
|
| 414 |
group.values = NULL, |
|
| 415 |
ngroups = 1L) {
|
|
| 416 |
# if "level :" appears in flat.model |
|
| 417 |
# if data not NULL, cluster must not be NULL, if it is: *** error *** |
|
| 418 |
# compute tmp.group.values and tmp.level.values from flat.model |
|
| 419 |
# there should be at least 2 levels, if not *** error *** |
|
| 420 |
# copy flat.model without attributes and lav_model_partable -> tmp.lav |
|
| 421 |
# check at least 2 levels for tmp.lav, if not *** error *** |
|
| 422 |
# compute ov.names.l per group and per level (via lav_partable_vnames |
|
| 423 |
# on tmp.lav) |
|
| 424 |
# else |
|
| 425 |
# if lav_partable_nlevels(flat.model) > 0 |
|
| 426 |
# if data not NULL, cluster must not be NULL, if it is: *** error *** |
|
| 427 |
# compute ov.names.l per group and per level (via lav_partable_vnames |
|
| 428 |
# on flat.model) |
|
| 429 |
# else |
|
| 430 |
# there are no levels (ov.names.l = list()) |
|
| 431 | ||
| 432 |
# handle ov.names.l |
|
| 433 | 140x |
if (any(flat.model$op == ":" & tolower(flat.model$lhs) == "level")) {
|
| 434 |
# check for cluster argument |
|
| 435 | 2x |
if (!is.null(data) && is.null(cluster)) {
|
| 436 | ! |
lav_msg_stop(gettext("cluster argument is missing."))
|
| 437 |
} |
|
| 438 | ||
| 439 |
# here, we only need to figure out: |
|
| 440 |
# - nlevels |
|
| 441 |
# - ov's per level |
|
| 442 |
# - FIXME: we need a more efficient way, avoiding lav_model_partable/vnames |
|
| 443 | ||
| 444 | 2x |
group.idx <- which(flat.model$op == ":" & flat.model$lhs == "group") |
| 445 | 2x |
tmp.group.values <- unique(flat.model$rhs[group.idx]) |
| 446 | 2x |
tmp.ngroups <- max(c(length(tmp.group.values), 1)) |
| 447 | ||
| 448 | 2x |
level.idx <- which(flat.model$op == ":" & |
| 449 | 2x |
tolower(flat.model$lhs) == "level") |
| 450 |
# replace by "level" (in case we got 'Level') |
|
| 451 | 2x |
flat.model$lhs[level.idx] <- "level" |
| 452 | 2x |
tmp.level.values <- unique(flat.model$rhs[level.idx]) |
| 453 | 2x |
tmp.nlevels <- length(tmp.level.values) |
| 454 | ||
| 455 |
# we need at least 2 levels (for now) |
|
| 456 | 2x |
if (tmp.nlevels < 2L) {
|
| 457 | ! |
lav_msg_stop( |
| 458 | ! |
gettext("when data is clustered, you must specify a model
|
| 459 | ! |
for each level in the model syntax (for now); |
| 460 | ! |
see example(Demo.twolevel)") |
| 461 |
) |
|
| 462 |
} |
|
| 463 | ||
| 464 | 2x |
flat.model.2 <- flat.model |
| 465 | 2x |
attr(flat.model.2, "modifiers") <- NULL |
| 466 | 2x |
attr(flat.model.2, "constraints") <- NULL |
| 467 | 2x |
tmp.lav <- lav_model_partable(flat.model.2, ngroups = tmp.ngroups, warn = FALSE) |
| 468 |
# check for empty levels |
|
| 469 | 2x |
if (max(tmp.lav$level) < 2L) {
|
| 470 | ! |
lav_msg_stop( |
| 471 | ! |
gettext("at least one level has no model syntax;
|
| 472 | ! |
you must specify a model for each level in the model syntax; |
| 473 | ! |
see example(Demo.twolevel)") |
| 474 |
) |
|
| 475 |
} |
|
| 476 | 2x |
ov.names.l <- vector("list", length = tmp.ngroups) # per group
|
| 477 | ||
| 478 | 2x |
for (g in seq_len(tmp.ngroups)) {
|
| 479 | 4x |
ov.names.l[[g]] <- vector("list", length = tmp.nlevels)
|
| 480 | 4x |
for (l in seq_len(tmp.nlevels)) {
|
| 481 | 8x |
if (tmp.ngroups > 1L) {
|
| 482 | 8x |
ov.names.l[[g]][[l]] <- |
| 483 | 8x |
unique(unlist(lav_partable_vnames(tmp.lav, |
| 484 | 8x |
type = "ov", |
| 485 | 8x |
group = tmp.group.values[g], |
| 486 | 8x |
level = tmp.level.values[l] |
| 487 |
))) |
|
| 488 |
} else {
|
|
| 489 | ! |
ov.names.l[[g]][[l]] <- |
| 490 | ! |
unique(unlist(lav_partable_vnames(tmp.lav, |
| 491 | ! |
type = "ov", |
| 492 | ! |
level = tmp.level.values[l] |
| 493 |
))) |
|
| 494 |
} |
|
| 495 |
} # levels |
|
| 496 |
} # groups |
|
| 497 |
} else {
|
|
| 498 |
# perhaps model is already a parameter table |
|
| 499 | 138x |
nlevels <- lav_partable_nlevels(flat.model) |
| 500 | 138x |
if (nlevels > 1L) {
|
| 501 |
# check for cluster argument (only if we have data) |
|
| 502 | 2x |
if (!is.null(data) && is.null(cluster)) {
|
| 503 | ! |
lav_msg_stop(gettext("cluster argument is missing."))
|
| 504 |
} |
|
| 505 | ||
| 506 | 2x |
ngroups <- lav_partable_ngroups(flat.model) |
| 507 | 2x |
group.values <- lav_partable_group_values(flat.model) |
| 508 | 2x |
ov.names.l <- vector("list", length = ngroups)
|
| 509 | 2x |
for (g in 1:ngroups) {
|
| 510 |
# note: lav_object_vnames() will return a list if any level: |
|
| 511 | 4x |
ov.names.l[[g]] <- lav_object_vnames(flat.model, "ov", group = group.values[g]) |
| 512 |
} |
|
| 513 |
} else {
|
|
| 514 |
# no level: in model syntax |
|
| 515 | 136x |
ov.names.l <- list() |
| 516 |
} |
|
| 517 |
} |
|
| 518 | ||
| 519 | 140x |
list( |
| 520 | 140x |
flat.model = flat.model, |
| 521 | 140x |
ov.names.l = ov.names.l |
| 522 |
) |
|
| 523 |
} |
|
| 524 | ||
| 525 |
lav_lavaan_step01_ovnames_ordered <- function(ordered = NULL, # nolint |
|
| 526 |
flat.model = NULL, |
|
| 527 |
data = NULL) {
|
|
| 528 |
# interpretation and check ordered parameter, modify if needed |
|
| 529 | ||
| 530 |
# sanity check ordered argument (just in case, add lhs variables names) |
|
| 531 | 140x |
if (!is.null(ordered)) { # new in 0.6-4
|
| 532 | 2x |
if (is.logical(ordered) && ordered) { # ordered = TRUE
|
| 533 |
# assume the user means: ordered = names(Data) |
|
| 534 | ! |
ordered <- lav_object_vnames(flat.model, "ov.nox") # new in 0.6-6: changed from ov |
| 535 | 2x |
} else if (is.logical(ordered) && !ordered) {
|
| 536 | ! |
ordered <- character(0L) |
| 537 | 2x |
} else if (!is.character(ordered)) {
|
| 538 | ! |
lav_msg_stop(gettext("ordered argument must be a character vector"))
|
| 539 | 2x |
} else if (length(ordered) == 1L && nchar(ordered) == 0L) {
|
| 540 | ! |
ordered <- character(0L) |
| 541 |
} else {
|
|
| 542 |
# check if all names in "ordered" occur in the dataset? |
|
| 543 | 2x |
if (!is.null(data)) {
|
| 544 | 2x |
if (inherits(data, "data.frame")) {
|
| 545 | 2x |
data_names <- names(data) |
| 546 | ! |
} else if (inherits(data, "matrix")) {
|
| 547 | ! |
data_names <- colnames(data) |
| 548 |
} |
|
| 549 | 2x |
missing.idx <- which(!ordered %in% data_names) |
| 550 | 2x |
if (length(missing.idx) > 0L) { # FIXme: warn = FALSE has no eff
|
| 551 | ! |
lav_msg_warn(gettextf( |
| 552 | ! |
"ordered variable(s): %s could not be found |
| 553 | ! |
in the data and will be ignored", |
| 554 | ! |
paste(ordered[missing.idx], collapse = " "))) |
| 555 |
} |
|
| 556 |
} |
|
| 557 |
} |
|
| 558 |
} |
|
| 559 | ||
| 560 |
# add the variable names that were treated as ordinal |
|
| 561 |
# in the model syntax |
|
| 562 | 140x |
ordered <- unique(c(ordered, lav_object_vnames(flat.model, "ov.ord"))) |
| 563 | ||
| 564 | 140x |
ordered |
| 565 |
} |
| 1 |
# lavaan parameter table |
|
| 2 |
# |
|
| 3 |
# initial version: YR 22/05/2009 |
|
| 4 |
# major revision: YR 02/11/2010: - FLATTEN the model syntax and turn it into a |
|
| 5 |
# data.frame, with a "modifiers" attribute |
|
| 6 |
# - add default elements here |
|
| 7 |
# - check for duplicate elements |
|
| 8 |
# - allow for every possible model... |
|
| 9 |
# - since 0.4-5 |
|
| 10 |
# - the end result is a full description of |
|
| 11 |
# a model (but no matrix representation) |
|
| 12 |
# - 14 Jan 2014: merge 02lavaanUser.R with lav_partable.R |
|
| 13 |
# move syntax-based code to lav_syntax.R |
|
| 14 |
# - 26 April 2016: handle multiple 'blocks' (levels, classes, groups, ...) |
|
| 15 |
# - 24 March 2019: handle efa sets |
|
| 16 |
# - 23 May 2020: support for random slopes |
|
| 17 | ||
| 18 |
lav_model_partable <- function( |
|
| 19 |
model = NULL, |
|
| 20 |
meanstructure = FALSE, |
|
| 21 |
int.ov.free = FALSE, |
|
| 22 |
int.lv.free = FALSE, |
|
| 23 |
marker.int.zero = FALSE, |
|
| 24 |
orthogonal = FALSE, |
|
| 25 |
orthogonal.y = FALSE, |
|
| 26 |
orthogonal.x = FALSE, |
|
| 27 |
orthogonal.efa = FALSE, |
|
| 28 |
std.lv = FALSE, |
|
| 29 |
correlation = FALSE, |
|
| 30 |
composites = TRUE, |
|
| 31 |
effect.coding = "", |
|
| 32 |
conditional.x = FALSE, |
|
| 33 |
fixed.x = FALSE, |
|
| 34 |
parameterization = "delta", |
|
| 35 |
constraints = NULL, |
|
| 36 |
ceq.simple = FALSE, |
|
| 37 |
auto = FALSE, |
|
| 38 |
model.type = "sem", |
|
| 39 |
auto.fix.first = FALSE, |
|
| 40 |
auto.fix.single = FALSE, |
|
| 41 |
auto.var = FALSE, |
|
| 42 |
auto.cov.lv.x = FALSE, |
|
| 43 |
auto.cov.y = FALSE, |
|
| 44 |
auto.th = FALSE, |
|
| 45 |
auto.delta = FALSE, |
|
| 46 |
auto.efa = FALSE, |
|
| 47 |
varTable = NULL, # nolint |
|
| 48 |
ngroups = 1L, |
|
| 49 |
nthresholds = NULL, |
|
| 50 |
group.equal = NULL, |
|
| 51 |
group.partial = NULL, |
|
| 52 |
group.w.free = FALSE, |
|
| 53 |
debug = FALSE, |
|
| 54 |
warn = TRUE, |
|
| 55 |
as.data.frame. = TRUE) { # nolint
|
|
| 56 | 51x |
if (!missing(debug)) {
|
| 57 | ! |
current.debug <- lav_debug() |
| 58 | ! |
if (lav_debug(debug)) |
| 59 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 60 |
} |
|
| 61 | 51x |
if (!missing(warn)) {
|
| 62 | 4x |
current.warn <- lav_warn() |
| 63 | 4x |
if (lav_warn(warn)) |
| 64 | 4x |
on.exit(lav_warn(current.warn), TRUE) |
| 65 |
} |
|
| 66 |
# check if model is already flat or a full parameter table |
|
| 67 | 51x |
if (is.list(model) && !is.null(model$lhs)) {
|
| 68 | 51x |
if (is.null(model$mod.idx)) {
|
| 69 | ! |
lav_msg_warn(gettext("input already looks like a parameter table"))
|
| 70 | ! |
return(lav_partable_set_cache(model)) |
| 71 |
} else {
|
|
| 72 | 51x |
flat <- model |
| 73 |
} |
|
| 74 |
} else {
|
|
| 75 |
# parse the model syntax and flatten the user-specified model |
|
| 76 |
# return a data.frame, where each line is a model element (rhs, op, lhs) |
|
| 77 | ! |
flat <- lavParseModelString( |
| 78 | ! |
model.syntax = model, debug = FALSE |
| 79 |
) |
|
| 80 |
} |
|
| 81 |
# user-specified *modifiers* are returned as an attribute |
|
| 82 | 51x |
tmp.mod <- attr(flat, "modifiers") |
| 83 | 51x |
attr(flat, "modifiers") <- NULL |
| 84 |
# user-specified *constraints* are returned as an attribute |
|
| 85 | 51x |
tmp.con <- attr(flat, "constraints") |
| 86 | 51x |
attr(flat, "constraints") <- NULL |
| 87 | ||
| 88 |
# ov.names.data? |
|
| 89 | 51x |
ov.names.data <- attr(flat, "ovda") |
| 90 | ||
| 91 |
# extra constraints? |
|
| 92 | 51x |
if (!is.null(constraints) && any(nchar(constraints) > 0L)) {
|
| 93 | 2x |
flat2 <- lavParseModelString(model.syntax = constraints, warn = lav_warn()) |
| 94 | 2x |
con2 <- attr(flat2, "constraints") |
| 95 | 2x |
rm(flat2) |
| 96 | 2x |
tmp.con <- c(tmp.con, con2) |
| 97 |
} |
|
| 98 | 51x |
if (length(tmp.con) > 0L) {
|
| 99 |
# add 'user' column |
|
| 100 | 4x |
tmp.con <- lapply(tmp.con, function(x) {
|
| 101 | 6x |
x$user <- 1L |
| 102 | 6x |
x |
| 103 |
}) |
|
| 104 |
# any explicit (in)equality constraints? (ignoring := definitions) |
|
| 105 | 4x |
tmp.con.nondef.flag <- (sum(sapply(tmp.con, "[[", "op") |
| 106 | 4x |
%in% c("==", "<", ">")) > 0L)
|
| 107 |
# any explicit equality constraints? |
|
| 108 | 4x |
tmp.con.eq.flag <- (sum(sapply(tmp.con, "[[", "op") == "==") > 0L) |
| 109 | 4x |
if (tmp.con.nondef.flag) {
|
| 110 | 2x |
ceq.simple <- FALSE |
| 111 |
} |
|
| 112 |
} |
|
| 113 | ||
| 114 | 51x |
if (lav_debug()) {
|
| 115 | ! |
cat("[lavaan DEBUG]: flat (flattened user model):\n")
|
| 116 | ! |
print(flat) |
| 117 | ! |
cat("[lavaan DEBUG]: tmp.mod (modifiers):\n")
|
| 118 | ! |
print(str(tmp.mod)) |
| 119 | ! |
cat("[lavaan DEBUG]: tmp.con (constraints):\n")
|
| 120 | ! |
print(str(tmp.con)) |
| 121 |
} |
|
| 122 | ||
| 123 |
# bogus varTable? (if data.type == "none") |
|
| 124 | 51x |
if (!is.null(varTable)) {
|
| 125 | 47x |
if (!is.list(varTable) || is.null(varTable$name)) {
|
| 126 | ! |
lav_msg_stop(gettext( |
| 127 | ! |
"varTable is not a list or does not contain variable names.")) |
| 128 |
} |
|
| 129 | 47x |
if (all(varTable$nobs == 0)) {
|
| 130 | 2x |
varTable <- NULL # nolint |
| 131 |
} |
|
| 132 |
} |
|
| 133 | ||
| 134 |
# check for wrongly specified variances/covariances/intercepts |
|
| 135 |
# of exogenous variables in model syntax (if fixed.x=TRUE) |
|
| 136 | 51x |
if (fixed.x && lav_warn()) { # we ignore the groups here!
|
| 137 |
# we only call this function for the warning message |
|
| 138 | 12x |
tmp <- lav_partable_vnames(flat, "ov.x", force.warn = TRUE) |
| 139 | 12x |
rm(tmp) |
| 140 |
} |
|
| 141 | ||
| 142 |
# check if group.equal is non-empty, but ngroups = 1L |
|
| 143 |
# fixme: triggers this if mimic="Mplus"! |
|
| 144 |
# if(ngroups == 1L && length(group.equal) > 0L) {
|
|
| 145 |
# warning("lavaan WARNING: group.equal= argument",
|
|
| 146 |
# " has no effect if no groups are specified.") |
|
| 147 |
# } |
|
| 148 | ||
| 149 |
# auto=TRUE? |
|
| 150 | 51x |
if (auto) { # mimic sem/cfa auto behavior
|
| 151 | ! |
if (model.type == "sem") {
|
| 152 | ! |
int.ov.free <- TRUE |
| 153 | ! |
int.lv.free <- FALSE |
| 154 | ! |
auto.fix.first <- !std.lv |
| 155 | ! |
auto.fix.single <- TRUE |
| 156 | ! |
auto.var <- TRUE |
| 157 | ! |
auto.cov.lv.x <- TRUE |
| 158 | ! |
auto.cov.y <- TRUE |
| 159 | ! |
auto.th <- TRUE |
| 160 | ! |
auto.delta <- TRUE |
| 161 | ! |
auto.efa <- TRUE |
| 162 | ! |
} else if (model.type == "growth") {
|
| 163 | ! |
model.type <- "growth" |
| 164 | ! |
int.ov.free <- FALSE |
| 165 | ! |
int.lv.free <- TRUE |
| 166 | ! |
auto.fix.first <- !std.lv |
| 167 | ! |
auto.fix.single <- TRUE |
| 168 | ! |
auto.var <- TRUE |
| 169 | ! |
auto.cov.lv.x <- TRUE |
| 170 | ! |
auto.cov.y <- TRUE |
| 171 | ! |
auto.th <- TRUE |
| 172 | ! |
auto.delta <- TRUE |
| 173 | ! |
auto.efa <- TRUE |
| 174 |
} |
|
| 175 |
} |
|
| 176 | ||
| 177 |
# check for meanstructure |
|
| 178 | 51x |
if (any(flat$op == "~1")) {
|
| 179 | 4x |
meanstructure <- TRUE |
| 180 |
} |
|
| 181 | ||
| 182 |
# check for block identifiers in the syntax (op = ":") |
|
| 183 | 51x |
n.block.flat <- length(which(flat$op == ":")) |
| 184 |
# this is NOT the number of blocks (eg group 1: level 1: -> 1 block) |
|
| 185 | ||
| 186 |
# for each non-empty `block' in n.block.flat, produce a USER |
|
| 187 | 51x |
if (n.block.flat > 0L) {
|
| 188 |
# make sure flat is a data.frame |
|
| 189 | 6x |
flat <- as.data.frame(flat, stringsAsFactors = FALSE) |
| 190 | ||
| 191 |
# what are the block lhs labels? |
|
| 192 | 6x |
blocks.lhs.all <- tolower(flat$lhs[flat$op == ":"]) |
| 193 | 6x |
tmp.block.lhs <- unique(blocks.lhs.all) |
| 194 | ||
| 195 |
# if we have group and level, check that group comes first! |
|
| 196 | 6x |
if ("group" %in% tmp.block.lhs && "level" %in% tmp.block.lhs) {
|
| 197 | 6x |
group.idx <- which(tmp.block.lhs == "group") |
| 198 | 6x |
level.idx <- which(tmp.block.lhs == "level") |
| 199 | 6x |
if (group.idx > level.idx) {
|
| 200 | ! |
lav_msg_stop(gettext( |
| 201 | ! |
"levels must be nested within groups (not the other way around).")) |
| 202 |
} |
|
| 203 |
} |
|
| 204 | ||
| 205 |
# block op == ":" indices |
|
| 206 | 6x |
block.op.idx <- which(flat$op == ":") |
| 207 | ||
| 208 |
# check for wrong spelled 'group' lhs |
|
| 209 | 6x |
if (length(grep("group", tmp.block.lhs)) > 1L) {
|
| 210 | ! |
lav_msg_warn(gettext("ambiguous block identifiers for group:"),
|
| 211 | ! |
lav_msg_view(tmp.block.lhs[grep("group", tmp.block.lhs)], "none"))
|
| 212 |
} |
|
| 213 | ||
| 214 |
# no empty :rhs fields allowed! |
|
| 215 | 6x |
if (any(nchar(flat$rhs[block.op.idx]) == 0L)) {
|
| 216 | ! |
empty.idx <- nchar(flat$rhs[block.op.idx]) == 0L |
| 217 | ! |
txt <- paste(flat$lhs[block.op.idx][empty.idx], ":") |
| 218 | ! |
lav_msg_stop(gettext( |
| 219 | ! |
"syntax contains block identifiers with missing numbers/labels: "), txt) |
| 220 |
} |
|
| 221 | ||
| 222 |
# check for ngroups (ngroups is based on the data!) |
|
| 223 | 6x |
if ("group" %in% tmp.block.lhs) {
|
| 224 |
# how many group blocks? |
|
| 225 | 6x |
group.block.idx <- flat$op == ":" & flat$lhs == "group" |
| 226 | 6x |
n.group.flat <- length(unique(flat$rhs[group.block.idx])) |
| 227 | ||
| 228 | 6x |
if (n.group.flat > 0L && n.group.flat != ngroups) {
|
| 229 | ! |
lav_msg_stop(gettextf( |
| 230 | ! |
"syntax defines %1$s groups; data (or argument ngroups) |
| 231 | ! |
suggests %2$s groups", n.group.flat, ngroups)) |
| 232 |
} |
|
| 233 |
} |
|
| 234 | ||
| 235 |
# figure out how many 'blocks' we have, and store indices/block.labels |
|
| 236 | 6x |
tmp.block.rhs <- rep("0", length(tmp.block.lhs))
|
| 237 | 6x |
block.id <- 0L |
| 238 | 6x |
block.info <- vector("list", length = n.block.flat) # too large
|
| 239 | 6x |
block.op.idx1 <- c(block.op.idx, nrow(flat) + 1L) # add addition row |
| 240 | 6x |
for (block.op in seq_len(n.block.flat)) {
|
| 241 |
# fill block.rhs value(s) |
|
| 242 | 36x |
block.lhs <- flat$lhs[block.op.idx1[block.op]] |
| 243 | 36x |
block.rhs <- flat$rhs[block.op.idx1[block.op]] |
| 244 | 36x |
tmp.block.rhs[which(block.lhs == tmp.block.lhs)] <- block.rhs |
| 245 | ||
| 246 |
# another block identifier? |
|
| 247 | 36x |
if (block.op.idx1[block.op + 1L] - block.op.idx1[block.op] == 1L) {
|
| 248 | 12x |
next |
| 249 |
} |
|
| 250 | ||
| 251 |
# we have a 'block' |
|
| 252 | 24x |
block.id <- block.id + 1L |
| 253 | ||
| 254 |
# select flat rows for this block |
|
| 255 | 24x |
tmp.idx <- seq.int( |
| 256 | 24x |
block.op.idx1[block.op] + 1L, |
| 257 | 24x |
block.op.idx1[block.op + 1L] - 1L |
| 258 |
) |
|
| 259 | ||
| 260 |
# store info in block.info |
|
| 261 | 24x |
block.info[[block.id]] <- list( |
| 262 | 24x |
lhs = tmp.block.lhs, # always the same |
| 263 | 24x |
rhs = tmp.block.rhs, # for this block |
| 264 | 24x |
idx = tmp.idx |
| 265 |
) |
|
| 266 |
} |
|
| 267 | 6x |
block.info <- block.info[seq_len(block.id)] |
| 268 | ||
| 269 |
# new in 0.6-12 |
|
| 270 |
# check for blocks with the same block.rhs combination |
|
| 271 |
# (perhaps added later?) |
|
| 272 |
# - merge the indices |
|
| 273 |
# - remove the duplicated blocks |
|
| 274 | 6x |
block.labels <- sapply(lapply(block.info, "[[", "rhs"), |
| 275 | 6x |
paste, |
| 276 | 6x |
collapse = "." |
| 277 |
) |
|
| 278 | 6x |
nblocks <- length(unique(block.labels)) |
| 279 | 6x |
if (nblocks < length(block.labels)) {
|
| 280 |
# it would appear we have duplicated block.labels -> merge |
|
| 281 | ! |
dup.idx <- which(duplicated(block.labels)) |
| 282 | ! |
for (i in seq_along(dup.idx)) {
|
| 283 | ! |
this.dup.idx <- dup.idx[i] |
| 284 | ! |
orig.idx <- which(block.labels == block.labels[this.dup.idx])[1] |
| 285 | ! |
block.info[[orig.idx]]$idx <- c( |
| 286 | ! |
block.info[[orig.idx]]$idx, |
| 287 | ! |
block.info[[this.dup.idx]]$idx |
| 288 |
) |
|
| 289 |
} |
|
| 290 | ! |
block.info <- block.info[-dup.idx] |
| 291 |
} |
|
| 292 | ||
| 293 |
# split the flat data.frame per `block', create tmp.list |
|
| 294 |
# for each `block', and rbind them together, adding block columns |
|
| 295 | 6x |
for (block in seq_len(nblocks)) {
|
| 296 | 24x |
tmp.block.rhs <- block.info[[block]]$rhs |
| 297 | 24x |
block.lhs <- block.info[[block]]$lhs[length(tmp.block.lhs)] # last one |
| 298 | 24x |
block.idx <- block.info[[block]]$idx |
| 299 | ||
| 300 | 24x |
flat.block <- flat[block.idx, ] |
| 301 |
# rm 'block' column (if any) in flat.block |
|
| 302 | 24x |
flat.block$block <- NULL |
| 303 | ||
| 304 |
# new in 0.6-7: check for random slopes, add them here |
|
| 305 | 24x |
if (block.lhs == "level" && |
| 306 | 24x |
block > 1L && # FIXME: multigroup, multilevel |
| 307 | 24x |
!is.null(flat$rv) && |
| 308 | 24x |
any(nchar(flat$rv) > 0L)) {
|
| 309 | ! |
lv.names.rv <- unique(flat$rv[nchar(flat$rv) > 0L]) |
| 310 | ! |
for (i in seq_along(lv.names.rv)) {
|
| 311 |
# add phantom latent variable |
|
| 312 | ! |
tmp <- flat.block[1, ] |
| 313 | ! |
tmp$lhs <- lv.names.rv[i] |
| 314 | ! |
tmp$op <- "=~" |
| 315 | ! |
tmp$rhs <- lv.names.rv[i] |
| 316 | ! |
tmp$mod.idx <- max(flat$mod.idx) + i |
| 317 | ! |
tmp$fixed <- "0" |
| 318 | ! |
tmp$start <- "" |
| 319 | ! |
tmp$lower <- "" |
| 320 | ! |
tmp$upper <- "" |
| 321 | ! |
tmp$label <- "" |
| 322 | ! |
tmp$prior <- "" |
| 323 | ! |
tmp$efa <- "" |
| 324 | ! |
tmp$rv <- lv.names.rv[i] |
| 325 | ! |
flat.block <- rbind(flat.block, tmp, deparse.level = 0L) |
| 326 | ! |
tmp.mod <- c(tmp.mod, list(list(fixed = 0))) |
| 327 |
} |
|
| 328 |
} |
|
| 329 | ||
| 330 |
# new in 0.6-8: if multilevel, use 'global' ov.names.x |
|
| 331 | 24x |
if (fixed.x && block.lhs == "level") {
|
| 332 | ! |
tmp.ov.names.x <- lav_partable_vnames(flat, "ov.x") # global |
| 333 | ! |
ov.names.x.block <- lav_partable_vnames(flat.block, "ov.x") |
| 334 | ! |
if (length(ov.names.x.block) > 0L) {
|
| 335 | ! |
idx <- which(!ov.names.x.block %in% tmp.ov.names.x) |
| 336 | ! |
if (length(idx) > 0L) {
|
| 337 |
# warn! |
|
| 338 | ! |
lav_msg_warn(gettextf( |
| 339 | ! |
"the variable(s) [%s] are exogenous at one level, but endogenous |
| 340 | ! |
at another level. These variables will be treated as endogenous, |
| 341 | ! |
and their variances/intercepts will be freely estimated. |
| 342 | ! |
To remove this warning, use fixed.x = FALSE.", |
| 343 | ! |
lav_msg_view(ov.names.x.block[idx], "none"))) |
| 344 | ! |
ov.names.x.block <- ov.names.x.block[-idx] |
| 345 |
} |
|
| 346 |
} |
|
| 347 |
} else {
|
|
| 348 | 24x |
ov.names.x.block <- NULL |
| 349 |
} |
|
| 350 | ||
| 351 |
# new in 0.6-12: if multilevel and conditional.x, make sure |
|
| 352 |
# that 'splitted' exogenous covariates become 'y' variables |
|
| 353 | 24x |
if (conditional.x && block.lhs == "level") {
|
| 354 | ! |
if (ngroups == 1L) {
|
| 355 | ! |
other.block.names <- lav_partable_vnames(flat, "ov", |
| 356 | ! |
block = seq_len(nblocks)[-block] |
| 357 |
) |
|
| 358 |
} else {
|
|
| 359 |
# TEST ME |
|
| 360 | ! |
this.group <- ceiling(block / nlevels) |
| 361 | ! |
blocks.within.group <- (this.group - 1L) * nlevels + seq_len(nlevels) |
| 362 | ! |
other.block.names <- lav_partable_vnames(flat, "ov", |
| 363 | ! |
block = blocks.within.group[-block] |
| 364 |
) |
|
| 365 |
} |
|
| 366 | ! |
ov.names.x.block <- lav_partable_vnames(flat.block, "ov.x") |
| 367 | ! |
if (length(ov.names.x.block) > 0L) {
|
| 368 | ! |
idx <- which(ov.names.x.block %in% other.block.names) |
| 369 | ! |
if (length(idx) > 0L) {
|
| 370 | ! |
ov.names.x.block <- ov.names.x.block[-idx] |
| 371 |
} |
|
| 372 |
} |
|
| 373 |
} else {
|
|
| 374 | 24x |
ov.names.x.block <- NULL |
| 375 |
} |
|
| 376 | ||
| 377 | 24x |
list.block <- lav_partable_flat(flat.block, |
| 378 | 24x |
blocks = tmp.block.lhs, |
| 379 | 24x |
block.id = block, |
| 380 | 24x |
meanstructure = meanstructure, |
| 381 | 24x |
int.ov.free = int.ov.free, int.lv.free = int.lv.free, |
| 382 | 24x |
orthogonal = orthogonal, orthogonal.y = orthogonal.y, |
| 383 | 24x |
orthogonal.x = orthogonal.x, orthogonal.efa = orthogonal.efa, |
| 384 | 24x |
std.lv = std.lv, correlation = correlation, composites = composites, |
| 385 | 24x |
conditional.x = conditional.x, fixed.x = fixed.x, |
| 386 | 24x |
parameterization = parameterization, |
| 387 | 24x |
auto.fix.first = auto.fix.first, |
| 388 | 24x |
auto.fix.single = auto.fix.single, |
| 389 | 24x |
auto.var = auto.var, auto.cov.lv.x = auto.cov.lv.x, |
| 390 | 24x |
auto.cov.y = auto.cov.y, auto.th = auto.th, |
| 391 | 24x |
auto.delta = auto.delta, auto.efa = auto.efa, |
| 392 | 24x |
varTable = varTable, group.equal = NULL, |
| 393 | 24x |
group.w.free = group.w.free, ngroups = 1L, |
| 394 | 24x |
nthresholds = nthresholds, |
| 395 | 24x |
ov.names.x.block = ov.names.x.block |
| 396 |
) |
|
| 397 | 24x |
list.block <- as.data.frame(list.block, stringsAsFactors = FALSE) |
| 398 | ||
| 399 |
# add block columns with current values in block.rhs |
|
| 400 | 24x |
for (b in seq_len(length(tmp.block.lhs))) {
|
| 401 | 48x |
block.lhs <- tmp.block.lhs[b] |
| 402 | 48x |
block.rhs <- tmp.block.rhs[b] |
| 403 | 48x |
list.block[block.lhs] <- rep(block.rhs, length(list.block$lhs)) |
| 404 |
} |
|
| 405 | ||
| 406 | 24x |
if (!exists("tmp.list")) {
|
| 407 | 6x |
tmp.list <- list.block |
| 408 |
} else {
|
|
| 409 | 18x |
list.block$id <- list.block$id + max(tmp.list$id) |
| 410 | 18x |
tmp.list <- rbind(tmp.list, list.block) |
| 411 |
} |
|
| 412 |
} |
|
| 413 | 6x |
tmp.list <- as.list(tmp.list) |
| 414 | ||
| 415 |
# convert block columns to integers if possible |
|
| 416 | 6x |
for (b in seq_len(length(tmp.block.lhs))) {
|
| 417 | 12x |
block.lhs <- tmp.block.lhs[b] |
| 418 | 12x |
block.rhs <- tmp.block.rhs[b] |
| 419 | 12x |
tmp <- try(scan( |
| 420 | 12x |
text = tmp.list[[block.lhs]], what = integer(), |
| 421 | 12x |
quiet = TRUE |
| 422 | 12x |
), silent = TRUE) |
| 423 | 12x |
if (inherits(tmp, "integer")) {
|
| 424 | ! |
tmp.list[[block.lhs]] <- tmp |
| 425 |
} |
|
| 426 |
} |
|
| 427 |
} else {
|
|
| 428 | 45x |
tmp.list <- lav_partable_flat(flat, |
| 429 | 45x |
blocks = "group", |
| 430 | 45x |
meanstructure = meanstructure, |
| 431 | 45x |
int.ov.free = int.ov.free, int.lv.free = int.lv.free, |
| 432 | 45x |
orthogonal = orthogonal, orthogonal.y = orthogonal.y, |
| 433 | 45x |
orthogonal.x = orthogonal.x, orthogonal.efa = orthogonal.efa, |
| 434 | 45x |
std.lv = std.lv, correlation = correlation, composites = composites, |
| 435 | 45x |
conditional.x = conditional.x, fixed.x = fixed.x, |
| 436 | 45x |
parameterization = parameterization, |
| 437 | 45x |
auto.fix.first = auto.fix.first, auto.fix.single = auto.fix.single, |
| 438 | 45x |
auto.var = auto.var, auto.cov.lv.x = auto.cov.lv.x, |
| 439 | 45x |
auto.cov.y = auto.cov.y, auto.th = auto.th, |
| 440 | 45x |
auto.delta = auto.delta, auto.efa = auto.efa, |
| 441 | 45x |
varTable = varTable, group.equal = group.equal, |
| 442 | 45x |
group.w.free = group.w.free, |
| 443 | 45x |
ngroups = ngroups, nthresholds = nthresholds |
| 444 |
) |
|
| 445 |
} |
|
| 446 | 51x |
if (lav_debug()) {
|
| 447 | ! |
cat("[lavaan DEBUG]: parameter tmp.list without MODIFIERS:\n")
|
| 448 | ! |
print(as.data.frame(tmp.list, stringsAsFactors = FALSE)) |
| 449 |
} |
|
| 450 | ||
| 451 |
# check for auto-regressions |
|
| 452 | 51x |
auto.reg.idx <- which(tmp.list$op == "~" & |
| 453 | 51x |
tmp.list$lhs == tmp.list$rhs) |
| 454 | ||
| 455 |
# check ordinal variables |
|
| 456 | 51x |
categorical <- FALSE |
| 457 | 51x |
ov.ord <- lav_object_vnames(tmp.list, "ov.ord") |
| 458 | 51x |
if (length(ov.ord) > 0L) {
|
| 459 | 2x |
categorical <- TRUE |
| 460 | 2x |
ord.var.idx <- which(tmp.list$op == "~~" & |
| 461 | 2x |
tmp.list$lhs == tmp.list$rhs & |
| 462 | 2x |
tmp.list$lhs %in% ov.ord & |
| 463 | 2x |
tmp.list$user == 1L) |
| 464 | 2x |
if (parameterization == "delta" && length(ord.var.idx) > 0L) {
|
| 465 | ! |
lav_msg_warn(gettextf("variances of ordered variables are ignored when
|
| 466 | ! |
parameterization = \"delta\"; please remove them from the model syntax |
| 467 | ! |
or use parameterization = \"theta\"; variables involved are: %s", |
| 468 | ! |
paste(tmp.list$lhs[ord.var.idx], collapse = " "))) |
| 469 |
# force them to be nonfree and set ustart to 1 (new in 0.6-20) |
|
| 470 |
# later, after we have processes the modifiers |
|
| 471 |
} |
|
| 472 |
} # ov.ord |
|
| 473 | ||
| 474 |
# handle multilevel-specific constraints |
|
| 475 | 51x |
multilevel <- FALSE |
| 476 | 51x |
nlevels <- 1L |
| 477 | 51x |
if (!is.null(tmp.list$level)) {
|
| 478 | 6x |
nlevels <- lav_partable_nlevels(tmp.list) |
| 479 | 6x |
if (nlevels > 1L) {
|
| 480 | 6x |
multilevel <- TRUE |
| 481 |
} |
|
| 482 |
} |
|
| 483 | 51x |
if (multilevel && any(tmp.list$op == "~1")) {
|
| 484 |
# fix ov intercepts for all within ov that also appear at level 2 |
|
| 485 |
# FIXME: not tested with > 2 levels |
|
| 486 | 2x |
ov.names <- lav_partable_vnames(tmp.list, "ov") ## all names |
| 487 | 2x |
level.values <- lav_partable_level_values(tmp.list) |
| 488 | 2x |
other.names <- tmp.list$lhs[tmp.list$op == "~1" & |
| 489 | 2x |
tmp.list$level %in% level.values[-1L] & |
| 490 | 2x |
tmp.list$lhs %in% ov.names] |
| 491 | 2x |
fix.names.idx <- which(tmp.list$op == "~1" & |
| 492 | 2x |
tmp.list$level %in% level.values[1L] & |
| 493 | 2x |
tmp.list$lhs %in% other.names) |
| 494 | 2x |
if (length(fix.names.idx) > 0L) {
|
| 495 | 2x |
tmp.list$free[fix.names.idx] <- 0L |
| 496 | 2x |
tmp.list$ustart[fix.names.idx] <- 0 |
| 497 |
} |
|
| 498 |
} |
|
| 499 | 51x |
if (multilevel && any(tmp.list$op == "|")) {
|
| 500 |
# fix ALL thresholds at level 1 |
|
| 501 | ! |
level.values <- lav_partable_level_values(tmp.list) |
| 502 | ! |
th.idx <- which(tmp.list$op == "|" & |
| 503 | ! |
tmp.list$level %in% level.values[1L]) |
| 504 | ! |
tmp.list$free[th.idx] <- 0L |
| 505 | ! |
tmp.list$ustart[th.idx] <- 0 |
| 506 | ||
| 507 |
# fix ALL scaling parmaters at higher levels |
|
| 508 | ! |
scale.idx <- which(tmp.list$op == "~*~" & |
| 509 | ! |
tmp.list$level %in% level.values[-1L]) |
| 510 | ! |
tmp.list$free[scale.idx] <- 0L |
| 511 | ! |
tmp.list$ustart[scale.idx] <- 1 |
| 512 |
} |
|
| 513 | ||
| 514 |
# apply user-specified modifiers |
|
| 515 | 51x |
warn.about.single.label <- FALSE |
| 516 | 51x |
if (length(tmp.mod)) {
|
| 517 | 28x |
for (el in seq_along(tmp.mod)) {
|
| 518 | 418x |
idx <- which(tmp.list$mod.idx == el) # for each group |
| 519 | ||
| 520 |
# 0.5-21: check if idx exists |
|
| 521 |
# perhaps the corresponding element was duplicated, and removed |
|
| 522 | 418x |
if (length(idx) == 0L) {
|
| 523 | ! |
next |
| 524 |
} |
|
| 525 | ||
| 526 | 418x |
tmp.mod.fixed <- tmp.mod[[el]]$fixed |
| 527 | 418x |
tmp.mod.start <- tmp.mod[[el]]$start |
| 528 | 418x |
tmp.mod.lower <- tmp.mod[[el]]$lower |
| 529 | 418x |
tmp.mod.upper <- tmp.mod[[el]]$upper |
| 530 | 418x |
tmp.mod.label <- tmp.mod[[el]]$label |
| 531 | 418x |
tmp.mod.prior <- tmp.mod[[el]]$prior |
| 532 | 418x |
tmp.mod.efa <- tmp.mod[[el]]$efa |
| 533 | 418x |
tmp.mod.rv <- tmp.mod[[el]]$rv |
| 534 | ||
| 535 |
# check for single argument if multiple groups |
|
| 536 | 418x |
if (ngroups > 1L && length(idx) > 1L) {
|
| 537 |
# Ok, this is not very consistent: |
|
| 538 |
# A) here we force same behavior across groups |
|
| 539 | ! |
if (length(tmp.mod.fixed) == 1L) {
|
| 540 | ! |
tmp.mod.fixed <- rep(tmp.mod.fixed, ngroups) |
| 541 |
} |
|
| 542 | ! |
if (length(tmp.mod.start) == 1L) {
|
| 543 | ! |
tmp.mod.start <- rep(tmp.mod.start, ngroups) |
| 544 |
} |
|
| 545 | ! |
if (length(tmp.mod.lower) == 1L) {
|
| 546 | ! |
tmp.mod.lower <- rep(tmp.mod.lower, ngroups) |
| 547 |
} |
|
| 548 | ! |
if (length(tmp.mod.upper) == 1L) {
|
| 549 | ! |
tmp.mod.upper <- rep(tmp.mod.upper, ngroups) |
| 550 |
} |
|
| 551 | ! |
if (length(tmp.mod.prior) == 1L) {
|
| 552 | ! |
tmp.mod.prior <- rep(tmp.mod.prior, ngroups) |
| 553 |
} |
|
| 554 | ! |
if (length(tmp.mod.efa) == 1L) {
|
| 555 | ! |
tmp.mod.efa <- rep(tmp.mod.efa, ngroups) |
| 556 |
} |
|
| 557 | ! |
if (length(tmp.mod.rv) == 1L) {
|
| 558 | ! |
tmp.mod.rv <- rep(tmp.mod.rv, ngroups) |
| 559 |
} |
|
| 560 | ||
| 561 |
# new in 0.6-7 (proposal): |
|
| 562 |
# - always recycle modifiers, including labels |
|
| 563 |
# - if ngroups > 1 AND group.label= is empty, produce a warning |
|
| 564 |
# (as this is a break from < 0.6-6) |
|
| 565 | ! |
if (length(tmp.mod.label) == 1L) {
|
| 566 | ! |
tmp.mod.label <- rep(tmp.mod.label, ngroups) |
| 567 | ! |
if (is.null(group.equal) || length(group.equal) == 0L) {
|
| 568 | ! |
warn.about.single.label <- TRUE |
| 569 |
} |
|
| 570 |
} |
|
| 571 | ||
| 572 |
# < 0.6-7 code: |
|
| 573 |
# B) here we do NOT! otherwise, it would imply an equality |
|
| 574 |
# constraint... |
|
| 575 |
# except if group.equal="loadings"! |
|
| 576 |
# if(length(tmp.mod.label) == 1L) {
|
|
| 577 |
# if("loadings" %in% group.equal ||
|
|
| 578 |
# "composite.loadings" %in% group.equal) {
|
|
| 579 |
# tmp.mod.label <- rep(tmp.mod.label, ngroups) |
|
| 580 |
# } else {
|
|
| 581 |
# tmp.mod.label <- c(tmp.mod.label, rep("", (ngroups-1L)) )
|
|
| 582 |
# } |
|
| 583 |
# } |
|
| 584 |
} |
|
| 585 | ||
| 586 |
# check for wrong number of arguments if multiple groups |
|
| 587 | 418x |
nidx <- length(idx) |
| 588 | 418x |
if ((!is.null(tmp.mod.fixed) && nidx != length(tmp.mod.fixed)) || |
| 589 | 418x |
(!is.null(tmp.mod.start) && nidx != length(tmp.mod.start)) || |
| 590 | 418x |
(!is.null(tmp.mod.lower) && nidx != length(tmp.mod.lower)) || |
| 591 | 418x |
(!is.null(tmp.mod.upper) && nidx != length(tmp.mod.upper)) || |
| 592 | 418x |
(!is.null(tmp.mod.prior) && nidx != length(tmp.mod.prior)) || |
| 593 | 418x |
(!is.null(tmp.mod.efa) && nidx != length(tmp.mod.efa)) || |
| 594 | 418x |
(!is.null(tmp.mod.rv) && nidx != length(tmp.mod.rv)) || |
| 595 | 418x |
(!is.null(tmp.mod.label) && nidx != length(tmp.mod.label))) {
|
| 596 | ! |
el.idx <- which(tmp.list$mod.idx == el)[1L] |
| 597 | ! |
lav_msg_stop(gettextf( |
| 598 | ! |
"wrong number of arguments in modifier (%s) of element", |
| 599 | ! |
lav_msg_view(tmp.mod.label, "none")), |
| 600 | ! |
tmp.list$lhs[el.idx], tmp.list$op[el.idx], tmp.list$rhs[el.idx] |
| 601 |
) |
|
| 602 |
} |
|
| 603 | ||
| 604 |
# apply modifiers |
|
| 605 | 418x |
if (!is.null(tmp.mod.fixed)) {
|
| 606 |
# two options: constant or NA |
|
| 607 | 102x |
na.idx <- which(is.na(tmp.mod.fixed)) |
| 608 | 102x |
not.na.idx <- which(!is.na(tmp.mod.fixed)) |
| 609 | ||
| 610 |
# constant |
|
| 611 | 102x |
tmp.list$ustart[idx][not.na.idx] <- tmp.mod.fixed[not.na.idx] |
| 612 | 102x |
tmp.list$free[idx][not.na.idx] <- 0L |
| 613 | ||
| 614 |
# NA* modifier |
|
| 615 | 102x |
tmp.list$free[idx][na.idx] <- 1L # eg factor loading |
| 616 | 102x |
tmp.list$ustart[idx][na.idx] <- as.numeric(NA) |
| 617 |
} |
|
| 618 | 418x |
if (!is.null(tmp.mod.start)) {
|
| 619 | ! |
tmp.list$ustart[idx] <- tmp.mod.start |
| 620 |
} |
|
| 621 | 418x |
if (!is.null(tmp.mod.prior)) {
|
| 622 |
# do we already have a `prior' column? if not, create one |
|
| 623 | ! |
if (is.null(tmp.list$prior)) {
|
| 624 | ! |
tmp.list$prior <- character(length(tmp.list$lhs)) |
| 625 |
} |
|
| 626 | ! |
tmp.list$prior[idx] <- tmp.mod.prior |
| 627 |
} |
|
| 628 | 418x |
if (!is.null(tmp.mod.efa)) {
|
| 629 |
# do we already have a `efa' column? if not, create one |
|
| 630 | 120x |
if (is.null(tmp.list$efa)) {
|
| 631 | 4x |
tmp.list$efa <- character(length(tmp.list$lhs)) |
| 632 |
} |
|
| 633 | 120x |
tmp.list$efa[idx] <- tmp.mod.efa |
| 634 |
} |
|
| 635 | 418x |
if (!is.null(tmp.mod.rv)) {
|
| 636 |
# do we already have a `rv' column? if not, create one |
|
| 637 | ! |
if (is.null(tmp.list$rv)) {
|
| 638 | ! |
tmp.list$rv <- character(length(tmp.list$lhs)) |
| 639 |
} |
|
| 640 | ! |
tmp.list$rv[idx] <- tmp.mod.rv |
| 641 | ||
| 642 | ! |
tmp.list$free[idx] <- 0L |
| 643 | ! |
tmp.list$ustart[idx] <- as.numeric(NA) # |
| 644 |
} |
|
| 645 | 418x |
if (!is.null(tmp.mod.lower)) {
|
| 646 |
# do we already have a `lower' column? if not, create one |
|
| 647 | ! |
if (is.null(tmp.list$lower)) {
|
| 648 | ! |
tmp.list$lower <- rep(-Inf, length(tmp.list$lhs)) |
| 649 |
} |
|
| 650 | ! |
tmp.list$lower[idx] <- as.numeric(tmp.mod.lower) |
| 651 |
} |
|
| 652 | 418x |
if (!is.null(tmp.mod.upper)) {
|
| 653 |
# do we already have a `upper' column? if not, create one |
|
| 654 | ! |
if (is.null(tmp.list$upper)) {
|
| 655 | ! |
tmp.list$upper <- rep(Inf, length(tmp.list$lhs)) |
| 656 |
} |
|
| 657 | ! |
tmp.list$upper[idx] <- as.numeric(tmp.mod.upper) |
| 658 |
} |
|
| 659 | 418x |
if (!is.null(tmp.mod.label)) {
|
| 660 | 196x |
tmp.list$label[idx] <- tmp.mod.label |
| 661 |
} |
|
| 662 |
} |
|
| 663 |
} |
|
| 664 |
# remove mod.idx column |
|
| 665 | 51x |
tmp.list$mod.idx <- NULL |
| 666 | ||
| 667 |
# categorical: check for nonfree variances if parameterization = "delta" |
|
| 668 |
# we already gave warning; here, we force them to be nonfree |
|
| 669 | 51x |
if (categorical && parameterization == "delta") {
|
| 670 | 2x |
ord.var.idx <- which(tmp.list$op == "~~" & |
| 671 | 2x |
tmp.list$lhs == tmp.list$rhs & |
| 672 | 2x |
tmp.list$lhs %in% ov.ord & |
| 673 | 2x |
tmp.list$user == 1L) |
| 674 | 2x |
if (length(ord.var.idx) > 0L) {
|
| 675 |
# force them to be nonfree and set ustart to 1 (new in 0.6-20) |
|
| 676 | ! |
tmp.list$free[ord.var.idx] <- rep(0L, length(ord.var.idx)) |
| 677 | ! |
tmp.list$ustart[ord.var.idx] <- rep(1, length(ord.var.idx)) |
| 678 |
} |
|
| 679 |
} # categorical |
|
| 680 | ||
| 681 | ||
| 682 |
# warning about single label in multiple group setting? |
|
| 683 | 51x |
if (warn.about.single.label) {
|
| 684 | ! |
lav_msg_warn(gettext( |
| 685 | ! |
"using a single label per parameter in a multiple group setting implies |
| 686 | ! |
imposing equality constraints across all the groups; If this is not |
| 687 | ! |
intended, either remove the label(s), or use a vector of labels (one for |
| 688 | ! |
each group); See the Multiple groups section in the man page of |
| 689 | ! |
model.syntax." |
| 690 |
)) |
|
| 691 |
} |
|
| 692 | ||
| 693 |
# if lower/upper values were added, fix non-free values to ustart values |
|
| 694 |
# new in 0.6-6 |
|
| 695 | 51x |
if (!is.null(tmp.list$lower)) {
|
| 696 | ! |
fixed.idx <- which(tmp.list$free == 0L) |
| 697 | ! |
if (length(fixed.idx) > 0L) {
|
| 698 | ! |
tmp.list$lower[fixed.idx] <- tmp.list$ustart[fixed.idx] |
| 699 |
} |
|
| 700 |
} |
|
| 701 | 51x |
if (!is.null(tmp.list$upper)) {
|
| 702 | ! |
fixed.idx <- which(tmp.list$free == 0L) |
| 703 | ! |
if (length(fixed.idx) > 0L) {
|
| 704 | ! |
tmp.list$upper[fixed.idx] <- tmp.list$ustart[fixed.idx] |
| 705 |
} |
|
| 706 |
} |
|
| 707 | ||
| 708 |
# if rv column is present, add rv.names to ALL rows where they are used |
|
| 709 | 51x |
if (!is.null(tmp.list$rv)) {
|
| 710 | ! |
rv.names <- unique(tmp.list$rv[nchar(tmp.list$rv) > 0L]) |
| 711 | ! |
for (i in seq_len(length(rv.names))) {
|
| 712 | ! |
lhs.idx <- which(tmp.list$lhs == rv.names[i] & |
| 713 | ! |
tmp.list$op == "=~") |
| 714 | ! |
tmp.list$rv[lhs.idx] <- rv.names[i] |
| 715 |
} |
|
| 716 |
} |
|
| 717 | ||
| 718 | 51x |
if (lav_debug()) {
|
| 719 | ! |
cat("[lavaan DEBUG]: parameter tmp.list with MODIFIERS:\n")
|
| 720 | ! |
print(as.data.frame(tmp.list, stringsAsFactors = FALSE)) |
| 721 |
} |
|
| 722 | ||
| 723 |
# get 'virtual' parameter labels |
|
| 724 | 51x |
if (n.block.flat > 1L) {
|
| 725 | 6x |
blocks <- tmp.block.lhs |
| 726 |
} else {
|
|
| 727 | 45x |
blocks <- "group" |
| 728 |
} |
|
| 729 | 51x |
label <- lav_partable_labels( |
| 730 | 51x |
partable = tmp.list, |
| 731 | 51x |
blocks = blocks, |
| 732 | 51x |
group.equal = group.equal, |
| 733 | 51x |
group.partial = group.partial |
| 734 |
) |
|
| 735 | ||
| 736 | 51x |
if (lav_debug()) {
|
| 737 | ! |
cat("[lavaan DEBUG]: parameter tmp.list with LABELS:\n")
|
| 738 | ! |
tmp <- tmp.list |
| 739 | ! |
tmp$label <- label |
| 740 | ! |
print(as.data.frame(tmp, stringsAsFactors = FALSE)) |
| 741 |
} |
|
| 742 | ||
| 743 |
# handle EFA equality constraints |
|
| 744 |
# YR 14 Jan 2020: 0.6-6 does no longer impose 'explicit' constraints |
|
| 745 |
# if we only need to fix a parameter to 0/1 |
|
| 746 |
# Note: we should also check if they are really needed: |
|
| 747 |
# eg., if all the factor-loadings of the 'second' set (time/group) |
|
| 748 |
# are constrained to be equal to the factor-loadings of the first |
|
| 749 |
# set, no further constraints are needed |
|
| 750 | 51x |
if (auto.efa && !is.null(tmp.list$efa)) {
|
| 751 | 4x |
tmp.list <- lav_partable_efa_constraints( |
| 752 | 4x |
LIST = tmp.list, |
| 753 | 4x |
orthogonal.efa = orthogonal.efa, |
| 754 | 4x |
group.equal = group.equal |
| 755 |
) |
|
| 756 |
} # auto.efa |
|
| 757 | ||
| 758 |
# handle user-specified equality constraints |
|
| 759 |
# lavaan 0.6-11: |
|
| 760 |
# two settings: |
|
| 761 |
# 1) simple equality constraints ONLY -> back to basics: only |
|
| 762 |
# duplicate 'free' numbers; no longer explicit == rows with plabels |
|
| 763 |
# 2) mixture of simple and other (explicit) constraints |
|
| 764 |
# treat them together as we did in <0.6-11 |
|
| 765 | 51x |
tmp.list$plabel <- paste(".p", tmp.list$id, ".", sep = "")
|
| 766 | 51x |
eq.labels <- unique(label[duplicated(label)]) |
| 767 | 51x |
eq.id <- integer(length(tmp.list$lhs)) |
| 768 | 51x |
for (eq.label in eq.labels) {
|
| 769 | 50x |
tmp.con.idx <- length(tmp.con) |
| 770 | 50x |
all.idx <- which(label == eq.label) # all same-label parameters |
| 771 | 50x |
ref.idx <- all.idx[1L] # the first one only |
| 772 | 50x |
other.idx <- all.idx[-1L] # the others |
| 773 | 50x |
eq.id[all.idx] <- ref.idx |
| 774 | ||
| 775 |
# new in 0.6-6: make sure lower/upper constraints are equal too |
|
| 776 | 50x |
if (!is.null(tmp.list$lower) && |
| 777 | 50x |
length(unique(tmp.list$lower[all.idx])) > 0L) {
|
| 778 | ! |
non.inf <- which(is.finite(tmp.list$lower[all.idx])) |
| 779 | ! |
if (length(non.inf) > 0L) {
|
| 780 | ! |
smallest.val <- min(tmp.list$lower[all.idx][non.inf]) |
| 781 | ! |
tmp.list$lower[all.idx] <- smallest.val |
| 782 |
} |
|
| 783 |
} |
|
| 784 | 50x |
if (!is.null(tmp.list$upper) && |
| 785 | 50x |
length(unique(tmp.list$upper[all.idx])) > 0L) {
|
| 786 | ! |
non.inf <- which(is.finite(tmp.list$upper[all.idx])) |
| 787 | ! |
if (length(non.inf) > 0L) {
|
| 788 | ! |
largest.val <- max(tmp.list$upper[all.idx][non.inf]) |
| 789 | ! |
tmp.list$upper[all.idx] <- largest.val |
| 790 |
} |
|
| 791 |
} |
|
| 792 | ||
| 793 |
# two possibilities: |
|
| 794 |
# 1. all.idx contains a fixed parameter: in this case, |
|
| 795 |
# we fix them all (hopefully to the same value) |
|
| 796 |
# 2. all.idx contains only free parameters |
|
| 797 | ||
| 798 |
# 1. all.idx contains a fixed parameter |
|
| 799 | 50x |
if (any(tmp.list$free[all.idx] == 0L)) {
|
| 800 |
# which one is fixed? |
|
| 801 | 2x |
fixed.all <- all.idx[tmp.list$free[all.idx] == 0L] |
| 802 |
# only pick the first |
|
| 803 | 2x |
fixed.idx <- fixed.all[1] |
| 804 | ||
| 805 |
# sanity check: are all ustart values equal? |
|
| 806 | 2x |
ustart1 <- tmp.list$ustart[fixed.idx] |
| 807 | 2x |
if (all(is.na(tmp.list$ustart[fixed.all]))) {
|
| 808 |
# nothing to do; ustart values have not been set yet |
|
| 809 | 2x |
} else if (!all(ustart1 == tmp.list$ustart[fixed.all])) {
|
| 810 | ! |
lav_msg_warn(gettext( |
| 811 | ! |
"equality constraints involve fixed parameters with different values; |
| 812 | ! |
only the first one will be used")) |
| 813 |
} |
|
| 814 | ||
| 815 |
# make them all fixed |
|
| 816 | 2x |
tmp.list$ustart[all.idx] <- tmp.list$ustart[fixed.idx] |
| 817 | 2x |
tmp.list$free[all.idx] <- 0L # not free anymore, since it must |
| 818 |
# be equal to the 'fixed' parameter |
|
| 819 |
# (Note: Mplus ignores this) |
|
| 820 | 2x |
eq.id[all.idx] <- 0L # remove from eq.id list |
| 821 | ||
| 822 |
# new in 0.6-8 (for efa + user-specified eq constraints) |
|
| 823 | 2x |
if (any(tmp.list$user[all.idx] %in% c(7L, 77L))) {
|
| 824 |
# if involved in an efa block, store in tmp.con anyway |
|
| 825 |
# we may need it for the rotated solution |
|
| 826 | ! |
for (o in other.idx) {
|
| 827 | ! |
tmp.con.idx <- tmp.con.idx + 1L |
| 828 | ! |
tmp.con[[tmp.con.idx]] <- list( |
| 829 | ! |
op = "==", |
| 830 | ! |
lhs = tmp.list$plabel[ref.idx], |
| 831 | ! |
rhs = tmp.list$plabel[o], |
| 832 | ! |
user = 2L |
| 833 |
) |
|
| 834 |
} |
|
| 835 |
} |
|
| 836 |
} else {
|
|
| 837 |
# 2. all.idx contains only free parameters |
|
| 838 |
# old system: |
|
| 839 |
# - add tmp.con entry |
|
| 840 |
# - in 0.6-11: only if tmp.con is not empty |
|
| 841 | 48x |
if (!ceq.simple) {
|
| 842 | 48x |
for (o in other.idx) {
|
| 843 | 110x |
tmp.con.idx <- tmp.con.idx + 1L |
| 844 | 110x |
tmp.con[[tmp.con.idx]] <- list( |
| 845 | 110x |
op = "==", |
| 846 | 110x |
lhs = tmp.list$plabel[ref.idx], |
| 847 | 110x |
rhs = tmp.list$plabel[o], |
| 848 | 110x |
user = 2L |
| 849 |
) |
|
| 850 |
} |
|
| 851 |
} else {
|
|
| 852 |
# new system: |
|
| 853 |
# - set $free elements to zero, and later to ref id |
|
| 854 | ! |
tmp.list$free[other.idx] <- 0L # all but the first are non-free |
| 855 |
# but will get a duplicated number |
|
| 856 |
} |
|
| 857 | ||
| 858 |
# just to trick semTools, also add something in the label |
|
| 859 |
# colum, *if* it is empty |
|
| 860 |
# update: 0.6-11 we keep this, because it shows the plabels |
|
| 861 |
# when eg group.equal = "loadings" |
|
| 862 | 48x |
for (i in all.idx) {
|
| 863 | 158x |
if (nchar(tmp.list$label[i]) == 0L) {
|
| 864 | ! |
tmp.list$label[i] <- tmp.list$plabel[ref.idx] |
| 865 |
} |
|
| 866 |
} |
|
| 867 |
} # all free |
|
| 868 |
} # eq in eq.labels |
|
| 869 | 51x |
if (lav_debug()) {
|
| 870 | ! |
print(tmp.con) |
| 871 |
} |
|
| 872 | ||
| 873 | ||
| 874 | ||
| 875 |
# handle constraints (if any) (NOT per group, but overall - 0.4-11) |
|
| 876 | 51x |
if (length(tmp.con) > 0L) {
|
| 877 | 14x |
n.con <- length(tmp.con) |
| 878 | 14x |
tmp.idx <- length(tmp.list$id) + seq_len(n.con) |
| 879 |
# grow tmp.list with length(tmp.con) extra rows |
|
| 880 | 14x |
tmp.list <- lapply(tmp.list, function(x) {
|
| 881 | 170x |
if (is.character(x)) {
|
| 882 | 74x |
c(x, rep("", n.con))
|
| 883 |
} else {
|
|
| 884 | 96x |
c(x, rep(NA, n.con)) |
| 885 |
} |
|
| 886 |
}) |
|
| 887 | ||
| 888 |
# fill in some columns |
|
| 889 | 14x |
tmp.list$id[tmp.idx] <- tmp.idx |
| 890 | 14x |
tmp.list$lhs[tmp.idx] <- unlist(lapply(tmp.con, "[[", "lhs")) |
| 891 | 14x |
tmp.list$op[tmp.idx] <- unlist(lapply(tmp.con, "[[", "op")) |
| 892 | 14x |
tmp.list$rhs[tmp.idx] <- unlist(lapply(tmp.con, "[[", "rhs")) |
| 893 | 14x |
tmp.list$user[tmp.idx] <- unlist(lapply(tmp.con, "[[", "user")) |
| 894 | ||
| 895 |
# zero is nicer? |
|
| 896 | 14x |
tmp.list$free[tmp.idx] <- rep(0L, n.con) |
| 897 | 14x |
tmp.list$exo[tmp.idx] <- rep(0L, n.con) |
| 898 | 14x |
tmp.list$block[tmp.idx] <- rep(0L, n.con) |
| 899 | ||
| 900 | 14x |
if (!is.null(tmp.list$group)) {
|
| 901 | 14x |
if (is.character(tmp.list$group)) {
|
| 902 | 2x |
tmp.list$group[tmp.idx] <- rep("", n.con)
|
| 903 |
} else {
|
|
| 904 | 12x |
tmp.list$group[tmp.idx] <- rep(0L, n.con) |
| 905 |
} |
|
| 906 |
} |
|
| 907 | 14x |
if (!is.null(tmp.list$level)) {
|
| 908 | 2x |
if (is.character(tmp.list$level)) {
|
| 909 | 2x |
tmp.list$level[tmp.idx] <- rep("", n.con)
|
| 910 |
} else {
|
|
| 911 | ! |
tmp.list$level[tmp.idx] <- rep(0L, n.con) |
| 912 |
} |
|
| 913 |
} |
|
| 914 | 14x |
if (!is.null(tmp.list$class)) {
|
| 915 | ! |
if (is.character(tmp.list$class)) {
|
| 916 | ! |
tmp.list$class[tmp.idx] <- rep("", n.con)
|
| 917 |
} else {
|
|
| 918 | ! |
tmp.list$class[tmp.idx] <- rep(0L, n.con) |
| 919 |
} |
|
| 920 |
} |
|
| 921 |
} |
|
| 922 | ||
| 923 |
# check defined variables (:=) |
|
| 924 | 51x |
def.idx <- which(tmp.list$op == ":=") |
| 925 | 51x |
if (length(def.idx) > 0L) {
|
| 926 |
# check if the lhs is unique (new in 0.6-20) |
|
| 927 | 2x |
def.lhs <- tmp.list$lhs[def.idx] |
| 928 | 2x |
dup.idx <- which(duplicated(def.lhs)) |
| 929 | 2x |
if (length(dup.idx) > 0L) {
|
| 930 |
# warn or stop? warn for now |
|
| 931 | ! |
lav_msg_warn(gettextf("at least one defined variable (using the :=
|
| 932 | ! |
operator) has been duplicated, and will be |
| 933 | ! |
overwritten by the last one: %s", |
| 934 | ! |
paste(def.lhs[dup.idx], collapse = " "))) |
| 935 |
} |
|
| 936 |
# put lhs of := elements in label column |
|
| 937 | 2x |
tmp.list$label[def.idx] <- def.lhs |
| 938 |
} |
|
| 939 | ||
| 940 | ||
| 941 |
# handle effect.coding related equality constraints |
|
| 942 | 51x |
if (is.logical(effect.coding) && effect.coding) {
|
| 943 | ! |
effect.coding <- c("loadings", "intercepts")
|
| 944 | 51x |
} else if (!is.character(effect.coding)) {
|
| 945 | ! |
lav_msg_stop(gettext("effect.coding argument must be a character string"))
|
| 946 |
} |
|
| 947 | 51x |
if (any(c("loadings", "intercepts") %in% effect.coding)) {
|
| 948 | ! |
tmp <- list() |
| 949 |
# for each block |
|
| 950 | ! |
nblocks <- lav_partable_nblocks(tmp.list) |
| 951 | ! |
for (b in seq_len(nblocks)) {
|
| 952 | ||
| 953 |
# which group? |
|
| 954 | ! |
this.group <- floor(b / nlevels + 0.5) |
| 955 | ||
| 956 |
# lv's for this block/set |
|
| 957 | ! |
lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~" & |
| 958 | ! |
tmp.list$block == b]) |
| 959 | ||
| 960 | ! |
if (length(lv.names) == 0L) {
|
| 961 | ! |
next |
| 962 |
} |
|
| 963 | ||
| 964 | ! |
int.plabel <- character(0L) |
| 965 | ! |
for (lv in lv.names) {
|
| 966 |
# ind.names |
|
| 967 | ! |
ind.names <- tmp.list$rhs[tmp.list$op == "=~" & |
| 968 | ! |
tmp.list$block == b & |
| 969 | ! |
tmp.list$lhs == lv] |
| 970 | ||
| 971 | ! |
if ("loadings" %in% effect.coding &
|
| 972 | ! |
(!"loadings" %in% group.equal || this.group == 1L)) {
|
| 973 |
# factor loadings indicators of this lv |
|
| 974 | ! |
loadings.idx <- which(tmp.list$op == "=~" & |
| 975 | ! |
tmp.list$block == b & |
| 976 | ! |
tmp.list$rhs %in% ind.names & |
| 977 | ! |
tmp.list$lhs == lv) |
| 978 | ||
| 979 |
# all free? |
|
| 980 | ! |
if (length(loadings.idx) > 0L && |
| 981 | ! |
all(tmp.list$free[loadings.idx] > 0L)) {
|
| 982 |
# add eq constraint |
|
| 983 | ! |
plabel <- tmp.list$plabel[loadings.idx] |
| 984 | ||
| 985 |
# Note: we write them as |
|
| 986 |
# .p1. == 3 - .p2. - .p3. |
|
| 987 |
# instead of |
|
| 988 |
# 3 == .p1.+.p2.+.p3. |
|
| 989 |
# as this makes it easier to translate things to |
|
| 990 |
# JAGS/stan |
|
| 991 | ||
| 992 | ! |
tmp.lhs <- plabel[1] |
| 993 | ! |
if (length(loadings.idx) > 1L) {
|
| 994 | ! |
tmp.rhs <- paste(length(loadings.idx), "-", |
| 995 | ! |
paste(plabel[-1], collapse = "-"), |
| 996 | ! |
sep = "" |
| 997 |
) |
|
| 998 |
} else {
|
|
| 999 | ! |
tmp.rhs <- length(loadings.idx) |
| 1000 |
} |
|
| 1001 | ||
| 1002 | ! |
tmp$lhs <- c(tmp$lhs, tmp.lhs) |
| 1003 | ! |
tmp$op <- c(tmp$op, "==") |
| 1004 | ! |
tmp$rhs <- c(tmp$rhs, tmp.rhs) |
| 1005 | ! |
tmp$block <- c(tmp$block, 0L) |
| 1006 | ! |
tmp$user <- c(tmp$user, 2L) |
| 1007 | ! |
tmp$ustart <- c(tmp$ustart, as.numeric(NA)) |
| 1008 |
} |
|
| 1009 |
} # loadings |
|
| 1010 | ||
| 1011 | ! |
if ("intercepts" %in% effect.coding &
|
| 1012 | ! |
(!"intercepts" %in% group.equal || this.group == 1L)) {
|
| 1013 |
# intercepts for indicators of this lv |
|
| 1014 | ! |
intercepts.idx <- which(tmp.list$op == "~1" & |
| 1015 | ! |
tmp.list$block == b & |
| 1016 | ! |
tmp.list$lhs %in% ind.names) |
| 1017 | ||
| 1018 |
# all free? |
|
| 1019 | ! |
if (length(intercepts.idx) > 0L && |
| 1020 | ! |
all(tmp.list$free[intercepts.idx] > 0L)) {
|
| 1021 |
# 1) add eq constraint |
|
| 1022 | ! |
plabel <- tmp.list$plabel[intercepts.idx] |
| 1023 | ||
| 1024 | ! |
tmp.lhs <- plabel[1] |
| 1025 | ! |
if (length(intercepts.idx) > 1L) {
|
| 1026 | ! |
tmp.rhs <- paste("0-",
|
| 1027 | ! |
paste(plabel[-1], collapse = "-"), |
| 1028 | ! |
sep = "" |
| 1029 |
) |
|
| 1030 |
} else {
|
|
| 1031 | ! |
tmp.rhs <- 0L |
| 1032 |
} |
|
| 1033 | ||
| 1034 | ! |
tmp$lhs <- c(tmp$lhs, tmp.lhs) |
| 1035 | ! |
tmp$op <- c(tmp$op, "==") |
| 1036 | ! |
tmp$rhs <- c(tmp$rhs, tmp.rhs) |
| 1037 | ! |
tmp$block <- c(tmp$block, 0L) |
| 1038 | ! |
tmp$user <- c(tmp$user, 2L) |
| 1039 | ! |
tmp$ustart <- c(tmp$ustart, as.numeric(NA)) |
| 1040 | ||
| 1041 |
# 2) release latent mean |
|
| 1042 | ! |
lv.int.idx <- which(tmp.list$op == "~1" & |
| 1043 | ! |
tmp.list$block == b & |
| 1044 | ! |
tmp.list$lhs == lv) |
| 1045 |
# free only if automatically added |
|
| 1046 | ! |
if (length(lv.int.idx) > 0L && |
| 1047 | ! |
tmp.list$user[lv.int.idx] == 0L) {
|
| 1048 | ! |
tmp.list$free[lv.int.idx] <- 1L |
| 1049 |
} |
|
| 1050 |
} |
|
| 1051 |
} # intercepts |
|
| 1052 |
} # lv |
|
| 1053 |
} # blocks |
|
| 1054 | ||
| 1055 | ! |
tmp.list <- lav_partable_merge(tmp.list, tmp) |
| 1056 |
} |
|
| 1057 | ||
| 1058 |
# marker.int.zero |
|
| 1059 | 51x |
if (meanstructure && marker.int.zero) {
|
| 1060 |
# for each block |
|
| 1061 | ! |
nblocks <- lav_partable_nblocks(tmp.list) |
| 1062 | ! |
for (b in seq_len(nblocks)) {
|
| 1063 |
# lv's for this block/set |
|
| 1064 | ! |
lv.names <- lav_partable_vnames(tmp.list, |
| 1065 | ! |
type = "lv.regular", |
| 1066 | ! |
block = b |
| 1067 |
) |
|
| 1068 | ! |
lv.marker <- lav_partable_vnames(tmp.list, |
| 1069 | ! |
type = "lv.regular", |
| 1070 | ! |
block = b |
| 1071 |
) |
|
| 1072 | ||
| 1073 | ! |
if (length(lv.names) == 0L) {
|
| 1074 | ! |
next |
| 1075 |
} |
|
| 1076 | ||
| 1077 |
# markers for this block |
|
| 1078 | ! |
lv.marker <- lav_partable_vnames(tmp.list, |
| 1079 | ! |
type = "lv.marker", |
| 1080 | ! |
block = b |
| 1081 |
) |
|
| 1082 | ||
| 1083 |
# fix marker intercepts to zero |
|
| 1084 | ! |
marker.idx <- which(tmp.list$op == "~1" & |
| 1085 | ! |
tmp.list$lhs %in% lv.marker & tmp.list$block == b & |
| 1086 | ! |
tmp.list$user == 0L) |
| 1087 | ! |
tmp.list$free[marker.idx] <- 0L |
| 1088 | ! |
tmp.list$ustart[marker.idx] <- 0 |
| 1089 | ||
| 1090 |
# free latent means |
|
| 1091 | ! |
lv.idx <- which(tmp.list$op == "~1" & |
| 1092 | ! |
tmp.list$lhs %in% lv.names & tmp.list$block == b & |
| 1093 | ! |
tmp.list$user == 0L) |
| 1094 | ! |
tmp.list$free[lv.idx] <- 1L |
| 1095 | ! |
tmp.list$ustart[lv.idx] <- as.numeric(NA) |
| 1096 |
} # block |
|
| 1097 |
} |
|
| 1098 | ||
| 1099 | ||
| 1100 |
# mg.lv.variances |
|
| 1101 | 51x |
if (ngroups > 1L && "mg.lv.variances" %in% effect.coding) {
|
| 1102 | ! |
tmp <- list() |
| 1103 | ||
| 1104 |
# do not include 'EFA' lv's |
|
| 1105 | ! |
if (!is.null(tmp.list$efa)) {
|
| 1106 | ! |
lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~" & |
| 1107 | ! |
!nchar(tmp.list$efa) > 0L]) |
| 1108 |
} else {
|
|
| 1109 | ! |
lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~"]) |
| 1110 |
} |
|
| 1111 | ! |
group.values <- lav_partable_group_values(tmp.list) |
| 1112 | ||
| 1113 | ! |
for (lv in lv.names) {
|
| 1114 |
# factor variances |
|
| 1115 | ! |
lv.var.idx <- which(tmp.list$op == "~~" & |
| 1116 | ! |
tmp.list$lhs == lv & |
| 1117 | ! |
tmp.list$rhs == tmp.list$lhs & |
| 1118 | ! |
tmp.list$lhs == lv) |
| 1119 | ||
| 1120 |
# all free (but the first?) |
|
| 1121 | ! |
if (length(lv.var.idx) > 0L && |
| 1122 | ! |
all(tmp.list$free[lv.var.idx][-1] > 0L)) {
|
| 1123 |
# 1) add eq constraint |
|
| 1124 | ! |
plabel <- tmp.list$plabel[lv.var.idx] |
| 1125 | ||
| 1126 | ! |
tmp.lhs <- plabel[1] |
| 1127 | ! |
if (length(lv.var.idx) > 1L) {
|
| 1128 | ! |
tmp.rhs <- paste(length(lv.var.idx), "-", |
| 1129 | ! |
paste(plabel[-1], collapse = "-"), |
| 1130 | ! |
sep = "" |
| 1131 |
) |
|
| 1132 |
} else {
|
|
| 1133 | ! |
tmp.rhs <- length(lv.var.idx) |
| 1134 |
} |
|
| 1135 | ||
| 1136 | ! |
tmp$lhs <- c(tmp$lhs, tmp.lhs) |
| 1137 | ! |
tmp$op <- c(tmp$op, "==") |
| 1138 | ! |
tmp$rhs <- c(tmp$rhs, tmp.rhs) |
| 1139 | ! |
tmp$block <- c(tmp$block, 0L) |
| 1140 | ! |
tmp$user <- c(tmp$user, 2L) |
| 1141 | ! |
tmp$ustart <- c(tmp$ustart, as.numeric(NA)) |
| 1142 | ||
| 1143 |
# 2) free lv variances first group |
|
| 1144 | ! |
lv.var.g1.idx <- which(tmp.list$op == "~~" & |
| 1145 | ! |
tmp.list$group == group.values[1] & |
| 1146 | ! |
tmp.list$lhs == lv & |
| 1147 | ! |
tmp.list$rhs == tmp.list$lhs & |
| 1148 | ! |
tmp.list$lhs == lv) |
| 1149 |
# free only if automatically added |
|
| 1150 | ! |
if (length(lv.var.g1.idx) > 0L && |
| 1151 | ! |
tmp.list$user[lv.var.g1.idx] == 0L) {
|
| 1152 | ! |
tmp.list$free[lv.var.g1.idx] <- 1L |
| 1153 |
} |
|
| 1154 |
} |
|
| 1155 |
} # lv |
|
| 1156 | ||
| 1157 | ! |
tmp.list <- lav_partable_merge(tmp.list, tmp) |
| 1158 |
} |
|
| 1159 | ||
| 1160 |
# mg.lv.efa.variances |
|
| 1161 | 51x |
if (ngroups > 1L && "mg.lv.efa.variances" %in% effect.coding) {
|
| 1162 | ! |
tmp <- list() |
| 1163 | ||
| 1164 |
# only 'EFA' lv's |
|
| 1165 | ! |
if (!is.null(tmp.list$efa)) {
|
| 1166 | ! |
lv.names <- unique(tmp.list$lhs[tmp.list$op == "=~" & |
| 1167 | ! |
nchar(tmp.list$efa) > 0L]) |
| 1168 |
} else {
|
|
| 1169 | ! |
lv.names <- character(0L) |
| 1170 |
} |
|
| 1171 | ! |
group.values <- lav_partable_group_values(tmp.list) |
| 1172 | ||
| 1173 | ! |
for (lv in lv.names) {
|
| 1174 |
# factor variances |
|
| 1175 | ! |
lv.var.idx <- which(tmp.list$op == "~~" & |
| 1176 | ! |
tmp.list$lhs == lv & |
| 1177 | ! |
tmp.list$rhs == tmp.list$lhs & |
| 1178 | ! |
tmp.list$lhs == lv) |
| 1179 | ||
| 1180 |
# all free (but the first?) |
|
| 1181 | ! |
if (length(lv.var.idx) > 0L && |
| 1182 | ! |
all(tmp.list$free[lv.var.idx][-1] > 0L)) {
|
| 1183 |
# 1) add eq constraint |
|
| 1184 | ! |
plabel <- tmp.list$plabel[lv.var.idx] |
| 1185 | ||
| 1186 | ! |
tmp.lhs <- plabel[1] |
| 1187 | ! |
if (length(lv.var.idx) > 1L) {
|
| 1188 | ! |
tmp.rhs <- paste(length(lv.var.idx), "-", |
| 1189 | ! |
paste(plabel[-1], collapse = "-"), |
| 1190 | ! |
sep = "" |
| 1191 |
) |
|
| 1192 |
} else {
|
|
| 1193 | ! |
tmp.rhs <- length(lv.var.idx) |
| 1194 |
} |
|
| 1195 | ||
| 1196 | ! |
tmp$lhs <- c(tmp$lhs, tmp.lhs) |
| 1197 | ! |
tmp$op <- c(tmp$op, "==") |
| 1198 | ! |
tmp$rhs <- c(tmp$rhs, tmp.rhs) |
| 1199 | ! |
tmp$block <- c(tmp$block, 0L) |
| 1200 | ! |
tmp$user <- c(tmp$user, 2L) |
| 1201 | ! |
tmp$ustart <- c(tmp$ustart, as.numeric(NA)) |
| 1202 | ||
| 1203 |
# 2) free lv variances first group |
|
| 1204 | ! |
lv.var.g1.idx <- which(tmp.list$op == "~~" & |
| 1205 | ! |
tmp.list$group == group.values[1] & |
| 1206 | ! |
tmp.list$lhs == lv & |
| 1207 | ! |
tmp.list$rhs == tmp.list$lhs & |
| 1208 | ! |
tmp.list$lhs == lv) |
| 1209 |
# free only if automatically added |
|
| 1210 | ! |
if (length(lv.var.g1.idx) > 0L && |
| 1211 | ! |
tmp.list$user[lv.var.g1.idx] == 0L) {
|
| 1212 | ! |
tmp.list$free[lv.var.g1.idx] <- 1L |
| 1213 |
} |
|
| 1214 |
} |
|
| 1215 |
} # lv |
|
| 1216 | ||
| 1217 | ! |
tmp.list <- lav_partable_merge(tmp.list, tmp) |
| 1218 |
} |
|
| 1219 | ||
| 1220 | ||
| 1221 |
# count free parameters |
|
| 1222 | 51x |
idx.free <- which(tmp.list$free > 0L) |
| 1223 | 51x |
tmp.list$free[idx.free] <- seq_along(idx.free) |
| 1224 | ||
| 1225 |
# new in 0.6-11: add free counter to this element (as in < 0.5-18) |
|
| 1226 |
# unless we have other constraints |
|
| 1227 | 51x |
if (ceq.simple) {
|
| 1228 | ! |
idx.equal <- which(eq.id > 0) |
| 1229 | ! |
tmp.list$free[idx.equal] <- tmp.list$free[eq.id[idx.equal]] |
| 1230 |
} |
|
| 1231 | ||
| 1232 |
# new in 0.6-14: add 'da' entries to reflect data-based order of ov's |
|
| 1233 |
# now via attribute "ovda" |
|
| 1234 | 51x |
attr(tmp.list, "ovda") <- ov.names.data |
| 1235 | ||
| 1236 |
# backwards compatibility... |
|
| 1237 | 51x |
if (!is.null(tmp.list$unco)) {
|
| 1238 | ! |
tmp.list$unco[idx.free] <- seq_along(sum(tmp.list$free > 0L)) |
| 1239 |
} |
|
| 1240 | ||
| 1241 | 51x |
if (lav_debug()) {
|
| 1242 | ! |
cat("[lavaan DEBUG] lavParTable\n")
|
| 1243 | ! |
print(as.data.frame(tmp.list)) |
| 1244 |
} |
|
| 1245 | ||
| 1246 |
# data.frame? |
|
| 1247 | 51x |
if (as.data.frame.) {
|
| 1248 | 4x |
tmp.list <- as.data.frame(tmp.list, stringsAsFactors = FALSE) |
| 1249 | 4x |
attr(tmp.list, "ovda") <- ov.names.data |
| 1250 |
} else {
|
|
| 1251 | 47x |
tmp.list <- lav_partable_set_cache(tmp.list) # add cached "pta" data |
| 1252 |
} |
|
| 1253 | ||
| 1254 | 51x |
tmp.list |
| 1255 |
} |
|
| 1256 |
lavParTable <- lav_model_partable # synonym #nolint |
|
| 1257 |
lavaanify <- lav_model_partable # synonym #nolint |
| 1 |
# build def function from partable |
|
| 2 |
lav_partable_constraints_def <- function(partable, con = NULL, debug = FALSE, |
|
| 3 |
txtOnly = FALSE, warn = TRUE) {
|
|
| 4 | 239x |
if (!missing(debug)) {
|
| 5 | 144x |
current.debug <- lav_debug() |
| 6 | 144x |
if (lav_debug(debug)) |
| 7 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 8 |
} |
|
| 9 |
# empty function |
|
| 10 | 239x |
def.function <- function() NULL |
| 11 | ||
| 12 |
# if 'con', merge partable + con |
|
| 13 | 239x |
if (!is.null(con)) {
|
| 14 | ! |
partable$lhs <- c(partable$lhs, con$lhs) |
| 15 | ! |
partable$op <- c(partable$op, con$op) |
| 16 | ! |
partable$rhs <- c(partable$rhs, con$rhs) |
| 17 |
} |
|
| 18 | ||
| 19 |
# get := definitions |
|
| 20 | 239x |
def.idx <- which(partable$op == ":=") |
| 21 | ||
| 22 |
# catch empty def |
|
| 23 | 239x |
if (length(def.idx) == 0L) {
|
| 24 | 237x |
if (txtOnly) {
|
| 25 | 95x |
return(character(0L)) |
| 26 |
} else {
|
|
| 27 | 142x |
return(def.function) |
| 28 |
} |
|
| 29 |
} |
|
| 30 | ||
| 31 |
# sort order of def.idx by dependencies |
|
| 32 | 2x |
deps <- lapply(partable$rhs[def.idx], FUN = function(x) {
|
| 33 | 2x |
all.vars(parse(text=x)) }) |
| 34 | 2x |
lab.unsorted <- partable$lhs[def.idx] |
| 35 | 2x |
adj.mat <- matrix(0L, nrow = length(def.idx), ncol = length(def.idx)) |
| 36 | 2x |
for (i in seq_along(lab.unsorted)) {
|
| 37 | 2x |
adj.mat[lab.unsorted %in% deps[[i]], i] <- 1L |
| 38 |
} |
|
| 39 | 2x |
def.idx <- def.idx[lav_graph_order_adj_mat(adj.mat, warn = warn)] |
| 40 | ||
| 41 |
# create function |
|
| 42 | 2x |
formals(def.function) <- alist(.x. = , ... = ) |
| 43 | 2x |
if (txtOnly) {
|
| 44 | ! |
BODY.txt <- "" |
| 45 |
} else {
|
|
| 46 | 2x |
BODY.txt <- paste("{\n# parameter definitions\n\n")
|
| 47 |
} |
|
| 48 | ||
| 49 | 2x |
lhs.names <- partable$lhs[def.idx] |
| 50 | 2x |
def.labels <- all.vars(parse(file = "", text = partable$rhs[def.idx])) |
| 51 |
# remove the ones in lhs.names |
|
| 52 | 2x |
idx <- which(def.labels %in% lhs.names) |
| 53 | ! |
if (length(idx) > 0L) def.labels <- def.labels[-idx] |
| 54 | ||
| 55 |
# get corresponding 'x' indices |
|
| 56 | 2x |
def.x.idx <- partable$free[match(def.labels, partable$label)] |
| 57 | 2x |
if (any(is.na(def.x.idx))) {
|
| 58 | ! |
lav_msg_stop(gettext( |
| 59 | ! |
"unknown label(s) in variable definition(s):"), |
| 60 | ! |
lav_msg_view(def.labels[which(is.na(def.x.idx))], "none") |
| 61 |
) |
|
| 62 |
} |
|
| 63 | 2x |
if (any(def.x.idx == 0)) {
|
| 64 | ! |
lav_msg_stop(gettext( |
| 65 | ! |
"non-free parameter(s) in variable definition(s):"), |
| 66 | ! |
lav_msg_view(def.labels[which(def.x.idx == 0)], "none") |
| 67 |
) |
|
| 68 |
} |
|
| 69 | 2x |
def.x.lab <- paste(".x.[", def.x.idx, "]", sep = "")
|
| 70 |
# put both the labels the function BODY |
|
| 71 | 2x |
if (length(def.x.idx) > 0L) {
|
| 72 | 2x |
BODY.txt <- paste(BODY.txt, "# parameter labels\n", |
| 73 | 2x |
paste(def.labels, " <- ", def.x.lab, collapse = "\n"), |
| 74 | 2x |
"\n", |
| 75 | 2x |
sep = "" |
| 76 |
) |
|
| 77 |
} |
|
| 78 | ||
| 79 |
# write the definitions literally |
|
| 80 | 2x |
BODY.txt <- paste(BODY.txt, "\n# parameter definitions\n", sep = "") |
| 81 | 2x |
for (i in 1:length(def.idx)) {
|
| 82 | 2x |
BODY.txt <- paste(BODY.txt, |
| 83 | 2x |
lhs.names[i], " <- ", partable$rhs[def.idx[i]], "\n", |
| 84 | 2x |
sep = "" |
| 85 |
) |
|
| 86 |
} |
|
| 87 | ||
| 88 | 2x |
if (txtOnly) {
|
| 89 | ! |
return(BODY.txt) |
| 90 |
} |
|
| 91 | ||
| 92 |
# put the results in 'out' |
|
| 93 | 2x |
BODY.txt <- paste(BODY.txt, "\nout <- ", |
| 94 | 2x |
paste("c(", paste(lhs.names, collapse = ","), ")\n", sep = ""),
|
| 95 | 2x |
sep = "" |
| 96 |
) |
|
| 97 |
# what to do with NA values? -> return +Inf??? |
|
| 98 | 2x |
BODY.txt <- paste(BODY.txt, "out[is.na(out)] <- Inf\n", sep = "") |
| 99 | 2x |
BODY.txt <- paste(BODY.txt, "names(out) <- ", |
| 100 | 2x |
paste("c(\"", paste(lhs.names, collapse = "\",\""), "\")\n", sep = ""),
|
| 101 | 2x |
sep = "" |
| 102 |
) |
|
| 103 | 2x |
BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "") |
| 104 | ||
| 105 | 2x |
body(def.function) <- parse(file = "", text = BODY.txt) |
| 106 | 2x |
if (lav_debug()) {
|
| 107 | ! |
cat("def.function = \n")
|
| 108 | ! |
print(def.function) |
| 109 | ! |
cat("\n")
|
| 110 |
} |
|
| 111 | ||
| 112 | 2x |
def.function |
| 113 |
} |
|
| 114 | ||
| 115 |
# build ceq function from partable |
|
| 116 |
# non-trivial equality constraints (linear or nonlinear) |
|
| 117 |
# convert to 'ceq(x)' function where 'x' is the (free) parameter vector |
|
| 118 |
# and ceq(x) returns the evaluated equality constraints |
|
| 119 |
# |
|
| 120 |
# eg. if b1 + b2 == 2 (and b1 correspond to, say, x[10] and x[17]) |
|
| 121 |
# ceq <- function(x) {
|
|
| 122 |
# out <- rep(NA, 1) |
|
| 123 |
# b1 = x[10]; b2 = x[17] |
|
| 124 |
# out[1] <- b1 + b2 - 2 |
|
| 125 |
# } |
|
| 126 |
lav_partable_constraints_ceq <- function(partable, con = NULL, debug = FALSE, |
|
| 127 |
txtOnly = FALSE) {
|
|
| 128 | 144x |
if (!missing(debug)) {
|
| 129 | 144x |
current.debug <- lav_debug() |
| 130 | 144x |
if (lav_debug(debug)) |
| 131 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 132 |
} |
|
| 133 |
# empty function |
|
| 134 | 144x |
ceq.function <- function() NULL |
| 135 | ||
| 136 |
# if 'con', merge partable + con |
|
| 137 | 144x |
if (!is.null(con)) {
|
| 138 | ! |
partable$lhs <- c(partable$lhs, con$lhs) |
| 139 | ! |
partable$op <- c(partable$op, con$op) |
| 140 | ! |
partable$rhs <- c(partable$rhs, con$rhs) |
| 141 |
} |
|
| 142 | ||
| 143 |
# get equality constraints |
|
| 144 | 144x |
eq.idx <- which(partable$op == "==") |
| 145 | ||
| 146 |
# catch empty ceq |
|
| 147 | 144x |
if (length(eq.idx) == 0L) {
|
| 148 | 134x |
if (txtOnly) {
|
| 149 | ! |
return(character(0L)) |
| 150 |
} else {
|
|
| 151 | 134x |
return(ceq.function) |
| 152 |
} |
|
| 153 |
} |
|
| 154 | ||
| 155 |
# create function |
|
| 156 | 10x |
formals(ceq.function) <- alist(.x. = , ... = ) |
| 157 | 10x |
if (txtOnly) {
|
| 158 | ! |
BODY.txt <- "" |
| 159 |
} else {
|
|
| 160 | 10x |
BODY.txt <- paste("{\nout <- rep(NA, ", length(eq.idx), ")\n", sep = "")
|
| 161 |
} |
|
| 162 | ||
| 163 |
# first come the variable definitions |
|
| 164 | 10x |
DEF.txt <- lav_partable_constraints_def(partable, txtOnly = TRUE, |
| 165 | 10x |
warn = FALSE) |
| 166 | 10x |
def.idx <- which(partable$op == ":=") |
| 167 | 10x |
BODY.txt <- paste(BODY.txt, DEF.txt, "\n", sep = "") |
| 168 | ||
| 169 | ||
| 170 |
# extract labels |
|
| 171 | 10x |
lhs.labels <- all.vars(parse(file = "", text = partable$lhs[eq.idx])) |
| 172 | 10x |
rhs.labels <- all.vars(parse(file = "", text = partable$rhs[eq.idx])) |
| 173 | 10x |
eq.labels <- unique(c(lhs.labels, rhs.labels)) |
| 174 |
# remove def.names from eq.labels |
|
| 175 | 10x |
if (length(def.idx) > 0L) {
|
| 176 | ! |
def.names <- as.character(partable$lhs[def.idx]) |
| 177 | ! |
d.idx <- which(eq.labels %in% def.names) |
| 178 | ! |
if (length(d.idx) > 0) eq.labels <- eq.labels[-d.idx] |
| 179 |
} |
|
| 180 | 10x |
eq.x.idx <- rep(as.integer(NA), length(eq.labels)) |
| 181 |
# get user-labels ids |
|
| 182 | 10x |
ulab.idx <- which(eq.labels %in% partable$label) |
| 183 | 10x |
if (length(ulab.idx) > 0L) {
|
| 184 | ! |
eq.x.idx[ulab.idx] <- partable$free[match( |
| 185 | ! |
eq.labels[ulab.idx], |
| 186 | ! |
partable$label |
| 187 |
)] |
|
| 188 |
} |
|
| 189 |
# get plabels ids |
|
| 190 | 10x |
plab.idx <- which(eq.labels %in% partable$plabel) |
| 191 | 10x |
if (length(plab.idx) > 0L) {
|
| 192 | 10x |
eq.x.idx[plab.idx] <- partable$free[match( |
| 193 | 10x |
eq.labels[plab.idx], |
| 194 | 10x |
partable$plabel |
| 195 |
)] |
|
| 196 |
} |
|
| 197 | ||
| 198 |
# check if we have found the label |
|
| 199 | 10x |
if (any(is.na(eq.x.idx))) {
|
| 200 | ! |
lav_msg_stop(gettext("unknown label(s) in equality constraint(s):"),
|
| 201 | ! |
lav_msg_view(eq.labels[which(is.na(eq.x.idx))], "none") |
| 202 |
) |
|
| 203 |
} |
|
| 204 |
# check if they are all 'free' |
|
| 205 | 10x |
if (any(eq.x.idx == 0)) {
|
| 206 | ! |
fixed.eq.idx <- which(eq.x.idx == 0) |
| 207 |
# FIXME: what should we do here? we used to stop with an error |
|
| 208 |
# from 0.5.18, we give a warning, and replace the non-free label |
|
| 209 |
# with its fixed value in ustart |
|
| 210 |
# warning("lavaan WARNING: non-free parameter(s) in equality constraint(s): ",
|
|
| 211 |
# paste(eq.labels[fixed.eq.idx], collapse=" ")) |
|
| 212 | ||
| 213 | ! |
fixed.lab.lhs <- eq.labels[fixed.eq.idx] |
| 214 | ! |
fixed.lab.rhs <- numeric(length(fixed.lab.lhs)) |
| 215 | ||
| 216 | ! |
for (i in 1:length(fixed.lab.lhs)) {
|
| 217 |
# first try label |
|
| 218 | ! |
idx <- match(fixed.lab.lhs[i], partable$label) |
| 219 |
# then try plabel |
|
| 220 | ! |
if (is.na(idx)) {
|
| 221 | ! |
idx <- match(fixed.lab.lhs[i], partable$plabel) |
| 222 |
} |
|
| 223 | ! |
if (is.na(idx)) {
|
| 224 |
# hm, not found? fill in zero, or NA? |
|
| 225 |
} else {
|
|
| 226 | ! |
fixed.lab.rhs[i] <- partable$ustart[idx] |
| 227 |
} |
|
| 228 |
} |
|
| 229 | ||
| 230 | ! |
BODY.txt <- paste(BODY.txt, "# non-free parameter labels\n", |
| 231 | ! |
paste(fixed.lab.lhs, "<-", fixed.lab.rhs, collapse = "\n"), |
| 232 | ! |
"\n", |
| 233 | ! |
sep = "" |
| 234 |
) |
|
| 235 | ||
| 236 | ! |
eq.x.idx <- eq.x.idx[-fixed.eq.idx] |
| 237 | ! |
eq.labels <- eq.labels[-fixed.eq.idx] |
| 238 |
} |
|
| 239 | ||
| 240 |
# put the labels the function BODY |
|
| 241 | 10x |
eq.x.lab <- paste(".x.[", eq.x.idx, "]", sep = "")
|
| 242 | 10x |
if (length(eq.x.idx) > 0L) {
|
| 243 | 10x |
BODY.txt <- paste(BODY.txt, "# parameter labels\n", |
| 244 | 10x |
paste(eq.labels, "<-", eq.x.lab, collapse = "\n"), |
| 245 | 10x |
"\n", |
| 246 | 10x |
sep = "" |
| 247 |
) |
|
| 248 |
} |
|
| 249 | ||
| 250 |
# write the equality constraints literally |
|
| 251 | 10x |
BODY.txt <- paste(BODY.txt, "\n# equality constraints\n", sep = "") |
| 252 | 10x |
for (i in 1:length(eq.idx)) {
|
| 253 | 110x |
lhs <- partable$lhs[eq.idx[i]] |
| 254 | 110x |
rhs <- partable$rhs[eq.idx[i]] |
| 255 | 110x |
if (rhs == "0") {
|
| 256 | ! |
eq.string <- lhs |
| 257 |
} else {
|
|
| 258 | 110x |
eq.string <- paste(lhs, " - (", rhs, ")", sep = "")
|
| 259 |
} |
|
| 260 | 110x |
BODY.txt <- paste(BODY.txt, "out[", i, "] <- ", eq.string, "\n", sep = "") |
| 261 |
} |
|
| 262 | ||
| 263 | 10x |
if (txtOnly) {
|
| 264 | ! |
return(BODY.txt) |
| 265 |
} |
|
| 266 | ||
| 267 |
# put the results in 'out' |
|
| 268 |
# BODY.txt <- paste(BODY.txt, "\nout <- ", |
|
| 269 |
# paste("c(", paste(lhs.names, collapse=","),")\n", sep=""), sep="")
|
|
| 270 | ||
| 271 |
# what to do with NA values? -> return +Inf??? |
|
| 272 | 10x |
BODY.txt <- paste(BODY.txt, "\n", "out[is.na(out)] <- Inf\n", sep = "") |
| 273 | 10x |
BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "") |
| 274 | 10x |
body(ceq.function) <- parse(file = "", text = BODY.txt) |
| 275 | 10x |
if (lav_debug()) {
|
| 276 | ! |
cat("ceq.function = \n")
|
| 277 | ! |
print(ceq.function) |
| 278 | ! |
cat("\n")
|
| 279 |
} |
|
| 280 | ||
| 281 | 10x |
ceq.function |
| 282 |
} |
|
| 283 | ||
| 284 | ||
| 285 |
# build ciq function from partable |
|
| 286 |
# non-trivial inequality constraints (linear or nonlinear) |
|
| 287 |
# convert to 'cin(x)' function where 'x' is the (free) parameter vector |
|
| 288 |
# and cin(x) returns the evaluated inequality constraints |
|
| 289 |
# |
|
| 290 |
# eg. if b1 + b2 > 2 (and b1 correspond to, say, x[10] and x[17]) |
|
| 291 |
# cin <- function(x) {
|
|
| 292 |
# out <- rep(NA, 1) |
|
| 293 |
# b1 = x[10]; b2 = x[17] |
|
| 294 |
# out[1] <- b1 + b2 - 2 |
|
| 295 |
# } |
|
| 296 |
# |
|
| 297 |
# new in 0.6-19: we also add the lower/upper bounds |
|
| 298 |
# |
|
| 299 |
# NOTE: very similar, but not identitical to ceq, because we need to take |
|
| 300 |
# care of the difference between '<' and '>' |
|
| 301 |
lav_partable_constraints_ciq <- function(partable, con = NULL, debug = FALSE, |
|
| 302 |
txtOnly = FALSE) {
|
|
| 303 | 144x |
if (!missing(debug)) {
|
| 304 | 144x |
current.debug <- lav_debug() |
| 305 | 144x |
if (lav_debug(debug)) |
| 306 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 307 |
} |
|
| 308 |
# empty function |
|
| 309 | 144x |
cin.function <- function() NULL |
| 310 | ||
| 311 |
# if 'con', merge partable + con |
|
| 312 | 144x |
if (!is.null(con)) {
|
| 313 | ! |
partable$lhs <- c(partable$lhs, con$lhs) |
| 314 | ! |
partable$op <- c(partable$op, con$op) |
| 315 | ! |
partable$rhs <- c(partable$rhs, con$rhs) |
| 316 |
} |
|
| 317 | ||
| 318 |
# get explicit inequality constraints |
|
| 319 | 144x |
ineq.idx <- which(partable$op == ">" | partable$op == "<") |
| 320 | ||
| 321 |
# get lower/upper bounds |
|
| 322 | 144x |
upper.idx <- integer(0L) |
| 323 | 144x |
lower.idx <- integer(0L) |
| 324 | 144x |
if (!is.null(partable$upper)) {
|
| 325 | 83x |
upper.idx <- which(partable$free > 0L & is.finite(partable$upper)) |
| 326 |
} |
|
| 327 | 144x |
if (!is.null(partable$lower)) {
|
| 328 | 83x |
lower.idx <- which(partable$free > 0L & is.finite(partable$lower)) |
| 329 |
} |
|
| 330 | ||
| 331 |
# add them to ineq.idx |
|
| 332 | 144x |
ineq.only.idx <- ineq.idx |
| 333 | 144x |
ineq.idx <- c(upper.idx, lower.idx, ineq.idx) |
| 334 | ||
| 335 |
# catch empty ciq |
|
| 336 | 144x |
if (length(ineq.idx) == 0L) {
|
| 337 | 59x |
if (txtOnly) {
|
| 338 | ! |
return(character(0L)) |
| 339 |
} else {
|
|
| 340 | 59x |
return(cin.function) |
| 341 |
} |
|
| 342 |
} |
|
| 343 | ||
| 344 |
# create function |
|
| 345 | 85x |
formals(cin.function) <- alist(.x. = , ... = ) |
| 346 | 85x |
if (txtOnly) {
|
| 347 | ! |
BODY.txt <- "" |
| 348 |
} else {
|
|
| 349 | 85x |
BODY.txt <- paste("{\nout <- rep(NA, ", length(ineq.idx), ")\n", sep = "")
|
| 350 |
} |
|
| 351 | ||
| 352 |
# first come the variable definitions |
|
| 353 | 85x |
DEF.txt <- lav_partable_constraints_def(partable, txtOnly = TRUE, |
| 354 | 85x |
warn = FALSE) |
| 355 | 85x |
def.idx <- which(partable$op == ":=") |
| 356 | 85x |
BODY.txt <- paste(BODY.txt, DEF.txt, "\n", sep = "") |
| 357 | ||
| 358 |
# extract labels |
|
| 359 | 85x |
lhs.labels <- all.vars(parse(file = "", text = partable$lhs[ineq.only.idx])) |
| 360 | 85x |
rhs.labels <- all.vars(parse(file = "", text = partable$rhs[ineq.only.idx])) |
| 361 | 85x |
ineq.labels <- unique(c(lhs.labels, rhs.labels)) |
| 362 |
# remove def.names from ineq.labels |
|
| 363 | 85x |
if (length(def.idx) > 0L) {
|
| 364 | ! |
def.names <- as.character(partable$lhs[def.idx]) |
| 365 | ! |
d.idx <- which(ineq.labels %in% def.names) |
| 366 | ! |
if (length(d.idx) > 0) ineq.labels <- ineq.labels[-d.idx] |
| 367 |
} |
|
| 368 | 85x |
ineq.x.idx <- rep(as.integer(NA), length(ineq.labels)) |
| 369 |
# get user-labels ids |
|
| 370 | 85x |
ulab.idx <- which(ineq.labels %in% partable$label) |
| 371 | 85x |
if (length(ulab.idx) > 0L) {
|
| 372 | 2x |
ineq.x.idx[ulab.idx] <- partable$free[match( |
| 373 | 2x |
ineq.labels[ulab.idx], |
| 374 | 2x |
partable$label |
| 375 |
)] |
|
| 376 |
} |
|
| 377 |
# get plabels ids |
|
| 378 | 85x |
plab.idx <- which(ineq.labels %in% partable$plabel) |
| 379 | 85x |
if (length(plab.idx) > 0L) {
|
| 380 | ! |
ineq.x.idx[plab.idx] <- partable$free[match( |
| 381 | ! |
ineq.labels[plab.idx], |
| 382 | ! |
partable$plabel |
| 383 |
)] |
|
| 384 |
} |
|
| 385 | ||
| 386 |
# check if we have found the label |
|
| 387 | 85x |
if (length(ineq.x.idx) > 0L && any(is.na(ineq.x.idx))) {
|
| 388 | ! |
lav_msg_stop(gettext("unknown label(s) in inequality constraint(s):"),
|
| 389 | ! |
lav_msg_view(ineq.labels[which(is.na(ineq.x.idx))], "none") |
| 390 |
) |
|
| 391 |
} |
|
| 392 | ||
| 393 |
# check if they are all 'free' |
|
| 394 | 85x |
if (length(ineq.x.idx) > 0L && any(ineq.x.idx == 0)) {
|
| 395 | ! |
fixed.ineq.idx <- which(ineq.x.idx == 0) |
| 396 |
# FIXME: what should we do here? we used to stop with an error |
|
| 397 |
# from 0.5.18, we give a warning, and replace the non-free label |
|
| 398 |
# with its fixed value in ustart |
|
| 399 | ! |
lav_msg_warn(gettext("non-free parameter(s) in inequality constraint(s):"),
|
| 400 | ! |
lav_msg_view(ineq.labels[fixed.ineq.idx],"none") |
| 401 |
) |
|
| 402 | ||
| 403 | ! |
fixed.lab.lhs <- ineq.labels[fixed.ineq.idx] |
| 404 | ! |
fixed.lab.rhs <- partable$ustart[match(fixed.lab.lhs, partable$label)] |
| 405 | ! |
BODY.txt <- paste(BODY.txt, "# non-free parameter labels\n", |
| 406 | ! |
paste(fixed.lab.lhs, "<-", fixed.lab.rhs, collapse = "\n"), |
| 407 | ! |
"\n", |
| 408 | ! |
sep = "" |
| 409 |
) |
|
| 410 | ||
| 411 | ! |
ineq.x.idx <- ineq.x.idx[-fixed.ineq.idx] |
| 412 | ! |
ineq.labels <- ineq.labels[-fixed.ineq.idx] |
| 413 |
} |
|
| 414 | ||
| 415 |
# put the labels the function BODY |
|
| 416 | 85x |
if (length(ineq.x.idx) > 0L) {
|
| 417 | 2x |
ineq.x.lab <- paste(".x.[", ineq.x.idx, "]", sep = "")
|
| 418 | 2x |
if (length(ineq.x.idx) > 0L) {
|
| 419 | 2x |
BODY.txt <- paste(BODY.txt, "# parameter labels\n", |
| 420 | 2x |
paste(ineq.labels, "<-", ineq.x.lab, collapse = "\n"), |
| 421 | 2x |
"\n", |
| 422 | 2x |
sep = "" |
| 423 |
) |
|
| 424 |
} |
|
| 425 |
} |
|
| 426 | ||
| 427 |
# write the constraints literally |
|
| 428 | 85x |
BODY.txt <- paste(BODY.txt, "\n# inequality constraints\n", sep = "") |
| 429 | 85x |
FREE <- partable$free |
| 430 | 85x |
FREE[FREE > 0] <- seq_len(length(FREE[FREE > 0])) |
| 431 | 85x |
for (i in 1:length(ineq.idx)) {
|
| 432 | 525x |
lhs <- partable$lhs[ineq.idx[i]] |
| 433 | 525x |
op <- partable$op[ineq.idx[i]] |
| 434 | 525x |
rhs <- partable$rhs[ineq.idx[i]] |
| 435 | ||
| 436 | 525x |
if (ineq.idx[i] %in% ineq.only.idx) {
|
| 437 |
# EXPLICIT inequality constraints |
|
| 438 |
# note,this is different from ==, because we have < AND > |
|
| 439 | 4x |
if (rhs == "0" && op == ">") {
|
| 440 | ! |
ineq.string <- lhs |
| 441 | 4x |
} else if (rhs == "0" && op == "<") {
|
| 442 | ! |
ineq.string <- paste(rhs, " - (", lhs, ")", sep = "")
|
| 443 | 4x |
} else if (rhs != "0" && op == ">") {
|
| 444 | ! |
ineq.string <- paste(lhs, " - (", rhs, ")", sep = "")
|
| 445 | 4x |
} else if (rhs != "0" && op == "<") {
|
| 446 | 4x |
ineq.string <- paste(rhs, " - (", lhs, ")", sep = "")
|
| 447 |
} |
|
| 448 | 521x |
} else if (ineq.idx[i] %in% upper.idx) {
|
| 449 |
# simple upper bound |
|
| 450 | ! |
val <- partable$upper[ineq.idx[i]] |
| 451 | ! |
xlab <- paste(".x.[", FREE[ineq.idx[i]], "]", sep = "")
|
| 452 | ! |
ineq.string <- paste(val, " - (", xlab, ")", sep = "")
|
| 453 | 521x |
} else if (ineq.idx[i] %in% lower.idx) {
|
| 454 |
# simple lower bound |
|
| 455 | 521x |
val <- partable$lower[ineq.idx[i]] |
| 456 | 521x |
xlab <- paste(".x.[", FREE[ineq.idx[i]], "]", sep = "")
|
| 457 | 521x |
ineq.string <- paste(xlab, " - (", val, ")", sep = "")
|
| 458 |
} |
|
| 459 | ||
| 460 | 525x |
BODY.txt <- paste(BODY.txt, "out[", i, "] <- ", ineq.string, "\n", sep = "") |
| 461 |
} |
|
| 462 | ||
| 463 | 85x |
if (txtOnly) {
|
| 464 | ! |
return(BODY.txt) |
| 465 |
} |
|
| 466 | ||
| 467 |
# put the results in 'out' |
|
| 468 | 85x |
BODY.txt <- paste(BODY.txt, "\n", "out[is.na(out)] <- Inf\n", sep = "") |
| 469 | 85x |
if (length(upper.idx) > 0L || length(lower.idx) > 0L) {
|
| 470 | 83x |
bound.idx <- which(ineq.idx %in% c(upper.idx, lower.idx)) |
| 471 | 83x |
bound.txt <- paste("c(", paste(bound.idx, collapse = ", "), ")", sep = "")
|
| 472 | 83x |
BODY.txt <- paste(BODY.txt, "attr(out, \"bound.idx\") <- ", bound.txt, |
| 473 | 83x |
"\n", sep = "") |
| 474 |
} |
|
| 475 | 85x |
BODY.txt <- paste(BODY.txt, "return(out)\n}\n", sep = "") |
| 476 | 85x |
body(cin.function) <- parse(file = "", text = BODY.txt) |
| 477 | 85x |
if (lav_debug()) {
|
| 478 | ! |
cat("cin.function = \n")
|
| 479 | ! |
print(cin.function) |
| 480 | ! |
cat("\n")
|
| 481 |
} |
|
| 482 | ||
| 483 | 85x |
cin.function |
| 484 |
} |
|
| 485 | ||
| 486 |
# return a named vector of the 'free' indices, for the labels that |
|
| 487 |
# are used in a constrained (or optionally a definition) |
|
| 488 |
# (always 0 for definitions) |
|
| 489 |
lav_partable_constraints_label_id <- function(partable, con = NULL, |
|
| 490 |
def = TRUE) {
|
|
| 491 |
# if 'con', merge partable + con |
|
| 492 | 10x |
if (!is.null(con)) {
|
| 493 | ! |
partable$lhs <- c(partable$lhs, con$lhs) |
| 494 | ! |
partable$op <- c(partable$op, con$op) |
| 495 | ! |
partable$rhs <- c(partable$rhs, con$rhs) |
| 496 |
} |
|
| 497 | ||
| 498 |
# get constraints |
|
| 499 | 10x |
if (def) {
|
| 500 | 10x |
con.idx <- which(partable$op %in% c("==", "<", ">", ":="))
|
| 501 |
} else {
|
|
| 502 | ! |
con.idx <- which(partable$op %in% c("==", "<", ">"))
|
| 503 |
} |
|
| 504 | ||
| 505 |
# catch empty con |
|
| 506 | 10x |
if (length(con.idx) == 0L) {
|
| 507 | ! |
return(integer(0L)) |
| 508 |
} |
|
| 509 | ||
| 510 | 10x |
def.idx <- which(partable$op == ":=") |
| 511 | ||
| 512 |
# extract labels |
|
| 513 | 10x |
lhs.labels <- all.vars(parse(file = "", text = partable$lhs[con.idx])) |
| 514 | 10x |
rhs.labels <- all.vars(parse(file = "", text = partable$rhs[con.idx])) |
| 515 | 10x |
con.labels <- unique(c(lhs.labels, rhs.labels)) |
| 516 | ||
| 517 |
# remove def.names from con.labels (unless def = TRUE) |
|
| 518 | 10x |
if (!def && length(def.idx) > 0L) {
|
| 519 | ! |
def.names <- as.character(partable$lhs[def.idx]) |
| 520 | ! |
d.idx <- which(con.labels %in% def.names) |
| 521 | ! |
if (length(d.idx) > 0) {
|
| 522 | ! |
con.labels <- con.labels[-d.idx] |
| 523 |
} |
|
| 524 |
} |
|
| 525 | 10x |
con.x.idx <- rep(as.integer(NA), length(con.labels)) |
| 526 | ||
| 527 |
# get user-labels ids |
|
| 528 | 10x |
ulab.idx <- which(con.labels %in% partable$label) |
| 529 | 10x |
if (length(ulab.idx) > 0L) {
|
| 530 | ! |
con.x.idx[ulab.idx] <- partable$free[match( |
| 531 | ! |
con.labels[ulab.idx], |
| 532 | ! |
partable$label |
| 533 |
)] |
|
| 534 |
} |
|
| 535 |
# get plabels ids |
|
| 536 | 10x |
plab.idx <- which(con.labels %in% partable$plabel) |
| 537 | 10x |
if (length(plab.idx) > 0L) {
|
| 538 | 10x |
con.x.idx[plab.idx] <- partable$free[match( |
| 539 | 10x |
con.labels[plab.idx], |
| 540 | 10x |
partable$plabel |
| 541 |
)] |
|
| 542 |
} |
|
| 543 | ||
| 544 |
# check if we have found the label |
|
| 545 | 10x |
if (any(is.na(con.x.idx))) {
|
| 546 | ! |
lav_msg_warn(gettext("unknown label(s) in equality constraint(s):"),
|
| 547 | ! |
lav_msg_view(con.labels[which(is.na(con.x.idx))], "none") |
| 548 |
) |
|
| 549 |
} |
|
| 550 | ||
| 551 |
# return named integer vector |
|
| 552 | 10x |
names(con.x.idx) <- con.labels |
| 553 | ||
| 554 | 10x |
con.x.idx |
| 555 |
} |
|
| 556 |
| 1 |
# constructor for the 'lavSampleStats' class |
|
| 2 |
# |
|
| 3 |
# initial version: YR 25/03/2009 |
|
| 4 |
# major revision: YR 5/11/2011: separate data.obs and sample statistics |
|
| 5 |
# YR 5/01/2016: add rescov, resvar, ... if conditional.x = TRUE |
|
| 6 | ||
| 7 |
# YR 18 Jan 2021: use lavoptions |
|
| 8 | ||
| 9 |
lav_samplestats_from_data <- function(lavdata = NULL, |
|
| 10 |
lavoptions = NULL, |
|
| 11 |
WLS.V = NULL, |
|
| 12 |
NACOV = NULL) {
|
|
| 13 |
# extra info from lavoptions |
|
| 14 | 35x |
stopifnot(!is.null(lavoptions)) |
| 15 | 35x |
missing <- lavoptions$missing |
| 16 | 35x |
rescale <- lavoptions$sample.cov.rescale |
| 17 | 35x |
estimator <- lavoptions$estimator |
| 18 | 35x |
mimic <- lavoptions$mimic |
| 19 | 35x |
meanstructure <- lavoptions$meanstructure |
| 20 | 35x |
correlation <- lavoptions$correlation |
| 21 | 35x |
conditional.x <- lavoptions$conditional.x |
| 22 | 35x |
fixed.x <- lavoptions$fixed.x |
| 23 | 35x |
group.w.free <- lavoptions$group.w.free |
| 24 | 35x |
se <- lavoptions$se |
| 25 | 35x |
test <- lavoptions$test |
| 26 | 35x |
ridge <- lavoptions$ridge |
| 27 | 35x |
zero.add <- lavoptions$zero.add |
| 28 | 35x |
zero.keep.margins <- lavoptions$zero.keep.margins |
| 29 | 35x |
zero.cell.warn <- lavoptions$zero.cell.warn |
| 30 | 35x |
allow.empty.cell <- lavoptions$allow.empty.cell |
| 31 | 35x |
dls.a <- lavoptions$estimator.args$dls.a |
| 32 | 35x |
dls.GammaNT <- lavoptions$estimator.args$dls.GammaNT |
| 33 | ||
| 34 |
# sample.icov (new in 0.6-9; ensure it exists, for older objects) |
|
| 35 | 35x |
sample.icov <- TRUE |
| 36 | 35x |
if (!is.null(lavoptions$sample.icov)) {
|
| 37 | 35x |
sample.icov <- lavoptions$sample.icov |
| 38 |
} |
|
| 39 | ||
| 40 |
# ridge default |
|
| 41 | 35x |
if (ridge) {
|
| 42 | ! |
if (is.numeric(lavoptions$ridge.constant)) {
|
| 43 | ! |
ridge.eps <- lavoptions$ridge.constant |
| 44 |
} else {
|
|
| 45 | ! |
ridge.eps <- 1e-5 |
| 46 |
} |
|
| 47 |
} else {
|
|
| 48 | 35x |
ridge.eps <- 0.0 |
| 49 |
} |
|
| 50 | ||
| 51 |
# check lavdata |
|
| 52 | 35x |
stopifnot(!is.null(lavdata)) |
| 53 | ||
| 54 |
# lavdata slots (FIXME: keep lavdata@ names) |
|
| 55 | 35x |
X <- lavdata@X |
| 56 | 35x |
Mp <- lavdata@Mp |
| 57 | 35x |
ngroups <- lavdata@ngroups |
| 58 | 35x |
nlevels <- lavdata@nlevels |
| 59 | 35x |
nobs <- lavdata@nobs |
| 60 | 35x |
ov.names <- lavdata@ov.names |
| 61 | 35x |
ov.names.x <- lavdata@ov.names.x |
| 62 | 35x |
DataOv <- lavdata@ov |
| 63 | 35x |
eXo <- lavdata@eXo |
| 64 | 35x |
WT <- lavdata@weights |
| 65 | ||
| 66 |
# new in 0.6-6 |
|
| 67 |
# if sampling weights have been used, redefine nobs: |
|
| 68 |
# per group, we define nobs == sum(wt) |
|
| 69 | 35x |
for (g in seq_len(ngroups)) {
|
| 70 | 37x |
if (!is.null(WT[[g]])) {
|
| 71 | ! |
nobs[[g]] <- sum(WT[[g]]) |
| 72 |
} |
|
| 73 |
} |
|
| 74 | ||
| 75 |
# sample.cov.robust cannot be used if sampling weights are used |
|
| 76 | 35x |
if (lavoptions$sample.cov.robust) {
|
| 77 | ! |
if (!is.null(WT[[1]])) {
|
| 78 | ! |
lav_msg_stop(gettext( |
| 79 | ! |
"sample.cov.robust = TRUE does not work (yet) |
| 80 | ! |
if sampling weights are provided.")) |
| 81 |
} |
|
| 82 |
} |
|
| 83 | ||
| 84 |
# sample statistics per group |
|
| 85 | ||
| 86 |
# joint (y,x) |
|
| 87 | 35x |
cov <- vector("list", length = ngroups)
|
| 88 | 35x |
var <- vector("list", length = ngroups)
|
| 89 | 35x |
mean <- vector("list", length = ngroups)
|
| 90 | 35x |
th <- vector("list", length = ngroups)
|
| 91 | 35x |
th.idx <- vector("list", length = ngroups)
|
| 92 | 35x |
th.names <- vector("list", length = ngroups)
|
| 93 | ||
| 94 |
# residual (y | x) |
|
| 95 | 35x |
res.cov <- vector("list", length = ngroups)
|
| 96 | 35x |
res.var <- vector("list", length = ngroups)
|
| 97 | 35x |
res.th <- vector("list", length = ngroups)
|
| 98 | 35x |
res.th.nox <- vector("list", length = ngroups)
|
| 99 | 35x |
res.slopes <- vector("list", length = ngroups)
|
| 100 | 35x |
res.int <- vector("list", length = ngroups)
|
| 101 | ||
| 102 |
# fixed.x |
|
| 103 | 35x |
mean.x <- vector("list", length = ngroups)
|
| 104 | 35x |
cov.x <- vector("list", length = ngroups)
|
| 105 | ||
| 106 |
# binary/ordinal |
|
| 107 | 35x |
bifreq <- vector("list", length = ngroups)
|
| 108 | ||
| 109 |
# extra sample statistics per group |
|
| 110 | 35x |
icov <- vector("list", length = ngroups)
|
| 111 | 35x |
cov.log.det <- vector("list", length = ngroups)
|
| 112 | 35x |
res.icov <- vector("list", length = ngroups)
|
| 113 | 35x |
res.cov.log.det <- vector("list", length = ngroups)
|
| 114 | 35x |
WLS.obs <- vector("list", length = ngroups)
|
| 115 | 35x |
missing. <- vector("list", length = ngroups)
|
| 116 | 35x |
missing.h1. <- vector("list", length = ngroups)
|
| 117 | 35x |
missing.flag. <- FALSE |
| 118 | 35x |
zero.cell.tables <- vector("list", length = ngroups)
|
| 119 | 35x |
YLp <- vector("list", length = ngroups)
|
| 120 | ||
| 121 |
# group weights |
|
| 122 | 35x |
group.w <- vector("list", length = ngroups)
|
| 123 | ||
| 124 |
# convenience? # FIXME! |
|
| 125 | 35x |
x.idx <- vector("list", length = ngroups)
|
| 126 | ||
| 127 | ||
| 128 | 35x |
WLS.VD <- vector("list", length = ngroups)
|
| 129 | 35x |
if (is.null(WLS.V)) {
|
| 130 | 35x |
WLS.V <- vector("list", length = ngroups)
|
| 131 | 35x |
WLS.V.user <- FALSE |
| 132 |
} else {
|
|
| 133 | ! |
if (!is.list(WLS.V)) {
|
| 134 | ! |
if (ngroups == 1L) {
|
| 135 | ! |
WLS.V <- list(WLS.V) |
| 136 |
} else {
|
|
| 137 | ! |
lav_msg_stop(gettextf( |
| 138 | ! |
"WLS.V argument should be a list of length %s", ngroups) |
| 139 |
) |
|
| 140 |
} |
|
| 141 |
} else {
|
|
| 142 | ! |
if (length(WLS.V) != ngroups) {
|
| 143 | ! |
lav_msg_stop(gettextf( |
| 144 | ! |
"WLS.V assumes %1$s groups; data contains %2$s groups", |
| 145 | ! |
length(WLS.V), ngroups)) |
| 146 |
} |
|
| 147 |
} |
|
| 148 | ||
| 149 |
# is WLS.V full? check first |
|
| 150 | ! |
if (is.null(dim(WLS.V[[1]]))) {
|
| 151 |
# we will assume it is the diagonal only |
|
| 152 | ! |
WLS.VD <- WLS.V |
| 153 | ! |
WLS.V <- lapply(WLS.VD, diag) |
| 154 |
} else {
|
|
| 155 |
# create WLS.VD |
|
| 156 | ! |
WLS.VD <- lapply(WLS.V, diag) |
| 157 |
} |
|
| 158 | ||
| 159 | ! |
WLS.V.user <- TRUE |
| 160 |
# FIXME: check dimension of WLS.V!! |
|
| 161 |
} |
|
| 162 | ||
| 163 | 35x |
NACOV.compute <- FALSE # since 0.6-6 |
| 164 | 35x |
if (is.null(NACOV)) {
|
| 165 | 35x |
NACOV <- vector("list", length = ngroups)
|
| 166 | 35x |
NACOV.user <- FALSE |
| 167 | 35x |
if (se %in% c("robust.sem", "robust.sem.nt") && missing == "listwise") {
|
| 168 | ! |
NACOV.compute <- TRUE |
| 169 |
} |
|
| 170 |
# note: test can be a vector... |
|
| 171 | 35x |
if (missing == "listwise" && any(test %in% c( |
| 172 | 35x |
"satorra.bentler", |
| 173 | 35x |
"mean.var.adjusted", |
| 174 | 35x |
"scaled.shifted" |
| 175 |
))) {
|
|
| 176 | ! |
NACOV.compute <- TRUE |
| 177 |
} |
|
| 178 | ! |
} else if (is.logical(NACOV)) {
|
| 179 | ! |
if (!NACOV) {
|
| 180 | ! |
NACOV.compute <- FALSE |
| 181 |
} else {
|
|
| 182 | ! |
NACOV.compute <- TRUE |
| 183 |
} |
|
| 184 | ! |
NACOV.user <- FALSE |
| 185 | ! |
NACOV <- vector("list", length = ngroups)
|
| 186 |
} else {
|
|
| 187 | ! |
if (!is.list(NACOV)) {
|
| 188 | ! |
if (ngroups == 1L) {
|
| 189 | ! |
NACOV <- list(NACOV) |
| 190 |
} else {
|
|
| 191 | ! |
lav_msg_stop(gettextf( |
| 192 | ! |
"NACOV argument should be a list of length ", ngroups)) |
| 193 |
} |
|
| 194 |
} else {
|
|
| 195 | ! |
if (length(NACOV) != ngroups) {
|
| 196 | ! |
lav_msg_stop(gettextf( |
| 197 | ! |
"NACOV assumes %1$s groups; data contains %2$s groups", |
| 198 | ! |
length(NACOV), ngroups)) |
| 199 |
} |
|
| 200 |
} |
|
| 201 | ! |
NACOV.user <- TRUE |
| 202 |
# FIXME: check dimension of NACOV!! |
|
| 203 |
} |
|
| 204 | ||
| 205 | ||
| 206 | ||
| 207 |
# compute some sample statistics per group |
|
| 208 | 35x |
for (g in 1:ngroups) {
|
| 209 |
# switch off computing all sample statistics? (housekeeping only) |
|
| 210 | 37x |
if (!is.null(lavoptions$samplestats) && !lavoptions$samplestats) {
|
| 211 | ! |
next |
| 212 |
} |
|
| 213 |
# check nobs |
|
| 214 | 37x |
if (is.null(WT[[g]])) {
|
| 215 | 37x |
if (nobs[[g]] < 2L) {
|
| 216 | ! |
if (nobs[[g]] == 0L) {
|
| 217 | ! |
if (ngroups > 1L) {
|
| 218 | ! |
lav_msg_stop(gettextf("data contains no observations in
|
| 219 | ! |
group %s", g)) |
| 220 |
} else {
|
|
| 221 | ! |
lav_msg_stop(gettext("data contains no observations"))
|
| 222 |
} |
|
| 223 |
} else {
|
|
| 224 | ! |
if (ngroups > 1L) {
|
| 225 | ! |
lav_msg_stop(gettextf("data contains only a single observation
|
| 226 | ! |
in group %s", g)) |
| 227 |
} else {
|
|
| 228 | ! |
lav_msg_stop(gettext("data contains only a single observation"))
|
| 229 |
} |
|
| 230 |
} |
|
| 231 |
} |
|
| 232 |
} |
|
| 233 | ||
| 234 |
# exogenous x? |
|
| 235 | 37x |
nexo <- length(ov.names.x[[g]]) |
| 236 | 37x |
if (nexo) {
|
| 237 | 12x |
stopifnot(nexo == NCOL(eXo[[g]])) |
| 238 | ||
| 239 |
# two cases: ov.names contains 'x' variables, or not |
|
| 240 | 12x |
if (conditional.x) {
|
| 241 |
# ov.names.x are NOT in ov.names |
|
| 242 | 2x |
x.idx[[g]] <- length(ov.names[[g]]) + seq_len(nexo) |
| 243 |
} else {
|
|
| 244 | 10x |
if (fixed.x) {
|
| 245 |
# ov.names.x are a subset of ov.names |
|
| 246 | 10x |
x.idx[[g]] <- match(ov.names.x[[g]], ov.names[[g]]) |
| 247 | 10x |
stopifnot(!anyNA(x.idx[[g]])) |
| 248 |
} else {
|
|
| 249 | ! |
x.idx[[g]] <- integer(0L) |
| 250 |
} |
|
| 251 |
} |
|
| 252 |
} else {
|
|
| 253 | 25x |
x.idx[[g]] <- integer(0L) |
| 254 | 25x |
conditional.x <- FALSE |
| 255 | 25x |
fixed.x <- FALSE |
| 256 |
} |
|
| 257 | ||
| 258 |
# group weight |
|
| 259 | 37x |
group.w[[g]] <- nobs[[g]] / sum(unlist(nobs)) |
| 260 | ||
| 261 |
# check if we have categorical data in this group |
|
| 262 | 37x |
categorical <- FALSE |
| 263 | 37x |
ov.types <- DataOv$type[match(ov.names[[g]], DataOv$name)] |
| 264 | 37x |
ov.levels <- DataOv$nlev[match(ov.names[[g]], DataOv$name)] |
| 265 | 37x |
CAT <- list() |
| 266 | 37x |
if ("ordered" %in% ov.types) {
|
| 267 | 2x |
categorical <- TRUE |
| 268 | 2x |
if (nlevels > 1L) {
|
| 269 | ! |
lav_msg_warn(gettext("multilevel + categorical not supported yet."))
|
| 270 |
} |
|
| 271 |
} |
|
| 272 | ||
| 273 | 37x |
if (categorical) {
|
| 274 |
# compute CAT |
|
| 275 | ||
| 276 | 2x |
if (estimator %in% c("ML", "REML", "PML", "FML", "MML", "none", "ULS")) {
|
| 277 | ! |
WLS.W <- FALSE |
| 278 | ! |
if (estimator == "ULS" && se %in% c("robust.sem", "robust.sem.nt")) {
|
| 279 | ! |
WLS.W <- TRUE |
| 280 |
} |
|
| 281 |
} else {
|
|
| 282 | 2x |
WLS.W <- TRUE |
| 283 |
} |
|
| 284 |
# check cat.wls.w option (new in 0.6-18) |
|
| 285 | 2x |
if (!is.null(lavoptions$cat.wls.w) && !lavoptions$cat.wls.w) {
|
| 286 | ! |
WLS.W <- FALSE # perhaps do.fit = FALSE? (eg sam()) |
| 287 |
} |
|
| 288 | 2x |
if (lav_verbose()) {
|
| 289 | ! |
cat("Estimating sample thresholds and correlations ... ")
|
| 290 |
} |
|
| 291 | ||
| 292 | 2x |
current.verbose <- lav_verbose() |
| 293 | 2x |
if (lav_verbose(lav_debug())) |
| 294 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 295 | 2x |
if (conditional.x) {
|
| 296 | 2x |
CAT <- muthen1984( |
| 297 | 2x |
Data = X[[g]], |
| 298 | 2x |
wt = WT[[g]], |
| 299 | 2x |
ov.names = ov.names[[g]], |
| 300 | 2x |
ov.types = ov.types, |
| 301 | 2x |
ov.levels = ov.levels, |
| 302 | 2x |
ov.names.x = ov.names.x[[g]], |
| 303 | 2x |
eXo = eXo[[g]], |
| 304 | 2x |
group = g, # for error messages only |
| 305 | 2x |
WLS.W = WLS.W, |
| 306 | 2x |
zero.add = zero.add, |
| 307 | 2x |
zero.keep.margins = zero.keep.margins, |
| 308 | 2x |
zero.cell.warn = FALSE, |
| 309 | 2x |
zero.cell.tables = TRUE, |
| 310 | 2x |
allow.empty.cell = allow.empty.cell |
| 311 |
) |
|
| 312 |
} else {
|
|
| 313 | ! |
CAT <- muthen1984( |
| 314 | ! |
Data = X[[g]], |
| 315 | ! |
wt = WT[[g]], |
| 316 | ! |
ov.names = ov.names[[g]], |
| 317 | ! |
ov.types = ov.types, |
| 318 | ! |
ov.levels = ov.levels, |
| 319 | ! |
ov.names.x = NULL, |
| 320 | ! |
eXo = NULL, |
| 321 | ! |
group = g, # for error messages only |
| 322 | ! |
WLS.W = WLS.W, |
| 323 | ! |
zero.add = zero.add, |
| 324 | ! |
zero.keep.margins = zero.keep.margins, |
| 325 | ! |
zero.cell.warn = FALSE, |
| 326 | ! |
zero.cell.tables = TRUE, |
| 327 | ! |
allow.empty.cell = allow.empty.cell |
| 328 |
) |
|
| 329 |
} |
|
| 330 | 2x |
lav_verbose(current.verbose) |
| 331 |
# empty cell tables |
|
| 332 | 2x |
zero.cell.tables[[g]] <- CAT$zero.cell.tables |
| 333 | ! |
if (lav_verbose()) cat("done\n")
|
| 334 |
} |
|
| 335 | ||
| 336 | 37x |
if (categorical) {
|
| 337 |
# convenience |
|
| 338 | 2x |
th.idx[[g]] <- unlist(CAT$TH.IDX) |
| 339 | 2x |
th.names[[g]] <- unlist(CAT$TH.NAMES) |
| 340 | ||
| 341 | 2x |
if (conditional.x) {
|
| 342 |
# residual var/cov |
|
| 343 | 2x |
res.var[[g]] <- unlist(CAT$VAR) |
| 344 | 2x |
res.cov[[g]] <- unname(CAT$COV) |
| 345 | 2x |
if (ridge) {
|
| 346 | ! |
diag(res.cov[[g]]) <- diag(res.cov[[g]]) + ridge.eps |
| 347 | ! |
res.var[[g]] <- diag(res.cov[[g]]) |
| 348 |
} |
|
| 349 | ||
| 350 |
# th also contains the means of numeric variables |
|
| 351 | 2x |
res.th[[g]] <- unlist(CAT$TH) |
| 352 | 2x |
res.th.nox[[g]] <- unlist(CAT$TH.NOX) |
| 353 | ||
| 354 |
# for convenience, we store the intercept of numeric |
|
| 355 |
# variables in res.int |
|
| 356 | 2x |
NVAR <- NCOL(res.cov[[g]]) |
| 357 | 2x |
mean[[g]] <- res.int[[g]] <- numeric(NVAR) |
| 358 | 2x |
num.idx <- which(!seq_len(NVAR) %in% th.idx[[g]]) |
| 359 | 2x |
if (length(num.idx) > 0L) {
|
| 360 | 2x |
NUM.idx <- which(th.idx[[g]] == 0L) |
| 361 | 2x |
mean[[g]][num.idx] <- res.th.nox[[g]][NUM.idx] |
| 362 | 2x |
res.int[[g]][num.idx] <- res.th[[g]][NUM.idx] |
| 363 |
} |
|
| 364 | ||
| 365 |
# slopes |
|
| 366 | 2x |
res.slopes[[g]] <- CAT$SLOPES |
| 367 |
} else {
|
|
| 368 |
# var/cov |
|
| 369 | ! |
var[[g]] <- unlist(CAT$VAR) |
| 370 | ! |
cov[[g]] <- unname(CAT$COV) |
| 371 | ! |
if (ridge) {
|
| 372 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 373 | ! |
var[[g]] <- diag(cov[[g]]) |
| 374 |
} |
|
| 375 | ||
| 376 |
# th also contains the means of numeric variables |
|
| 377 | ! |
th[[g]] <- unlist(CAT$TH) |
| 378 | ||
| 379 |
# mean (numeric only) |
|
| 380 | ! |
NVAR <- NCOL(cov[[g]]) |
| 381 | ! |
mean[[g]] <- numeric(NVAR) |
| 382 | ! |
num.idx <- which(!seq_len(NVAR) %in% th.idx[[g]]) |
| 383 | ! |
if (length(num.idx) > 0L) {
|
| 384 | ! |
NUM.idx <- which(th.idx[[g]] == 0L) |
| 385 | ! |
mean[[g]][num.idx] <- th[[g]][NUM.idx] |
| 386 |
} |
|
| 387 |
} |
|
| 388 | ||
| 389 |
# only for catML |
|
| 390 | 2x |
if (estimator == "catML") {
|
| 391 | ! |
COV <- cov2cor(lav_matrix_symmetric_force_pd(cov[[g]], |
| 392 | ! |
tol = 1e-04 |
| 393 |
)) |
|
| 394 |
# overwrite |
|
| 395 | ! |
cov[[g]] <- COV |
| 396 | ! |
out <- lav_samplestats_icov( |
| 397 | ! |
COV = COV, |
| 398 | ! |
x.idx = x.idx[[g]], |
| 399 | ! |
ngroups = ngroups, g = g |
| 400 |
) |
|
| 401 | ! |
icov[[g]] <- out$icov |
| 402 | ! |
cov.log.det[[g]] <- out$cov.log.det |
| 403 | ||
| 404 |
# the same for res.cov if conditional.x = TRUE |
|
| 405 | ! |
if (conditional.x) {
|
| 406 | ! |
RES.COV <- |
| 407 | ! |
cov2cor(lav_matrix_symmetric_force_pd(res.cov[[g]], |
| 408 | ! |
tol = 1e-04 |
| 409 |
)) |
|
| 410 |
# overwrite |
|
| 411 | ! |
res.cov[[g]] <- RES.COV |
| 412 | ! |
out <- lav_samplestats_icov( |
| 413 | ! |
COV = RES.COV, |
| 414 | ! |
ridge = 1e-05, |
| 415 | ! |
x.idx = x.idx[[g]], |
| 416 | ! |
ngroups = ngroups, g = g |
| 417 |
) |
|
| 418 | ! |
res.icov[[g]] <- out$icov |
| 419 | ! |
res.cov.log.det[[g]] <- out$cov.log.det |
| 420 |
} |
|
| 421 |
} |
|
| 422 |
} # categorical |
|
| 423 | ||
| 424 |
# continuous -- multilevel |
|
| 425 | 35x |
else if (nlevels > 1L) {
|
| 426 |
# level-based sample statistics |
|
| 427 | 4x |
YLp[[g]] <- lav_samplestats_cluster_patterns( |
| 428 | 4x |
Y = X[[g]], |
| 429 | 4x |
Lp = lavdata@Lp[[g]], |
| 430 | 4x |
conditional.x = lavoptions$conditional.x |
| 431 |
) |
|
| 432 | ||
| 433 | ||
| 434 | 4x |
if (conditional.x) {
|
| 435 |
# for starting values only |
|
| 436 |
# no handling of missing data yet.... |
|
| 437 | ! |
if (missing %in% c( |
| 438 | ! |
"ml", "ml.x", |
| 439 | ! |
"two.stage", "robust.two.stage" |
| 440 |
)) {
|
|
| 441 | ! |
lav_msg_stop(gettextf( |
| 442 | ! |
"missing = %s + conditional.x + two.level not supported yet", |
| 443 | ! |
missing)) |
| 444 |
} |
|
| 445 | ||
| 446 |
# residual covariances! |
|
| 447 | ! |
Y <- X[[g]] # contains eXo |
| 448 | ! |
COV <- unname(stats::cov(Y, use = "pairwise.complete.obs")) |
| 449 |
# if we have missing values (missing by design?), replace them by 0 |
|
| 450 | ! |
COV[is.na(COV)] <- 0 |
| 451 | ! |
MEAN <- unname(colMeans(Y, na.rm = TRUE)) |
| 452 | ! |
var[[g]] <- diag(COV) |
| 453 |
# rescale cov by (N-1)/N? (only COV!) |
|
| 454 | ! |
if (rescale) {
|
| 455 |
# we 'transform' the sample cov (divided by n-1) |
|
| 456 |
# to a sample cov divided by 'n' |
|
| 457 | ! |
COV <- ((nobs[[g]] - 1) / nobs[[g]]) * COV |
| 458 |
} |
|
| 459 | ! |
cov[[g]] <- COV |
| 460 | ! |
if (ridge) {
|
| 461 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 462 | ! |
var[[g]] <- diag(cov[[g]]) |
| 463 |
} |
|
| 464 | ! |
mean[[g]] <- MEAN |
| 465 | ||
| 466 | ! |
A <- COV[-x.idx[[g]], -x.idx[[g]], drop = FALSE] |
| 467 | ! |
B <- COV[-x.idx[[g]], x.idx[[g]], drop = FALSE] |
| 468 | ! |
C <- COV[x.idx[[g]], x.idx[[g]], drop = FALSE] |
| 469 |
# FIXME: make robust against singular C!!! |
|
| 470 | ! |
res.cov[[g]] <- A - B %*% solve(C) %*% t(B) |
| 471 | ! |
res.var[[g]] <- diag(cov[[g]]) |
| 472 | ||
| 473 | ! |
MY <- MEAN[-x.idx[[g]]] |
| 474 | ! |
MX <- MEAN[x.idx[[g]]] |
| 475 | ! |
C3 <- rbind( |
| 476 | ! |
c(1, MX), |
| 477 | ! |
cbind(MX, C + tcrossprod(MX)) |
| 478 |
) |
|
| 479 | ! |
B3 <- cbind(MY, B + tcrossprod(MY, MX)) |
| 480 | ! |
COEF <- unname(solve(C3, t(B3))) |
| 481 | ||
| 482 | ! |
res.int[[g]] <- COEF[1, ] # intercepts |
| 483 | ! |
res.slopes[[g]] <- t(COEF[-1, , drop = FALSE]) # slopes |
| 484 |
} else {
|
|
| 485 |
# FIXME: needed? |
|
| 486 | 4x |
COV <- unname(stats::cov(X[[g]], use = "pairwise.complete.obs")) |
| 487 |
# if we have missing values (missing by design?), replace them by 0 |
|
| 488 | 4x |
COV[is.na(COV)] <- 0 |
| 489 | 4x |
cov[[g]] <- COV |
| 490 | 4x |
mean[[g]] <- unname(colMeans(X[[g]], na.rm = TRUE)) |
| 491 | 4x |
var[[g]] <- diag(cov[[g]]) |
| 492 | ||
| 493 |
# missing patterns |
|
| 494 | 4x |
if (missing %in% c("ml", "ml.x")) {
|
| 495 | ! |
missing.flag. <- TRUE |
| 496 | ! |
missing.[[g]] <- |
| 497 | ! |
lav_samplestats_missing_patterns( |
| 498 | ! |
Y = X[[g]], |
| 499 | ! |
Mp = Mp[[g]], |
| 500 | ! |
wt = WT[[g]], |
| 501 | ! |
Lp = lavdata@Lp[[g]] |
| 502 |
) |
|
| 503 |
} |
|
| 504 |
} |
|
| 505 |
} # multilevel |
|
| 506 | ||
| 507 |
# continuous -- single-level |
|
| 508 |
else {
|
|
| 509 | 31x |
if (conditional.x) {
|
| 510 |
# FIXME! |
|
| 511 |
# no correlation structures yet |
|
| 512 | ! |
if (correlation) {
|
| 513 | ! |
lav_msg_stop(gettext( |
| 514 | ! |
"conditional.x = TRUE is not supported (yet) for |
| 515 | ! |
correlation structures.")) |
| 516 |
} |
|
| 517 | ||
| 518 |
# FIXME! |
|
| 519 |
# no handling of missing data yet.... |
|
| 520 | ! |
if (missing %in% c( |
| 521 | ! |
"ml", "ml.x", |
| 522 | ! |
"two.stage", "robust.two.stage" |
| 523 |
)) {
|
|
| 524 | ! |
lav_msg_stop(gettextf( |
| 525 | ! |
"missing = %s + conditional.x not supported yet", missing)) |
| 526 |
} |
|
| 527 | ||
| 528 |
# residual covariances! |
|
| 529 | ||
| 530 | ! |
Y <- cbind(X[[g]], eXo[[g]]) |
| 531 | ! |
COV <- unname(stats::cov(Y, use = "pairwise.complete.obs")) |
| 532 |
# if we have missing values (missing by design?), replace them by 0 |
|
| 533 | ! |
COV[is.na(COV)] <- 0 |
| 534 | ! |
MEAN <- unname(colMeans(Y, na.rm = TRUE)) |
| 535 |
# rescale cov by (N-1)/N? (only COV!) |
|
| 536 | ! |
if (rescale) {
|
| 537 |
# we 'transform' the sample cov (divided by n-1) |
|
| 538 |
# to a sample cov divided by 'n' |
|
| 539 | ! |
COV <- ((nobs[[g]] - 1) / nobs[[g]]) * COV |
| 540 |
} |
|
| 541 | ! |
cov[[g]] <- COV |
| 542 | ! |
var[[g]] <- diag(COV) |
| 543 | ! |
if (ridge) {
|
| 544 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 545 | ! |
var[[g]] <- diag(cov[[g]]) |
| 546 |
} |
|
| 547 | ! |
mean[[g]] <- MEAN |
| 548 | ||
| 549 | ! |
A <- COV[-x.idx[[g]], -x.idx[[g]], drop = FALSE] |
| 550 | ! |
B <- COV[-x.idx[[g]], x.idx[[g]], drop = FALSE] |
| 551 | ! |
C <- COV[x.idx[[g]], x.idx[[g]], drop = FALSE] |
| 552 |
# FIXME: make robust against singular C!!! |
|
| 553 | ! |
res.cov[[g]] <- A - B %*% solve(C) %*% t(B) |
| 554 | ! |
res.var[[g]] <- diag(cov[[g]]) |
| 555 | ||
| 556 | ||
| 557 | ! |
MY <- MEAN[-x.idx[[g]]] |
| 558 | ! |
MX <- MEAN[x.idx[[g]]] |
| 559 | ! |
C3 <- rbind( |
| 560 | ! |
c(1, MX), |
| 561 | ! |
cbind(MX, C + tcrossprod(MX)) |
| 562 |
) |
|
| 563 | ! |
B3 <- cbind(MY, B + tcrossprod(MY, MX)) |
| 564 | ! |
COEF <- unname(solve(C3, t(B3))) |
| 565 | ||
| 566 | ! |
res.int[[g]] <- COEF[1, ] # intercepts |
| 567 | ! |
res.slopes[[g]] <- t(COEF[-1, , drop = FALSE]) # slopes |
| 568 | 31x |
} else if (missing == "two.stage" || |
| 569 | 31x |
missing == "robust.two.stage") {
|
| 570 | ! |
missing.flag. <- FALSE # !!! just use sample statistics |
| 571 | ! |
missing.[[g]] <- |
| 572 | ! |
lav_samplestats_missing_patterns( |
| 573 | ! |
Y = X[[g]], |
| 574 | ! |
Mp = Mp[[g]], |
| 575 | ! |
wt = WT[[g]] |
| 576 |
) |
|
| 577 | ! |
current.warn <- lav_warn() |
| 578 | ! |
if (lav_warn(lavoptions$em.h1.warn)) |
| 579 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 580 | ! |
out <- lav_mvnorm_missing_h1_estimate_moments( |
| 581 | ! |
Y = X[[g]], |
| 582 | ! |
wt = WT[[g]], |
| 583 | ! |
Mp = Mp[[g]], Yp = missing.[[g]], |
| 584 | ! |
max.iter = lavoptions$em.h1.iter.max, |
| 585 | ! |
tol = lavoptions$em.h1.tol, |
| 586 |
) |
|
| 587 | ! |
lav_warn(current.warn) |
| 588 | ! |
missing.h1.[[g]]$sigma <- out$Sigma |
| 589 | ! |
missing.h1.[[g]]$mu <- out$Mu |
| 590 | ! |
missing.h1.[[g]]$h1 <- out$fx |
| 591 | ||
| 592 |
# here, sample statistics == EM estimates |
|
| 593 | ! |
cov[[g]] <- missing.h1.[[g]]$sigma |
| 594 | ! |
if (ridge) {
|
| 595 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 596 |
} |
|
| 597 | ! |
var[[g]] <- diag(cov[[g]]) |
| 598 | ! |
mean[[g]] <- missing.h1.[[g]]$mu |
| 599 | 31x |
} else if (missing %in% c("ml", "ml.x")) {
|
| 600 | 8x |
missing.flag. <- TRUE |
| 601 | 8x |
missing.[[g]] <- |
| 602 | 8x |
lav_samplestats_missing_patterns( |
| 603 | 8x |
Y = X[[g]], |
| 604 | 8x |
Mp = Mp[[g]], |
| 605 | 8x |
wt = WT[[g]] |
| 606 |
) |
|
| 607 | ||
| 608 | 8x |
if (nlevels == 1L) {
|
| 609 |
# estimate moments unrestricted model |
|
| 610 | 8x |
current.warn <- lav_warn() |
| 611 | 8x |
if (lav_warn(lavoptions$em.h1.warn)) |
| 612 | 4x |
on.exit(lav_warn(current.warn), TRUE) |
| 613 |
# zero coverage? |
|
| 614 | 8x |
if (any(lav_matrix_vech(Mp[[g]]$coverage, diagonal = FALSE) == 0)) {
|
| 615 |
#out <- lav_mvnorm_missing_h1_estimate_moments_chol( |
|
| 616 |
# lavdata = lavdata, lavoptions = lavoptions, group = g) |
|
| 617 |
#missing.h1.[[g]]$sigma <- out$Sigma |
|
| 618 |
#missing.h1.[[g]]$mu <- out$Mu |
|
| 619 |
#missing.h1.[[g]]$h1 <- out$fx |
|
| 620 |
} else {
|
|
| 621 | 8x |
out <- lav_mvnorm_missing_h1_estimate_moments( |
| 622 | 8x |
Y = X[[g]], |
| 623 | 8x |
wt = WT[[g]], |
| 624 | 8x |
Mp = Mp[[g]], Yp = missing.[[g]], |
| 625 | 8x |
max.iter = lavoptions$em.h1.iter.max, |
| 626 | 8x |
tol = lavoptions$em.h1.tol |
| 627 |
) |
|
| 628 | 8x |
missing.h1.[[g]]$sigma <- out$Sigma |
| 629 | 8x |
missing.h1.[[g]]$mu <- out$Mu |
| 630 | 8x |
missing.h1.[[g]]$h1 <- out$fx |
| 631 |
} |
|
| 632 | 8x |
lav_warn(current.warn) |
| 633 |
} |
|
| 634 | ||
| 635 | 8x |
if (!is.null(WT[[g]])) {
|
| 636 |
# here, sample statistics == EM estimates |
|
| 637 | ! |
cov[[g]] <- missing.h1.[[g]]$sigma |
| 638 | ! |
if (ridge) {
|
| 639 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 640 |
} |
|
| 641 | ! |
var[[g]] <- diag(cov[[g]]) |
| 642 | ! |
mean[[g]] <- missing.h1.[[g]]$mu |
| 643 |
} else {
|
|
| 644 |
# NEEDED? why not just EM-based? |
|
| 645 | 8x |
COV <- unname(stats::cov(X[[g]], use = "pairwise.complete.obs")) |
| 646 |
# if we have missing values (missing by design?), replace them by 0 |
|
| 647 | 8x |
COV[is.na(COV)] <- 0 |
| 648 | 8x |
cov[[g]] <- COV |
| 649 |
# rescale cov by (N-1)/N? (only COV!) |
|
| 650 | 8x |
if (rescale) {
|
| 651 |
# we 'transform' the sample cov (divided by n-1) |
|
| 652 |
# to a sample cov divided by 'n' |
|
| 653 | 8x |
cov[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov[[g]] |
| 654 |
} |
|
| 655 | 8x |
if (ridge) {
|
| 656 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 657 |
} |
|
| 658 | 8x |
var[[g]] <- diag(cov[[g]]) |
| 659 | 8x |
mean[[g]] <- colMeans(X[[g]], na.rm = TRUE) |
| 660 |
} |
|
| 661 |
} else {
|
|
| 662 |
# LISTWISE |
|
| 663 | 23x |
if (!is.null(WT[[g]])) {
|
| 664 | ! |
out <- stats::cov.wt(X[[g]], |
| 665 | ! |
wt = WT[[g]], |
| 666 | ! |
method = "ML" |
| 667 |
) |
|
| 668 | ! |
COV <- out$cov |
| 669 |
# if we have missing values (missing by design?), replace them by 0 |
|
| 670 | ! |
COV[is.na(COV)] <- 0 |
| 671 | ! |
cov[[g]] <- COV |
| 672 | ! |
if (ridge) {
|
| 673 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 674 |
} |
|
| 675 | ! |
var[[g]] <- diag(cov[[g]]) |
| 676 | ! |
mean[[g]] <- out$center |
| 677 | 23x |
} else if (lavoptions$sample.cov.robust) {
|
| 678 |
# fixme: allow prob/max.it to be options |
|
| 679 | ! |
out <- lav_cov_huber( |
| 680 | ! |
Y = X[[g]], prob = 0.95, |
| 681 | ! |
max.it = 200L, tol = 1e-07 |
| 682 |
) |
|
| 683 | ! |
cov[[g]] <- out$Sigma |
| 684 | ! |
var[[g]] <- diag(cov[[g]]) |
| 685 | ! |
mean[[g]] <- out$Mu |
| 686 |
} else {
|
|
| 687 | 23x |
COV <- unname(stats::cov(X[[g]], use = "pairwise.complete.obs")) |
| 688 |
# if we have missing values (missing by design?), replace them by 0 |
|
| 689 | 23x |
COV[is.na(COV)] <- 0 |
| 690 | 23x |
cov[[g]] <- COV |
| 691 |
# rescale cov by (N-1)/N? (only COV!) |
|
| 692 | 23x |
if (rescale) {
|
| 693 |
# we 'transform' the sample cov (divided by n-1) |
|
| 694 |
# to a sample cov divided by 'n' |
|
| 695 | 15x |
cov[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov[[g]] |
| 696 |
} |
|
| 697 | 23x |
if (ridge) {
|
| 698 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 699 |
} |
|
| 700 | 23x |
var[[g]] <- diag(cov[[g]]) |
| 701 | 23x |
mean[[g]] <- colMeans(X[[g]], na.rm = TRUE) |
| 702 |
} |
|
| 703 |
} |
|
| 704 | ||
| 705 |
# correlation structure? |
|
| 706 | 31x |
if (correlation) {
|
| 707 | ! |
cov[[g]] <- cov2cor(cov[[g]]) |
| 708 | ! |
var[[g]] <- rep(1, length(var[[g]])) |
| 709 | ! |
if (conditional.x) {
|
| 710 | ! |
res.cov[[g]] <- cov2cor(res.cov[[g]]) |
| 711 | ! |
res.var[[g]] <- rep(1, length(res.var[[g]])) |
| 712 | ! |
cov.x[[g]] <- cov2cor(cov.x[[g]]) |
| 713 |
# FIXME: slopes? more? |
|
| 714 |
} |
|
| 715 |
} |
|
| 716 | ||
| 717 |
# icov and cov.log.det (but not if missing) |
|
| 718 | 31x |
if (sample.icov && !missing %in% c("ml", "ml.x")) {
|
| 719 | 23x |
out <- lav_samplestats_icov( |
| 720 | 23x |
COV = cov[[g]], ridge = 1e-05, |
| 721 | 23x |
x.idx = x.idx[[g]], |
| 722 | 23x |
ngroups = ngroups, g = g |
| 723 |
) |
|
| 724 | 23x |
icov[[g]] <- out$icov |
| 725 | 23x |
cov.log.det[[g]] <- out$cov.log.det |
| 726 | ||
| 727 |
# the same for res.cov if conditional.x = TRUE |
|
| 728 | 23x |
if (conditional.x) {
|
| 729 | ! |
out <- lav_samplestats_icov( |
| 730 | ! |
COV = res.cov[[g]], |
| 731 | ! |
ridge = 1e-05, |
| 732 | ! |
x.idx = x.idx[[g]], |
| 733 | ! |
ngroups = ngroups, g = g |
| 734 |
) |
|
| 735 | ! |
res.icov[[g]] <- out$icov |
| 736 | ! |
res.cov.log.det[[g]] <- out$cov.log.det |
| 737 |
} |
|
| 738 |
} |
|
| 739 |
} # continuous - single level |
|
| 740 | ||
| 741 | ||
| 742 |
# WLS.obs |
|
| 743 | 37x |
if (nlevels == 1L) {
|
| 744 | 33x |
if (estimator == "catML") {
|
| 745 |
# correlations only (for now) |
|
| 746 | ! |
tmp.categorical <- FALSE |
| 747 | ! |
tmp.meanstructure <- FALSE |
| 748 |
} else {
|
|
| 749 | 33x |
tmp.categorical <- categorical |
| 750 | 33x |
tmp.meanstructure <- meanstructure |
| 751 |
} |
|
| 752 | 33x |
WLS.obs[[g]] <- lav_samplestats_wls_obs( |
| 753 | 33x |
mean.g = mean[[g]], |
| 754 | 33x |
cov.g = cov[[g]], var.g = var[[g]], th.g = th[[g]], |
| 755 | 33x |
th.idx.g = th.idx[[g]], res.int.g = res.int[[g]], |
| 756 | 33x |
res.cov.g = res.cov[[g]], res.var.g = res.var[[g]], |
| 757 | 33x |
res.th.g = res.th[[g]], res.slopes.g = res.slopes[[g]], |
| 758 | 33x |
group.w.g = log(nobs[[g]]), |
| 759 | 33x |
categorical = tmp.categorical, conditional.x = conditional.x, |
| 760 | 33x |
meanstructure = tmp.meanstructure, correlation = correlation, |
| 761 | 33x |
slopestructure = conditional.x, |
| 762 | 33x |
group.w.free = group.w.free |
| 763 |
) |
|
| 764 |
} |
|
| 765 | ||
| 766 |
# fill in the other slots |
|
| 767 | 37x |
if (!is.null(eXo[[g]])) {
|
| 768 | 12x |
if (!is.null(WT[[g]])) {
|
| 769 | ! |
if (missing != "listwise") {
|
| 770 | ! |
cov.x[[g]] <- missing.h1.[[g]]$sigma[x.idx[[g]], |
| 771 | ! |
x.idx[[g]], |
| 772 | ! |
drop = FALSE |
| 773 |
] |
|
| 774 | ! |
mean.x[[g]] <- missing.h1.[[g]]$mu[x.idx[[g]]] |
| 775 |
} else {
|
|
| 776 | ! |
out <- stats::cov.wt(eXo[[g]], |
| 777 | ! |
wt = WT[[g]], |
| 778 | ! |
method = "ML" |
| 779 |
) |
|
| 780 | ! |
cov.x[[g]] <- out$cov |
| 781 | ! |
mean.x[[g]] <- out$center |
| 782 |
} |
|
| 783 |
} else {
|
|
| 784 | 12x |
cov.x[[g]] <- cov(eXo[[g]], use = "pairwise") |
| 785 | 12x |
if (rescale) {
|
| 786 |
# we 'transform' the sample cov (divided by n-1) |
|
| 787 |
# to a sample cov divided by 'n' |
|
| 788 | 10x |
cov.x[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov.x[[g]] |
| 789 |
} |
|
| 790 | 12x |
mean.x[[g]] <- colMeans(eXo[[g]]) |
| 791 |
} |
|
| 792 |
} |
|
| 793 | ||
| 794 |
# NACOV (=GAMMA) |
|
| 795 | 37x |
if (!NACOV.user && nlevels == 1L) {
|
| 796 | 33x |
if (estimator == "ML" && !missing.flag. && NACOV.compute) {
|
| 797 | ! |
if (conditional.x) {
|
| 798 | ! |
Y <- Y |
| 799 |
} else {
|
|
| 800 | ! |
Y <- X[[g]] |
| 801 |
} |
|
| 802 | ||
| 803 | ! |
if (length(lavdata@cluster) > 0L) {
|
| 804 | ! |
cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
| 805 |
} else {
|
|
| 806 | ! |
cluster.idx <- NULL |
| 807 |
} |
|
| 808 | ||
| 809 | ! |
if (correlation) {
|
| 810 | ! |
NACOV[[g]] <- lav_samplestats_cor_Gamma( |
| 811 | ! |
Y = Y, |
| 812 | ! |
meanstructure = meanstructure |
| 813 |
) |
|
| 814 |
} else {
|
|
| 815 | ! |
NACOV[[g]] <- |
| 816 | ! |
lav_samplestats_Gamma( |
| 817 | ! |
Y = Y, |
| 818 | ! |
x.idx = x.idx[[g]], |
| 819 | ! |
cluster.idx = cluster.idx, |
| 820 | ! |
fixed.x = fixed.x, |
| 821 | ! |
conditional.x = conditional.x, |
| 822 | ! |
meanstructure = meanstructure, |
| 823 | ! |
slopestructure = conditional.x, |
| 824 | ! |
gamma.n.minus.one = |
| 825 | ! |
lavoptions$gamma.n.minus.one, |
| 826 | ! |
unbiased = lavoptions$gamma.unbiased, |
| 827 | ! |
Mplus.WLS = FALSE |
| 828 |
) |
|
| 829 |
} |
|
| 830 | 33x |
} else if (estimator %in% c("WLS", "DWLS", "ULS", "DLS", "catML")) {
|
| 831 | 4x |
if (!categorical) {
|
| 832 |
# sample size large enough? |
|
| 833 | 2x |
nvar <- ncol(X[[g]]) |
| 834 |
# if(conditional.x && nexo > 0L) {
|
|
| 835 |
# nvar <- nvar - nexo |
|
| 836 |
# } |
|
| 837 | 2x |
pstar <- nvar * (nvar + 1) / 2 |
| 838 | ! |
if (meanstructure) pstar <- pstar + nvar |
| 839 | 2x |
if (conditional.x && nexo > 0L) {
|
| 840 | ! |
pstar <- pstar + (nvar * nexo) |
| 841 |
} |
|
| 842 | 2x |
if (nrow(X[[g]]) < pstar) {
|
| 843 | ! |
if (ngroups > 1L) {
|
| 844 | ! |
lav_msg_warn(gettextf( |
| 845 | ! |
"number of observations (%s) too small to compute Gamma", |
| 846 | ! |
nrow(X[[g]]), " in group %s", g)) |
| 847 |
} else {
|
|
| 848 | ! |
lav_msg_warn(gettextf( |
| 849 | ! |
"number of observations (%s) too small to compute Gamma", |
| 850 | ! |
nrow(X[[g]]))) |
| 851 |
} |
|
| 852 |
} |
|
| 853 | 2x |
if (conditional.x) {
|
| 854 | ! |
Y <- Y |
| 855 |
} else {
|
|
| 856 | 2x |
Y <- X[[g]] |
| 857 |
} |
|
| 858 | ||
| 859 | 2x |
if (length(lavdata@cluster) > 0L) {
|
| 860 | ! |
cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
| 861 |
} else {
|
|
| 862 | 2x |
cluster.idx <- NULL |
| 863 |
} |
|
| 864 | 2x |
if (correlation) {
|
| 865 | ! |
NACOV[[g]] <- lav_samplestats_cor_Gamma( |
| 866 | ! |
Y = Y, |
| 867 | ! |
meanstructure = meanstructure |
| 868 |
) |
|
| 869 |
} else {
|
|
| 870 | 2x |
if (lavoptions$se == "robust.sem.nt") {
|
| 871 | ! |
NACOV[[g]] <- |
| 872 | ! |
lav_samplestats_Gamma_NT( |
| 873 | ! |
Y = Y, |
| 874 | ! |
x.idx = x.idx[[g]], |
| 875 |
# cluster.idx = cluster.idx, # not available |
|
| 876 | ! |
fixed.x = fixed.x, |
| 877 | ! |
conditional.x = conditional.x, |
| 878 | ! |
meanstructure = meanstructure, |
| 879 | ! |
slopestructure = conditional.x |
| 880 |
) |
|
| 881 |
} else {
|
|
| 882 | 2x |
NACOV[[g]] <- |
| 883 | 2x |
lav_samplestats_Gamma( |
| 884 | 2x |
Y = Y, |
| 885 | 2x |
x.idx = x.idx[[g]], |
| 886 | 2x |
cluster.idx = cluster.idx, |
| 887 | 2x |
fixed.x = fixed.x, |
| 888 | 2x |
conditional.x = conditional.x, |
| 889 | 2x |
meanstructure = meanstructure, |
| 890 | 2x |
slopestructure = conditional.x, |
| 891 | 2x |
gamma.n.minus.one = |
| 892 | 2x |
lavoptions$gamma.n.minus.one, |
| 893 | 2x |
unbiased = |
| 894 | 2x |
lavoptions$gamma.unbiased, |
| 895 | 2x |
Mplus.WLS = lavoptions$gamma.wls.mplus |
| 896 |
) |
|
| 897 |
} |
|
| 898 |
} |
|
| 899 |
} else { # categorical case
|
|
| 900 | 2x |
NACOV[[g]] <- CAT$WLS.W * nobs[[g]] |
| 901 | 2x |
if (lavoptions$gamma.n.minus.one) {
|
| 902 | ! |
NACOV[[g]] <- NACOV[[g]] * (nobs[[g]] / (nobs[[g]] - 1L)) |
| 903 |
} |
|
| 904 | 2x |
if (estimator == "catML") {
|
| 905 |
# remove all but the correlation part |
|
| 906 | ! |
ntotal <- nrow(NACOV[[g]]) |
| 907 | ! |
pstar <- nrow(CAT$A22) |
| 908 | ! |
nocor <- ntotal - pstar |
| 909 | ! |
if (length(nocor) > 0L) {
|
| 910 | ! |
NACOV[[g]] <- NACOV[[g]][ |
| 911 | ! |
-seq_len(nocor), |
| 912 | ! |
-seq_len(nocor) |
| 913 |
] |
|
| 914 |
} |
|
| 915 |
} |
|
| 916 |
} |
|
| 917 | 29x |
} else if (estimator == "PML") {
|
| 918 |
# no NACOV ... for now |
|
| 919 |
} |
|
| 920 | ||
| 921 |
# group.w.free |
|
| 922 | 33x |
if (!is.null(NACOV[[g]]) && group.w.free) {
|
| 923 |
# unweight!! |
|
| 924 | ! |
a <- group.w[[g]] * sum(unlist(nobs)) / nobs[[g]] |
| 925 |
# always 1!!! |
|
| 926 | ! |
NACOV[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), NACOV[[g]]) |
| 927 |
} |
|
| 928 |
} |
|
| 929 | ||
| 930 |
# WLS.V |
|
| 931 | 37x |
if (!WLS.V.user && nlevels == 1L) {
|
| 932 | 33x |
if (estimator == "DLS" && dls.GammaNT == "sample" && dls.a < 1.0) {
|
| 933 |
# compute GammaNT here |
|
| 934 | ! |
if (correlation) {
|
| 935 | ! |
GammaNT <- lav_samplestats_cor_Gamma_NT( |
| 936 | ! |
COV = cov[[g]], |
| 937 | ! |
MEAN = mean[[g]], |
| 938 | ! |
rescale = FALSE, |
| 939 | ! |
x.idx = x.idx[[g]], # not used yet |
| 940 | ! |
fixed.x = fixed.x, # not used yet |
| 941 | ! |
conditional.x = conditional.x, # not used yet |
| 942 | ! |
meanstructure = meanstructure, # not used yet |
| 943 | ! |
slopestructure = conditional.x # not used yet |
| 944 |
) |
|
| 945 |
} else {
|
|
| 946 | ! |
GammaNT <- lav_samplestats_Gamma_NT( |
| 947 | ! |
COV = cov[[g]], |
| 948 | ! |
MEAN = mean[[g]], |
| 949 | ! |
rescale = FALSE, |
| 950 | ! |
x.idx = x.idx[[g]], |
| 951 | ! |
fixed.x = fixed.x, |
| 952 | ! |
conditional.x = conditional.x, |
| 953 | ! |
meanstructure = meanstructure, |
| 954 | ! |
slopestructure = conditional.x |
| 955 |
) |
|
| 956 |
} |
|
| 957 |
} |
|
| 958 | ||
| 959 | 33x |
if (estimator == "GLS" || |
| 960 | 33x |
(estimator == "DLS" && dls.GammaNT == "sample" && |
| 961 | 33x |
dls.a == 1.0)) {
|
| 962 |
# Note: we need the 'original' COV/MEAN/ICOV |
|
| 963 |
# sample statistics; not the 'residual' version |
|
| 964 | 6x |
if (correlation) {
|
| 965 | ! |
GammaNT <- lav_samplestats_cor_Gamma_NT( |
| 966 | ! |
COV = cov[[g]], |
| 967 | ! |
MEAN = mean[[g]], |
| 968 |
#rescale = FALSE, |
|
| 969 | ! |
x.idx = x.idx[[g]], # not used yet |
| 970 | ! |
fixed.x = fixed.x, # not used yet |
| 971 | ! |
conditional.x = conditional.x, # not used yet |
| 972 | ! |
meanstructure = meanstructure, # not used yet |
| 973 | ! |
slopestructure = conditional.x # not used yet |
| 974 |
) |
|
| 975 | ! |
WLS.V[[g]] <- lav_matrix_symmetric_inverse(GammaNT) |
| 976 |
} else {
|
|
| 977 | 6x |
WLS.V[[g]] <- lav_samplestats_Gamma_inverse_NT( |
| 978 | 6x |
ICOV = icov[[g]], |
| 979 | 6x |
COV = cov[[g]], |
| 980 | 6x |
MEAN = mean[[g]], |
| 981 | 6x |
rescale = FALSE, |
| 982 | 6x |
x.idx = x.idx[[g]], |
| 983 | 6x |
fixed.x = fixed.x, |
| 984 | 6x |
conditional.x = conditional.x, |
| 985 | 6x |
meanstructure = meanstructure, |
| 986 | 6x |
slopestructure = conditional.x |
| 987 |
) |
|
| 988 |
} |
|
| 989 | 6x |
if (lavoptions$gls.v11.mplus && !conditional.x && meanstructure) {
|
| 990 |
# bug in Mplus? V11 rescaled by nobs[[g]]/(nobs[[g]]-1) |
|
| 991 | ! |
nvar <- NCOL(cov[[g]]) |
| 992 | ! |
WLS.V[[g]][1:nvar, 1:nvar] <- |
| 993 | ! |
WLS.V[[g]][1:nvar, 1:nvar, |
| 994 | ! |
drop = FALSE |
| 995 | ! |
] * (nobs[[g]] / (nobs[[g]] - 1)) |
| 996 |
} |
|
| 997 | 27x |
} else if (estimator == "ML") {
|
| 998 |
# no WLS.V here, since function of model-implied moments |
|
| 999 | 4x |
} else if (estimator %in% c("WLS", "DWLS", "ULS", "DLS")) {
|
| 1000 | 4x |
if (!categorical) {
|
| 1001 | 2x |
if (estimator == "WLS" || estimator == "DLS") {
|
| 1002 | 2x |
if (!fixed.x) {
|
| 1003 | 2x |
if (estimator != "DLS") {
|
| 1004 |
# Gamma should be po before we invert |
|
| 1005 | 2x |
ev <- eigen(NACOV[[g]], # symmetric=FALSE, |
| 1006 | 2x |
only.values = TRUE |
| 1007 | 2x |
)$values |
| 1008 | 2x |
if (is.complex(ev)) {
|
| 1009 | ! |
lav_msg_stop(gettext( |
| 1010 | ! |
"Gamma (NACOV) matrix is not positive-definite")) |
| 1011 |
} |
|
| 1012 | 2x |
if (any(Re(ev) < 0)) {
|
| 1013 | ! |
lav_msg_stop(gettext( |
| 1014 | ! |
"Gamma (NACOV) matrix is not positive-definite")) |
| 1015 |
} |
|
| 1016 |
} |
|
| 1017 | 2x |
if (estimator == "DLS" && dls.GammaNT == "sample") {
|
| 1018 | ! |
if (dls.a == 1.0) {
|
| 1019 |
# nothing to do, use GLS version |
|
| 1020 |
} else {
|
|
| 1021 | ! |
W.DLS <- |
| 1022 | ! |
(1 - dls.a) * NACOV[[g]] + dls.a * GammaNT |
| 1023 | ! |
WLS.V[[g]] <- |
| 1024 | ! |
lav_matrix_symmetric_inverse(W.DLS) |
| 1025 |
} |
|
| 1026 |
} else { # WLS
|
|
| 1027 | 2x |
WLS.V[[g]] <- |
| 1028 | 2x |
lav_matrix_symmetric_inverse(NACOV[[g]]) |
| 1029 |
} |
|
| 1030 |
} else {
|
|
| 1031 |
# fixed.x: we have zero cols/rows |
|
| 1032 |
# ginv does the trick, but perhaps this is overkill |
|
| 1033 |
# just removing the zero rows/cols, invert, and |
|
| 1034 |
# fill back in the zero rows/cols would do it |
|
| 1035 |
# WLS.V[[g]] <- MASS::ginv(NACOV[[g]]) |
|
| 1036 | ! |
if (estimator == "DLS" && dls.GammaNT == "sample") {
|
| 1037 | ! |
W.DLS <- (1 - dls.a) * NACOV[[g]] + dls.a * GammaNT |
| 1038 | ! |
WLS.V[[g]] <- |
| 1039 | ! |
lav_matrix_symmetric_inverse(W.DLS) |
| 1040 |
} else { # WLS
|
|
| 1041 | ! |
WLS.V[[g]] <- |
| 1042 | ! |
lav_matrix_symmetric_inverse(NACOV[[g]]) |
| 1043 |
} |
|
| 1044 |
} |
|
| 1045 | ! |
} else if (estimator == "DWLS") {
|
| 1046 | ! |
dacov <- diag(NACOV[[g]]) |
| 1047 | ! |
if (!all(is.finite(dacov))) {
|
| 1048 | ! |
lav_msg_stop(gettext( |
| 1049 | ! |
"diagonal of Gamma (NACOV) contains non finite values")) |
| 1050 |
} |
|
| 1051 | ! |
if (fixed.x) {
|
| 1052 |
# structural zeroes! |
|
| 1053 | ! |
zero.idx <- which(dacov == 0.0) |
| 1054 | ! |
idacov <- 1 / dacov |
| 1055 | ! |
idacov[zero.idx] <- 0.0 |
| 1056 |
} else {
|
|
| 1057 | ! |
idacov <- 1 / dacov |
| 1058 |
} |
|
| 1059 | ! |
WLS.V[[g]] <- diag(idacov, |
| 1060 | ! |
nrow = NROW(NACOV[[g]]), |
| 1061 | ! |
ncol = NCOL(NACOV[[g]]) |
| 1062 |
) |
|
| 1063 | ! |
WLS.VD[[g]] <- idacov |
| 1064 | ! |
} else if (estimator == "ULS") {
|
| 1065 |
# WLS.V[[g]] <- diag(length(WLS.obs[[g]])) |
|
| 1066 | ! |
WLS.VD[[g]] <- rep(1, length(WLS.obs[[g]])) |
| 1067 |
} |
|
| 1068 |
} else {
|
|
| 1069 | 2x |
if (estimator == "WLS") {
|
| 1070 | ! |
cS <- tryCatch(chol(CAT$WLS.W * nobs[[g]]), |
| 1071 | ! |
error = function(e) NULL) |
| 1072 | ! |
if (is.null(cS)) {
|
| 1073 | ! |
lav_msg_stop(gettext("could not invert CAT$WLS.W"))
|
| 1074 |
} |
|
| 1075 | ! |
WLS.V[[g]] <- chol2inv(cS) |
| 1076 | 2x |
} else if (estimator == "DWLS") {
|
| 1077 | 2x |
dacov <- diag(CAT$WLS.W * nobs[[g]]) |
| 1078 |
# WLS.V[[g]] <- diag(1/dacov, nrow=NROW(CAT$WLS.W), |
|
| 1079 |
# ncol=NCOL(CAT$WLS.W)) |
|
| 1080 | 2x |
WLS.VD[[g]] <- 1 / dacov |
| 1081 | ! |
} else if (estimator == "ULS") {
|
| 1082 |
# WLS.V[[g]] <- diag(length(WLS.obs[[g]])) |
|
| 1083 | ! |
WLS.VD[[g]] <- rep(1, length(WLS.obs[[g]])) |
| 1084 |
} |
|
| 1085 |
} |
|
| 1086 | ! |
} else if (estimator == "PML" || estimator == "FML") {
|
| 1087 |
# no WLS.V here |
|
| 1088 |
} |
|
| 1089 | ||
| 1090 |
# group.w.free (only if categorical) |
|
| 1091 | 33x |
if (group.w.free && categorical) {
|
| 1092 | ! |
if (!is.null(WLS.V[[g]])) {
|
| 1093 |
# unweight!! |
|
| 1094 | ! |
a <- group.w[[g]] * sum(unlist(nobs)) / nobs[[g]] |
| 1095 |
# always 1!!! |
|
| 1096 |
# invert |
|
| 1097 | ! |
a <- 1 / a |
| 1098 | ! |
WLS.V[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), WLS.V[[g]]) |
| 1099 |
} |
|
| 1100 | ! |
if (!is.null(WLS.VD[[g]])) {
|
| 1101 |
# unweight!! |
|
| 1102 | ! |
a <- group.w[[g]] * sum(unlist(nobs)) / nobs[[g]] |
| 1103 |
# always 1!!! |
|
| 1104 |
# invert |
|
| 1105 | ! |
a <- 1 / a |
| 1106 | ! |
WLS.VD[[g]] <- c(a, WLS.VD[[g]]) |
| 1107 |
} |
|
| 1108 |
} |
|
| 1109 |
} |
|
| 1110 |
} # ngroups |
|
| 1111 | ||
| 1112 |
# remove 'CAT', unless debug -- this is to save memory |
|
| 1113 | 35x |
if (!lav_debug()) {
|
| 1114 | 35x |
CAT <- list() |
| 1115 |
} |
|
| 1116 | ||
| 1117 |
# construct SampleStats object |
|
| 1118 | 35x |
lavSampleStats <- new("lavSampleStats",
|
| 1119 |
# sample moments |
|
| 1120 | 35x |
th = th, |
| 1121 | 35x |
th.idx = th.idx, |
| 1122 | 35x |
th.names = th.names, |
| 1123 | 35x |
mean = mean, |
| 1124 | 35x |
cov = cov, |
| 1125 | 35x |
var = var, |
| 1126 | ||
| 1127 |
# residual (y | x) |
|
| 1128 | 35x |
res.cov = res.cov, |
| 1129 | 35x |
res.var = res.var, |
| 1130 | 35x |
res.th = res.th, |
| 1131 | 35x |
res.th.nox = res.th.nox, |
| 1132 | 35x |
res.slopes = res.slopes, |
| 1133 | 35x |
res.int = res.int, |
| 1134 | 35x |
mean.x = mean.x, |
| 1135 | 35x |
cov.x = cov.x, |
| 1136 | 35x |
bifreq = bifreq, |
| 1137 | 35x |
group.w = group.w, |
| 1138 | ||
| 1139 |
# convenience |
|
| 1140 | 35x |
nobs = nobs, |
| 1141 | 35x |
ntotal = sum(unlist(nobs)), |
| 1142 | 35x |
ngroups = ngroups, |
| 1143 | 35x |
x.idx = x.idx, |
| 1144 | ||
| 1145 |
# extra sample statistics |
|
| 1146 | 35x |
icov = icov, |
| 1147 | 35x |
cov.log.det = cov.log.det, |
| 1148 | 35x |
res.icov = res.icov, |
| 1149 | 35x |
res.cov.log.det = res.cov.log.det, |
| 1150 | 35x |
ridge = ridge.eps, |
| 1151 | 35x |
WLS.obs = WLS.obs, |
| 1152 | 35x |
WLS.V = WLS.V, |
| 1153 | 35x |
WLS.VD = WLS.VD, |
| 1154 | 35x |
NACOV = NACOV, |
| 1155 | 35x |
NACOV.user = NACOV.user, |
| 1156 | ||
| 1157 |
# cluster/levels |
|
| 1158 | 35x |
YLp = YLp, |
| 1159 | ||
| 1160 |
# missingness |
|
| 1161 | 35x |
missing.flag = missing.flag., |
| 1162 | 35x |
missing = missing., |
| 1163 | 35x |
missing.h1 = missing.h1., |
| 1164 | 35x |
zero.cell.tables = zero.cell.tables |
| 1165 |
) |
|
| 1166 | ||
| 1167 |
# just a SINGLE warning if we have empty cells |
|
| 1168 | 35x |
if ((!is.null(lavoptions$samplestats) && lavoptions$samplestats) && |
| 1169 | 35x |
categorical && zero.cell.warn && |
| 1170 | 35x |
any(sapply(zero.cell.tables, nrow) > 0L)) {
|
| 1171 | ! |
nempty <- sum(sapply(zero.cell.tables, nrow)) |
| 1172 | ! |
lav_msg_warn(gettextf( |
| 1173 | ! |
"%s bivariate tables have empty cells; to see them, use: |
| 1174 | ! |
lavInspect(fit, \"zero.cell.tables\")", nempty) |
| 1175 |
) |
|
| 1176 |
} |
|
| 1177 | ||
| 1178 | 35x |
lavSampleStats |
| 1179 |
} |
|
| 1180 | ||
| 1181 | ||
| 1182 |
lav_samplestats_from_moments <- function(sample.cov = NULL, |
|
| 1183 |
sample.mean = NULL, |
|
| 1184 |
sample.th = NULL, |
|
| 1185 |
sample.nobs = NULL, |
|
| 1186 |
ov.names = NULL, # including x |
|
| 1187 |
ov.names.x = NULL, |
|
| 1188 |
WLS.V = NULL, |
|
| 1189 |
NACOV = NULL, |
|
| 1190 |
lavoptions = NULL) {
|
|
| 1191 |
# extract options |
|
| 1192 | 42x |
estimator <- lavoptions$estimator |
| 1193 | 42x |
mimic <- lavoptions$mimic |
| 1194 | 42x |
meanstructure <- lavoptions$meanstructure |
| 1195 | 42x |
correlation <- lavoptions$correlation |
| 1196 | 42x |
group.w.free <- lavoptions$group.w.free |
| 1197 | 42x |
ridge <- lavoptions$ridge |
| 1198 | 42x |
rescale <- lavoptions$sample.cov.rescale |
| 1199 | ||
| 1200 |
# no multilevel yet |
|
| 1201 | 42x |
nlevels <- 1L |
| 1202 | ||
| 1203 |
# ridge default |
|
| 1204 | 42x |
if (ridge) {
|
| 1205 | ! |
if (is.numeric(lavoptions$ridge.constant)) {
|
| 1206 | ! |
ridge.eps <- lavoptions$ridge.constant |
| 1207 |
} else {
|
|
| 1208 | ! |
ridge.eps <- 1e-5 |
| 1209 |
} |
|
| 1210 |
} else {
|
|
| 1211 | 42x |
ridge.eps <- 0.0 |
| 1212 |
} |
|
| 1213 | ||
| 1214 |
# new in 0.6-3: |
|
| 1215 |
# check if sample.cov has attributes if conditional.x = TRUE |
|
| 1216 | 42x |
sample.res.slopes <- attr(sample.cov, "res.slopes") |
| 1217 | 42x |
sample.cov.x <- attr(sample.cov, "cov.x") |
| 1218 | 42x |
sample.mean.x <- attr(sample.cov, "mean.x") |
| 1219 | 42x |
if (!is.null(sample.res.slopes)) {
|
| 1220 | ! |
conditional.x <- TRUE |
| 1221 |
# strip attributes |
|
| 1222 | ! |
attr(sample.cov, "res.slopes") <- NULL |
| 1223 | ! |
attr(sample.cov, "cov.x") <- NULL |
| 1224 | ! |
attr(sample.cov, "mean.x") <- NULL |
| 1225 |
# make list |
|
| 1226 | ! |
if (!is.list(sample.res.slopes)) {
|
| 1227 | ! |
sample.res.slopes <- list(sample.res.slopes) |
| 1228 |
} |
|
| 1229 | ! |
if (!is.list(sample.cov.x)) {
|
| 1230 | ! |
sample.cov.x <- list(sample.cov.x) |
| 1231 |
} |
|
| 1232 | ! |
if (!is.list(sample.mean.x)) {
|
| 1233 | ! |
sample.mean.x <- list(sample.mean.x) |
| 1234 |
} |
|
| 1235 | 42x |
} else if (!is.null(sample.cov.x)) {
|
| 1236 | ! |
conditional.x <- FALSE |
| 1237 | ! |
fixed.x <- TRUE |
| 1238 | ||
| 1239 |
# strip attributes |
|
| 1240 | ! |
attr(sample.cov, "cov.x") <- NULL |
| 1241 | ! |
attr(sample.cov, "mean.x") <- NULL |
| 1242 |
# make list |
|
| 1243 | ! |
if (!is.list(sample.cov.x)) {
|
| 1244 | ! |
sample.cov.x <- list(sample.cov.x) |
| 1245 |
} |
|
| 1246 | ! |
if (!is.list(sample.mean.x)) {
|
| 1247 | ! |
sample.mean.x <- list(sample.mean.x) |
| 1248 |
} |
|
| 1249 | 42x |
} else if (is.null(sample.cov.x) && length(unlist(ov.names.x)) > 0L) {
|
| 1250 |
# fixed.x = TRUE, but only joint sample.cov is provided |
|
| 1251 | 26x |
conditional.x <- FALSE |
| 1252 | 26x |
fixed.x <- TRUE |
| 1253 | ||
| 1254 |
# create sample.cov.x and sample.mean.x later... |
|
| 1255 |
} else {
|
|
| 1256 | 16x |
conditional.x <- FALSE |
| 1257 | 16x |
fixed.x <- FALSE |
| 1258 |
} |
|
| 1259 | ||
| 1260 |
# matrix -> list |
|
| 1261 | 42x |
if (!is.list(sample.cov)) {
|
| 1262 | 8x |
sample.cov <- list(sample.cov) |
| 1263 |
} |
|
| 1264 | ||
| 1265 |
# number of groups |
|
| 1266 | 42x |
ngroups <- length(sample.cov) |
| 1267 | ||
| 1268 |
# ov.names |
|
| 1269 | 42x |
if (!is.list(ov.names)) {
|
| 1270 | 42x |
ov.names <- rep(list(ov.names), ngroups) |
| 1271 |
} |
|
| 1272 | 42x |
if (!is.list(ov.names.x)) {
|
| 1273 | 42x |
ov.names.x <- rep(list(ov.names.x), ngroups) |
| 1274 |
} |
|
| 1275 | ||
| 1276 | 42x |
if (!is.null(sample.mean)) {
|
| 1277 | 36x |
meanstructure <- TRUE |
| 1278 | 36x |
if (!is.list(sample.mean)) {
|
| 1279 |
# check if sample.mean is string (between single quotes) |
|
| 1280 | 2x |
if (is.character(sample.mean)) {
|
| 1281 | ! |
sample.mean <- lav_char2num(sample.mean) |
| 1282 |
} |
|
| 1283 | 2x |
sample.mean <- list(unname(sample.mean)) |
| 1284 |
} else {
|
|
| 1285 | 34x |
sample.mean <- lapply(lapply(sample.mean, unname), unclass) |
| 1286 |
} |
|
| 1287 |
} |
|
| 1288 | ||
| 1289 | 42x |
if (!is.null(sample.th)) {
|
| 1290 | ! |
th.idx <- attr(sample.th, "th.idx") |
| 1291 | ! |
attr(sample.th, "th.idx") <- NULL |
| 1292 | ! |
if (is.null(th.idx)) {
|
| 1293 | ! |
lav_msg_stop(gettext("sample.th should have a th.idx attribute"))
|
| 1294 |
} else {
|
|
| 1295 | ! |
if (is.list(th.idx)) {
|
| 1296 | ! |
th.names <- lapply(th.idx, names) |
| 1297 | ! |
th.idx <- lapply(lapply(th.idx, unname), unclass) |
| 1298 |
} else {
|
|
| 1299 | ! |
th.names <- list(names(th.idx)) |
| 1300 | ! |
th.idx <- list(unclass(unname(th.idx))) |
| 1301 |
} |
|
| 1302 |
} |
|
| 1303 | ! |
if (is.list(sample.th)) {
|
| 1304 |
# strip names and lavaan.vector class |
|
| 1305 | ! |
sample.th <- lapply(lapply(sample.th, unname), unclass) |
| 1306 |
} else {
|
|
| 1307 |
# strip names and lavaan.vector class, make list |
|
| 1308 | ! |
sample.th <- list(unclass(unname(sample.th))) |
| 1309 |
} |
|
| 1310 |
} else {
|
|
| 1311 | 42x |
th.idx <- vector("list", length = ngroups)
|
| 1312 | 42x |
th.names <- vector("list", length = ngroups)
|
| 1313 |
} |
|
| 1314 | ||
| 1315 |
# sample statistics per group |
|
| 1316 | 42x |
cov <- vector("list", length = ngroups)
|
| 1317 | 42x |
var <- vector("list", length = ngroups)
|
| 1318 | 42x |
mean <- vector("list", length = ngroups)
|
| 1319 | 42x |
th <- vector("list", length = ngroups)
|
| 1320 |
# th.idx <- vector("list", length = ngroups)
|
|
| 1321 |
# th.names <- vector("list", length = ngroups)
|
|
| 1322 | ||
| 1323 |
# residual (y | x) |
|
| 1324 | 42x |
res.cov <- vector("list", length = ngroups)
|
| 1325 | 42x |
res.var <- vector("list", length = ngroups)
|
| 1326 | 42x |
res.slopes <- vector("list", length = ngroups)
|
| 1327 | 42x |
res.int <- vector("list", length = ngroups)
|
| 1328 | 42x |
res.th <- vector("list", length = ngroups)
|
| 1329 | 42x |
res.th.nox <- vector("list", length = ngroups)
|
| 1330 | ||
| 1331 |
# fixed.x / conditional.x |
|
| 1332 | 42x |
mean.x <- vector("list", length = ngroups)
|
| 1333 | 42x |
cov.x <- vector("list", length = ngroups)
|
| 1334 | ||
| 1335 | 42x |
bifreq <- vector("list", length = ngroups)
|
| 1336 | ||
| 1337 |
# extra sample statistics per group |
|
| 1338 | 42x |
icov <- vector("list", length = ngroups)
|
| 1339 | 42x |
cov.log.det <- vector("list", length = ngroups)
|
| 1340 | 42x |
res.icov <- vector("list", length = ngroups)
|
| 1341 | 42x |
res.cov.log.det <- vector("list", length = ngroups)
|
| 1342 | 42x |
WLS.obs <- vector("list", length = ngroups)
|
| 1343 | 42x |
missing. <- vector("list", length = ngroups)
|
| 1344 | 42x |
missing.h1. <- vector("list", length = ngroups)
|
| 1345 | 42x |
missing.flag. <- FALSE |
| 1346 | 42x |
zero.cell.tables <- vector("list", length = ngroups)
|
| 1347 | 42x |
YLp <- vector("list", length = ngroups)
|
| 1348 | ||
| 1349 |
# group weights |
|
| 1350 | 42x |
group.w <- vector("list", length = ngroups)
|
| 1351 | 42x |
x.idx <- vector("list", length = ngroups)
|
| 1352 | ||
| 1353 | 42x |
categorical <- FALSE |
| 1354 | 42x |
if (!is.null(sample.th)) {
|
| 1355 | ! |
categorical <- TRUE |
| 1356 |
} |
|
| 1357 | ||
| 1358 | 42x |
WLS.VD <- vector("list", length = ngroups)
|
| 1359 | 42x |
if (is.null(WLS.V)) {
|
| 1360 | 42x |
WLS.V <- vector("list", length = ngroups)
|
| 1361 | 42x |
WLS.V.user <- FALSE |
| 1362 |
} else {
|
|
| 1363 | ! |
if (!is.list(WLS.V)) {
|
| 1364 | ! |
if (ngroups == 1L) {
|
| 1365 | ! |
WLS.V <- list(unclass(WLS.V)) |
| 1366 |
} else {
|
|
| 1367 | ! |
lav_msg_stop(gettextf("WLS.V argument should be a list of length %s",
|
| 1368 | ! |
ngroups) |
| 1369 |
) |
|
| 1370 |
} |
|
| 1371 |
} else {
|
|
| 1372 | ! |
if (length(WLS.V) != ngroups) {
|
| 1373 | ! |
lav_msg_stop(gettextf( |
| 1374 | ! |
"WLS.V assumes %1$s groups; data contains %2$s groups", |
| 1375 | ! |
length(WLS.V), ngroups)) |
| 1376 |
} |
|
| 1377 | ! |
WLS.V <- lapply(WLS.V, unclass) |
| 1378 |
} |
|
| 1379 | ||
| 1380 |
# is WLS.V full? check first |
|
| 1381 | ! |
if (is.null(dim(WLS.V[[1]]))) {
|
| 1382 |
# we will assume it is the diagonal only |
|
| 1383 | ! |
WLS.VD <- WLS.V |
| 1384 | ! |
WLS.V <- lapply(WLS.VD, diag) |
| 1385 |
} else {
|
|
| 1386 |
# create WLS.VD |
|
| 1387 | ! |
WLS.VD <- lapply(WLS.V, diag) |
| 1388 |
# we could remove WLS.V to save space... |
|
| 1389 |
} |
|
| 1390 | ||
| 1391 | ! |
WLS.V.user <- TRUE |
| 1392 |
# FIXME: check dimension of WLS.V!! |
|
| 1393 |
} |
|
| 1394 | ||
| 1395 | 42x |
if (is.null(NACOV)) {
|
| 1396 | 42x |
NACOV <- vector("list", length = ngroups)
|
| 1397 | 42x |
NACOV.user <- FALSE |
| 1398 |
} else {
|
|
| 1399 | ! |
if (!is.list(NACOV)) {
|
| 1400 | ! |
if (ngroups == 1L) {
|
| 1401 | ! |
NACOV <- list(unclass(NACOV)) |
| 1402 |
} else {
|
|
| 1403 | ! |
lav_msg_stop(gettextf( |
| 1404 | ! |
"NACOV argument should be a list of length %s", ngroups)) |
| 1405 |
} |
|
| 1406 |
} else {
|
|
| 1407 | ! |
if (length(NACOV) != ngroups) {
|
| 1408 | ! |
lav_msg_stop(gettextf( |
| 1409 | ! |
"NACOV assumes %1$s groups; data contains %2$s groups", |
| 1410 | ! |
length(NACOV), ngroups)) |
| 1411 |
} |
|
| 1412 | ! |
NACOV <- lapply(NACOV, unclass) |
| 1413 |
} |
|
| 1414 | ! |
NACOV.user <- TRUE |
| 1415 |
# FIXME: check dimension of NACOV!! |
|
| 1416 |
} |
|
| 1417 | ||
| 1418 | 42x |
nobs <- as.list(as.integer(sample.nobs)) |
| 1419 | ||
| 1420 | ||
| 1421 | 42x |
for (g in 1:ngroups) {
|
| 1422 |
# exogenous x? |
|
| 1423 | 44x |
nexo <- length(ov.names.x[[g]]) |
| 1424 | 44x |
if (nexo) {
|
| 1425 |
# two cases: ov.names contains 'x' variables, or not |
|
| 1426 | 26x |
if (conditional.x) {
|
| 1427 |
# ov.names.x are NOT in ov.names |
|
| 1428 | ! |
x.idx[[g]] <- which(ov.names[[g]] %in% ov.names.x[[g]]) |
| 1429 |
} else {
|
|
| 1430 | 26x |
if (fixed.x) {
|
| 1431 |
# ov.names.x are a subset of ov.names |
|
| 1432 | 26x |
x.idx[[g]] <- match(ov.names.x[[g]], ov.names[[g]]) |
| 1433 | 26x |
stopifnot(!anyNA(x.idx[[g]])) |
| 1434 |
} else {
|
|
| 1435 | ! |
x.idx[[g]] <- integer(0L) |
| 1436 |
} |
|
| 1437 |
} |
|
| 1438 |
} else {
|
|
| 1439 | 18x |
x.idx[[g]] <- integer(0L) |
| 1440 | 18x |
conditional.x <- FALSE |
| 1441 | 18x |
fixed.x <- FALSE |
| 1442 |
} |
|
| 1443 | ||
| 1444 | ||
| 1445 |
# group weight |
|
| 1446 | 44x |
group.w[[g]] <- nobs[[g]] / sum(unlist(nobs)) |
| 1447 | ||
| 1448 | 44x |
tmp.cov <- sample.cov[[g]] |
| 1449 | ||
| 1450 |
# make sure that the matrix is fully symmetric (NEEDED?) |
|
| 1451 | 44x |
T <- t(tmp.cov) |
| 1452 | 44x |
tmp.cov[upper.tri(tmp.cov)] <- T[upper.tri(T)] |
| 1453 | ||
| 1454 |
# check dimnames |
|
| 1455 | 44x |
if (!is.null(rownames(tmp.cov))) {
|
| 1456 | 44x |
cov.names <- rownames(tmp.cov) |
| 1457 | ! |
} else if (!is.null(colnames(tmp.cov))) {
|
| 1458 | ! |
cov.names <- colnames(tmp.cov) |
| 1459 |
} else {
|
|
| 1460 | ! |
lav_msg_stop(gettext( |
| 1461 | ! |
"please provide row/col names for the covariance matrix!")) |
| 1462 |
} |
|
| 1463 | ||
| 1464 |
# extract only the part we need (using ov.names) |
|
| 1465 | 44x |
if (conditional.x) {
|
| 1466 | ! |
idx <- match(ov.names[[g]][-x.idx[[g]]], cov.names) |
| 1467 |
} else {
|
|
| 1468 | 44x |
idx <- match(ov.names[[g]], cov.names) |
| 1469 |
} |
|
| 1470 | 44x |
if (any(is.na(idx))) {
|
| 1471 | ! |
cat("found: ", cov.names, "\n")
|
| 1472 | ! |
cat("expected: ", ov.names[[g]], "\n")
|
| 1473 | ! |
lav_msg_stop(gettextf( |
| 1474 | ! |
"rownames of covariance matrix do not match the model! |
| 1475 | ! |
found: %1$s expected: %2$s", lav_msg_view(cov.names), |
| 1476 | ! |
lav_msg_view(ov.names[[g]]))) |
| 1477 |
} else {
|
|
| 1478 | 44x |
tmp.cov <- tmp.cov[idx, idx, drop = FALSE] |
| 1479 |
} |
|
| 1480 | ||
| 1481 |
# strip dimnames |
|
| 1482 | 44x |
dimnames(tmp.cov) <- NULL |
| 1483 | ||
| 1484 | 44x |
if (is.null(sample.mean)) {
|
| 1485 |
# assume zero mean vector |
|
| 1486 | 6x |
tmp.mean <- numeric(ncol(tmp.cov)) |
| 1487 |
} else {
|
|
| 1488 |
# extract only the part we need |
|
| 1489 | 38x |
tmp.mean <- unclass(sample.mean[[g]][idx]) |
| 1490 |
} |
|
| 1491 | ||
| 1492 | ||
| 1493 | ||
| 1494 | 44x |
if (categorical) {
|
| 1495 |
# categorical + conditional.x = TRUE |
|
| 1496 | ! |
if (conditional.x) {
|
| 1497 | ! |
th.g <- numeric(length(th.idx[[g]])) |
| 1498 | ! |
ord.idx <- which(th.idx[[g]] > 0) |
| 1499 | ! |
num.idx <- which(th.idx[[g]] == 0) |
| 1500 | ! |
if (length(ord.idx) > 0L) {
|
| 1501 | ! |
th.g[ord.idx] <- sample.th[[g]][ord.idx] |
| 1502 |
} |
|
| 1503 | ! |
if (length(num.idx) > 0L) {
|
| 1504 | ! |
ord.var.idx <- unique(th.idx[[g]][th.idx[[g]] > 0]) |
| 1505 | ! |
th.g[num.idx] <- -1 * sample.mean[[g]][-ord.var.idx] |
| 1506 |
} |
|
| 1507 | ! |
res.th[[g]] <- th.g |
| 1508 | ! |
res.th.nox[[g]] <- sample.th[[g]] |
| 1509 | ||
| 1510 | ! |
res.cov[[g]] <- tmp.cov |
| 1511 | ! |
if (ridge) {
|
| 1512 | ! |
diag(res.cov[[g]]) <- diag(res.cov[[g]]) + ridge.eps |
| 1513 |
} |
|
| 1514 | ! |
res.var[[g]] <- diag(tmp.cov) |
| 1515 | ! |
res.int[[g]] <- tmp.mean |
| 1516 | ||
| 1517 | ! |
res.slopes[[g]] <- unclass(unname(sample.res.slopes[[g]])) |
| 1518 | ! |
cov.x[[g]] <- unclass(unname(sample.cov.x[[g]])) |
| 1519 | ! |
mean.x[[g]] <- unclass(unname(sample.mean.x[[g]])) |
| 1520 | ||
| 1521 |
# th.idx and th.names are already ok |
|
| 1522 | ||
| 1523 |
# categorical + conditional.x = FALSE |
|
| 1524 |
} else {
|
|
| 1525 | ! |
th.g <- numeric(length(th.idx[[g]])) |
| 1526 | ! |
ord.idx <- which(th.idx[[g]] > 0) |
| 1527 | ! |
num.idx <- which(th.idx[[g]] == 0) |
| 1528 | ! |
if (length(ord.idx) > 0L) {
|
| 1529 | ! |
th.g[ord.idx] <- sample.th[[g]][ord.idx] |
| 1530 |
} |
|
| 1531 | ! |
if (length(num.idx) > 0L) {
|
| 1532 | ! |
ord.var.idx <- unique(th.idx[[g]][th.idx[[g]] > 0]) |
| 1533 | ! |
th.g[num.idx] <- -1 * sample.mean[[g]][-ord.var.idx] |
| 1534 |
} |
|
| 1535 | ! |
th[[g]] <- th.g |
| 1536 | ||
| 1537 | ! |
cov[[g]] <- tmp.cov |
| 1538 | ! |
if (ridge) {
|
| 1539 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 1540 |
} |
|
| 1541 | ! |
var[[g]] <- diag(tmp.cov) |
| 1542 | ! |
mean[[g]] <- tmp.mean |
| 1543 | ||
| 1544 |
# fixed.x? (needed?) |
|
| 1545 | ! |
if (fixed.x) {
|
| 1546 | ! |
cov.x[[g]] <- unclass(unname(sample.cov.x[[g]])) |
| 1547 | ! |
mean.x[[g]] <- unclass(unname(sample.mean.x[[g]])) |
| 1548 |
} |
|
| 1549 | ||
| 1550 |
# th, th.idx and th.names are already ok |
|
| 1551 |
} |
|
| 1552 | ||
| 1553 |
# multilevel |
|
| 1554 | 44x |
} else if (nlevels > 1L) {
|
| 1555 | ! |
lav_msg_stop(gettext("multilevel + sample stats not ready yet"))
|
| 1556 | ||
| 1557 | ||
| 1558 |
# single level |
|
| 1559 |
} else {
|
|
| 1560 |
# single-level + continuous + conditional.x = TRUE |
|
| 1561 | 44x |
if (conditional.x) {
|
| 1562 | ! |
res.cov[[g]] <- tmp.cov |
| 1563 | ! |
if (ridge) {
|
| 1564 | ! |
diag(res.cov[[g]]) <- diag(res.cov[[g]]) + ridge.eps |
| 1565 |
} |
|
| 1566 | ! |
res.var[[g]] <- diag(tmp.cov) |
| 1567 | ! |
res.int[[g]] <- tmp.mean |
| 1568 | ! |
res.slopes[[g]] <- unclass(unname(sample.res.slopes[[g]])) |
| 1569 | ! |
cov.x[[g]] <- unclass(unname(sample.cov.x[[g]])) |
| 1570 | ! |
mean.x[[g]] <- unclass(unname(sample.mean.x[[g]])) |
| 1571 | ||
| 1572 |
# no rescale! |
|
| 1573 | ||
| 1574 |
# icov and cov.log.det |
|
| 1575 |
# if(lavoptions$sample.icov) {
|
|
| 1576 | ! |
out <- lav_samplestats_icov( |
| 1577 | ! |
COV = res.cov[[g]], |
| 1578 | ! |
ridge = 1e-05, |
| 1579 | ! |
x.idx = x.idx[[g]], |
| 1580 | ! |
ngroups = ngroups, g = g |
| 1581 |
) |
|
| 1582 | ! |
res.icov[[g]] <- out$icov |
| 1583 | ! |
res.cov.log.det[[g]] <- out$cov.log.det |
| 1584 |
# } |
|
| 1585 | ||
| 1586 |
# continuous + conditional.x = FALSE |
|
| 1587 |
} else {
|
|
| 1588 | 44x |
cov[[g]] <- tmp.cov |
| 1589 | 44x |
mean[[g]] <- tmp.mean |
| 1590 | ||
| 1591 |
# rescale cov by (N-1)/N? |
|
| 1592 | 44x |
if (rescale) {
|
| 1593 |
# we 'transform' the sample cov (divided by n-1) |
|
| 1594 |
# to a sample cov divided by 'n' |
|
| 1595 | 8x |
cov[[g]] <- ((nobs[[g]] - 1) / nobs[[g]]) * cov[[g]] |
| 1596 |
} |
|
| 1597 | 44x |
if (ridge) {
|
| 1598 | ! |
diag(cov[[g]]) <- diag(cov[[g]]) + ridge.eps |
| 1599 |
} |
|
| 1600 | 44x |
var[[g]] <- diag(cov[[g]]) |
| 1601 | ||
| 1602 |
# icov and cov.log.det |
|
| 1603 |
# if(lavoptions$sample.icov) {
|
|
| 1604 | 44x |
out <- lav_samplestats_icov( |
| 1605 | 44x |
COV = cov[[g]], |
| 1606 | 44x |
ridge = 1e-05, |
| 1607 | 44x |
x.idx = x.idx[[g]], |
| 1608 | 44x |
ngroups = ngroups, |
| 1609 | 44x |
g = g |
| 1610 |
) |
|
| 1611 | 44x |
icov[[g]] <- out$icov |
| 1612 | 44x |
cov.log.det[[g]] <- out$cov.log.det |
| 1613 |
# } |
|
| 1614 | ||
| 1615 |
# fixed.x? |
|
| 1616 | 44x |
if (fixed.x) {
|
| 1617 | 26x |
if (is.null(sample.cov.x)) {
|
| 1618 | 26x |
cov.x[[g]] <- cov[[g]][x.idx[[g]], x.idx[[g]], |
| 1619 | 26x |
drop = FALSE |
| 1620 |
] |
|
| 1621 |
} else {
|
|
| 1622 | ! |
cov.x[[g]] <- unclass(unname(sample.cov.x[[g]])) |
| 1623 |
} |
|
| 1624 | 26x |
if (is.null(sample.mean.x)) {
|
| 1625 | 26x |
mean.x[[g]] <- mean[[g]][x.idx[[g]]] |
| 1626 |
} else {
|
|
| 1627 | ! |
mean.x[[g]] <- unclass(unname(sample.mean.x[[g]])) |
| 1628 |
} |
|
| 1629 |
} |
|
| 1630 |
} |
|
| 1631 | ||
| 1632 |
# correlation structure? |
|
| 1633 | 44x |
if (correlation) {
|
| 1634 | ! |
cov[[g]] <- cov2cor(cov[[g]]) |
| 1635 | ! |
var[[g]] <- rep(1, length(var[[g]])) |
| 1636 | ! |
if (conditional.x) {
|
| 1637 | ! |
res.cov[[g]] <- cov2cor(res.cov[[g]]) |
| 1638 | ! |
res.var[[g]] <- rep(1, length(res.var[[g]])) |
| 1639 | ! |
cov.x[[g]] <- cov2cor(cov.x[[g]]) |
| 1640 |
# FIXME: slopes? more? |
|
| 1641 |
} |
|
| 1642 |
} |
|
| 1643 |
} |
|
| 1644 | ||
| 1645 |
# WLS.obs |
|
| 1646 | 44x |
WLS.obs[[g]] <- lav_samplestats_wls_obs( |
| 1647 | 44x |
mean.g = mean[[g]], |
| 1648 | 44x |
cov.g = cov[[g]], var.g = var[[g]], th.g = th[[g]], |
| 1649 | 44x |
th.idx.g = th.idx[[g]], res.int.g = res.int[[g]], |
| 1650 | 44x |
res.cov.g = res.cov[[g]], res.var.g = res.var[[g]], |
| 1651 | 44x |
res.th.g = res.th[[g]], res.slopes.g = res.slopes[[g]], |
| 1652 | 44x |
group.w.g = log(nobs[[g]]), |
| 1653 | 44x |
categorical = categorical, conditional.x = conditional.x, |
| 1654 | 44x |
meanstructure = meanstructure, correlation = correlation, |
| 1655 | 44x |
slopestructure = conditional.x, |
| 1656 | 44x |
group.w.free = group.w.free |
| 1657 |
) |
|
| 1658 | ||
| 1659 |
# WLS.V |
|
| 1660 | 44x |
if (!WLS.V.user) {
|
| 1661 | 44x |
if (estimator == "GLS") {
|
| 1662 |
# FIXME: in <0.5-21, we had |
|
| 1663 |
# V11 <- icov[[g]] |
|
| 1664 |
# if(mimic == "Mplus") { # is this a bug in Mplus?
|
|
| 1665 |
# V11 <- V11 * nobs[[g]]/(nobs[[g]]-1) |
|
| 1666 |
# } |
|
| 1667 | ! |
if (correlation) {
|
| 1668 | ! |
GammaNT <- lav_samplestats_cor_Gamma_NT( |
| 1669 | ! |
COV = cov[[g]], |
| 1670 | ! |
MEAN = mean[[g]], |
| 1671 |
#rescale = FALSE, |
|
| 1672 | ! |
x.idx = x.idx[[g]], # not used yet |
| 1673 | ! |
fixed.x = fixed.x, # not used yet |
| 1674 | ! |
conditional.x = conditional.x, # not used yet |
| 1675 | ! |
meanstructure = meanstructure, # not used yet |
| 1676 | ! |
slopestructure = conditional.x # not used yet |
| 1677 |
) |
|
| 1678 | ! |
WLS.V[[g]] <- lav_matrix_symmetric_inverse(GammaNT) |
| 1679 |
} else {
|
|
| 1680 | ! |
WLS.V[[g]] <- lav_samplestats_Gamma_inverse_NT( |
| 1681 | ! |
ICOV = icov[[g]], |
| 1682 | ! |
COV = cov[[g]], |
| 1683 | ! |
MEAN = mean[[g]], |
| 1684 | ! |
rescale = FALSE, |
| 1685 | ! |
x.idx = x.idx[[g]], |
| 1686 | ! |
fixed.x = fixed.x, |
| 1687 | ! |
conditional.x = conditional.x, |
| 1688 | ! |
meanstructure = meanstructure, |
| 1689 | ! |
slopestructure = conditional.x |
| 1690 |
) |
|
| 1691 |
} |
|
| 1692 | 44x |
} else if (estimator == "ULS") {
|
| 1693 | ! |
WLS.V[[g]] <- diag(length(WLS.obs[[g]])) |
| 1694 | ! |
WLS.VD[[g]] <- rep(1, length(WLS.obs[[g]])) |
| 1695 | 44x |
} else if (estimator == "WLS" || estimator == "DWLS") {
|
| 1696 | ! |
if (is.null(WLS.V[[g]])) {
|
| 1697 | ! |
lav_msg_stop(gettext( |
| 1698 | ! |
"the (D)WLS estimator is only available with full data |
| 1699 | ! |
or with a user-provided WLS.V")) |
| 1700 |
} |
|
| 1701 |
} |
|
| 1702 | ||
| 1703 |
# group.w.free |
|
| 1704 | 44x |
if (!is.null(WLS.V[[g]]) && group.w.free) {
|
| 1705 |
# FIXME!!! |
|
| 1706 | ! |
WLS.V[[g]] <- lav_matrix_bdiag(matrix(1, 1, 1), WLS.V[[g]]) |
| 1707 |
} |
|
| 1708 |
} |
|
| 1709 |
} # ngroups |
|
| 1710 | ||
| 1711 |
# construct SampleStats object |
|
| 1712 | 42x |
lavSampleStats <- new("lavSampleStats",
|
| 1713 |
# sample moments |
|
| 1714 | 42x |
th = th, |
| 1715 | 42x |
th.idx = th.idx, |
| 1716 | 42x |
th.names = th.names, |
| 1717 | 42x |
mean = mean, |
| 1718 | 42x |
cov = cov, |
| 1719 | 42x |
var = var, |
| 1720 | ||
| 1721 |
# residual (y | x) |
|
| 1722 | 42x |
res.cov = res.cov, |
| 1723 | 42x |
res.var = res.var, |
| 1724 | 42x |
res.th = res.th, |
| 1725 | 42x |
res.th.nox = res.th.nox, |
| 1726 | 42x |
res.slopes = res.slopes, |
| 1727 | 42x |
res.int = res.int, |
| 1728 | ||
| 1729 |
# fixed.x |
|
| 1730 | 42x |
mean.x = mean.x, |
| 1731 | 42x |
cov.x = cov.x, |
| 1732 | ||
| 1733 |
# other |
|
| 1734 | 42x |
bifreq = bifreq, |
| 1735 | 42x |
group.w = group.w, |
| 1736 | ||
| 1737 |
# convenience |
|
| 1738 | 42x |
nobs = nobs, |
| 1739 | 42x |
ntotal = sum(unlist(nobs)), |
| 1740 | 42x |
ngroups = ngroups, |
| 1741 | 42x |
x.idx = x.idx, |
| 1742 | ||
| 1743 |
# extra sample statistics |
|
| 1744 | 42x |
icov = icov, |
| 1745 | 42x |
cov.log.det = cov.log.det, |
| 1746 | 42x |
res.icov = res.icov, |
| 1747 | 42x |
res.cov.log.det = res.cov.log.det, |
| 1748 | 42x |
ridge = ridge.eps, |
| 1749 | 42x |
WLS.obs = WLS.obs, |
| 1750 | 42x |
WLS.V = WLS.V, |
| 1751 | 42x |
WLS.VD = WLS.VD, |
| 1752 | 42x |
NACOV = NACOV, |
| 1753 | 42x |
NACOV.user = NACOV.user, |
| 1754 | ||
| 1755 |
# cluster/level |
|
| 1756 | 42x |
YLp = YLp, |
| 1757 | ||
| 1758 |
# missingness |
|
| 1759 | 42x |
missing.flag = missing.flag., |
| 1760 | 42x |
missing = missing., |
| 1761 | 42x |
missing.h1 = missing.h1., |
| 1762 | 42x |
zero.cell.tables = zero.cell.tables |
| 1763 |
) |
|
| 1764 | ||
| 1765 | 42x |
lavSampleStats |
| 1766 |
} |
|
| 1767 | ||
| 1768 |
# compute sample statistics, per missing pattern |
|
| 1769 |
lav_samplestats_missing_patterns <- function(Y = NULL, Mp = NULL, wt = NULL, |
|
| 1770 |
Lp = NULL) {
|
|
| 1771 |
# coerce Y to matrix |
|
| 1772 | 8x |
Y <- as.matrix(Y) |
| 1773 | ||
| 1774 |
# handle two-level data |
|
| 1775 | 8x |
if (!is.null(Lp)) {
|
| 1776 | ! |
Y.orig <- Y |
| 1777 | ! |
Z <- NULL |
| 1778 | ! |
if (length(Lp$between.idx[[2]]) > 0L) {
|
| 1779 | ! |
Y <- Y[, -Lp$between.idx[[2]], drop = FALSE] |
| 1780 | ! |
z.idx <- which(!duplicated(Lp$cluster.idx[[2]])) |
| 1781 | ! |
Z <- Y.orig[z.idx, Lp$between.idx[[2]], drop = FALSE] |
| 1782 |
} |
|
| 1783 |
} |
|
| 1784 | ||
| 1785 | 8x |
if (is.null(Mp)) {
|
| 1786 | ! |
Mp <- lav_data_missing_patterns(Y, |
| 1787 | ! |
sort.freq = FALSE, coverage = FALSE, |
| 1788 | ! |
Lp = Lp |
| 1789 |
) |
|
| 1790 |
} |
|
| 1791 | ||
| 1792 | 8x |
Yp <- vector("list", length = Mp$npatterns)
|
| 1793 | ||
| 1794 |
# fill in pattern statistics |
|
| 1795 | 8x |
for (p in seq_len(Mp$npatterns)) {
|
| 1796 |
# extract raw data for these cases |
|
| 1797 | 14x |
RAW <- Y[Mp$case.idx[[p]], Mp$pat[p, ], drop = FALSE] |
| 1798 | ||
| 1799 |
# more than one case |
|
| 1800 | 14x |
if (Mp$freq[p] > 1L) {
|
| 1801 | 8x |
if (!is.null(wt)) {
|
| 1802 | ! |
out <- stats::cov.wt(RAW, |
| 1803 | ! |
wt = wt[Mp$case.idx[[p]]], |
| 1804 | ! |
method = "ML" |
| 1805 |
) |
|
| 1806 | ! |
SY <- out$cov |
| 1807 | ! |
MY <- out$center |
| 1808 |
} else {
|
|
| 1809 | 8x |
MY <- base::.colMeans(RAW, m = NROW(RAW), n = NCOL(RAW)) |
| 1810 |
# SY <- crossprod(RAW)/Mp$freq[p] - tcrossprod(MY) |
|
| 1811 |
# bad practice, better like this: |
|
| 1812 | 8x |
SY <- lav_matrix_cov(RAW) |
| 1813 |
} |
|
| 1814 |
} |
|
| 1815 |
# only a single observation (no need to weight!) |
|
| 1816 |
else {
|
|
| 1817 | 6x |
SY <- 0 |
| 1818 | 6x |
MY <- as.numeric(RAW) |
| 1819 |
} |
|
| 1820 | ||
| 1821 | 14x |
if (!is.null(wt)) {
|
| 1822 | ! |
FREQ <- sum(wt[Mp$case.idx[[p]]]) |
| 1823 |
} else {
|
|
| 1824 | 14x |
FREQ <- Mp$freq[p] |
| 1825 |
} |
|
| 1826 | ||
| 1827 |
# store sample statistics, var.idx and freq |
|
| 1828 | 14x |
Yp[[p]] <- list( |
| 1829 | 14x |
SY = SY, MY = MY, var.idx = Mp$pat[p, ], |
| 1830 | 14x |
freq = FREQ |
| 1831 |
) |
|
| 1832 | ||
| 1833 |
# if clustered data, add rowsum over all cases per cluster |
|
| 1834 | 14x |
if (!is.null(Lp)) {
|
| 1835 | ! |
tmp <- rowsum.default(RAW, group = Mp$j.idx[[p]], reorder = FALSE) |
| 1836 | ! |
Yp[[p]]$ROWSUM <- tmp |
| 1837 |
} |
|
| 1838 |
} |
|
| 1839 | ||
| 1840 |
# add Zp as an attribute |
|
| 1841 |
# if(!is.null(Lp)) {
|
|
| 1842 |
# Zp <- lav_samplestats_missing_patterns(Y = Z, Mp = Mp$Zp) |
|
| 1843 |
# for(p in Mp$Zp$npatterns) {
|
|
| 1844 |
# this.z <- Z[Mp$Zp$case.idx[[p]], drop = FALSE] |
|
| 1845 |
# Zp[[p]]$ROWSUM <- t(this.z) |
|
| 1846 |
# |
|
| 1847 |
# } |
|
| 1848 |
# attr(Yp, "Zp") <- Zp |
|
| 1849 |
# } |
|
| 1850 | ||
| 1851 | 8x |
Yp |
| 1852 |
} |
|
| 1853 | ||
| 1854 |
# compute sample statistics, per cluster |
|
| 1855 |
lav_samplestats_cluster_patterns <- function(Y = NULL, Lp = NULL, |
|
| 1856 |
conditional.x = FALSE) {
|
|
| 1857 |
# coerce Y to matrix |
|
| 1858 | 4x |
Y1 <- as.matrix(Y) |
| 1859 | 4x |
N <- NROW(Y1) |
| 1860 | 4x |
P <- NCOL(Y1) |
| 1861 | ||
| 1862 | 4x |
if (is.null(Lp)) {
|
| 1863 | ! |
lav_msg_stop(gettext("Lp is NULL"))
|
| 1864 |
} |
|
| 1865 | ||
| 1866 |
# how many levels? |
|
| 1867 | 4x |
nlevels <- length(Lp$cluster) + 1L |
| 1868 | ||
| 1869 |
# compute some sample statistics per level |
|
| 1870 | 4x |
YLp <- vector("list", length = nlevels)
|
| 1871 | 4x |
for (l in 2:nlevels) {
|
| 1872 | 4x |
ncluster.sizes <- Lp$ncluster.sizes[[l]] |
| 1873 | 4x |
cluster.size <- Lp$cluster.size[[l]] |
| 1874 | 4x |
cluster.sizes <- Lp$cluster.sizes[[l]] |
| 1875 | 4x |
nclusters <- Lp$nclusters[[l]] |
| 1876 | 4x |
both.idx <- Lp$both.idx[[l]] |
| 1877 | 4x |
within.idx <- Lp$within.idx[[l]] |
| 1878 | 4x |
between.idx <- Lp$between.idx[[l]] |
| 1879 | 4x |
cluster.idx <- Lp$cluster.idx[[l]] |
| 1880 | 4x |
cluster.size.ns <- Lp$cluster.size.ns[[l]] |
| 1881 | ||
| 1882 |
# s <- (N^2 - sum(cluster.size^2)) / (N*(nclusters - 1L)) |
|
| 1883 |
# same as |
|
| 1884 | 4x |
s <- (N - sum(cluster.size^2) / N) / (nclusters - 1) |
| 1885 |
# NOTE: must be (nclusters - 1), otherwise, s is not average cluster |
|
| 1886 |
# size even in the balanced case |
|
| 1887 | ||
| 1888 | 4x |
Y1.means <- colMeans(Y1, na.rm = TRUE) |
| 1889 | 4x |
Y1Y1 <- lav_matrix_crossprod(Y1) |
| 1890 | 4x |
both.idx <- all.idx <- seq_len(P) |
| 1891 | ||
| 1892 | 4x |
if (length(within.idx) > 0L || |
| 1893 | 4x |
length(between.idx) > 0L) {
|
| 1894 | ! |
both.idx <- all.idx[-c(within.idx, between.idx)] |
| 1895 |
# hm, this assumes the 'order' is the |
|
| 1896 |
# same at both levels... |
|
| 1897 |
} |
|
| 1898 | ||
| 1899 |
# cluster-means |
|
| 1900 | 4x |
Y2 <- rowsum.default(Y1, |
| 1901 | 4x |
group = cluster.idx, reorder = FALSE, |
| 1902 | 4x |
na.rm = FALSE, # must be FALSE! |
| 1903 | 4x |
) / cluster.size |
| 1904 | 4x |
Y2c <- t(t(Y2) - Y1.means) |
| 1905 | ||
| 1906 |
# compute S.w |
|
| 1907 |
# center within variables by grand mean instead of group mean? |
|
| 1908 |
# (YR: apparently not for S.PW) |
|
| 1909 | ||
| 1910 | 4x |
Y2a <- Y2 |
| 1911 |
# if(length(within.idx) > 0L) {
|
|
| 1912 |
# for(i in 1:length(within.idx)) {
|
|
| 1913 |
# Y2a[, within.idx[i]] <- Y1.means[within.idx[i]] |
|
| 1914 |
# } |
|
| 1915 |
# } |
|
| 1916 | 4x |
Y1a <- Y1 - Y2a[cluster.idx, , drop = FALSE] |
| 1917 | 4x |
S.w <- lav_matrix_crossprod(Y1a) / (N - nclusters) |
| 1918 | ||
| 1919 |
# S.b |
|
| 1920 |
# three parts: within/within, between/between, between/within |
|
| 1921 |
# standard definition of the between variance matrix |
|
| 1922 |
# divides by (nclusters - 1) |
|
| 1923 | 4x |
S.b <- lav_matrix_crossprod(Y2c * cluster.size, Y2c) / (nclusters - 1) |
| 1924 | ||
| 1925 |
# check for zero variances |
|
| 1926 | 4x |
if (length(both.idx) > 0L) {
|
| 1927 | 4x |
zero.idx <- which(diag(S.b)[both.idx] < 0.0001) |
| 1928 | 4x |
if (length(zero.idx) > 0L && !anyNA(Y2)) {
|
| 1929 | ! |
lav_msg_warn(gettext( |
| 1930 | ! |
"(near) zero variance at between level for splitted variable:"), |
| 1931 | ! |
paste(Lp$both.names[[l]][zero.idx], collapse = " ") |
| 1932 |
) |
|
| 1933 |
} |
|
| 1934 |
} |
|
| 1935 | ||
| 1936 | 4x |
S <- cov(Y1, use = "pairwise.complete.obs") * (N - 1L) / N |
| 1937 |
# missing by design? |
|
| 1938 | 4x |
S[is.na(S)] <- as.numeric(NA) |
| 1939 | ||
| 1940 |
# loglik.x |
|
| 1941 |
# extract 'fixed' level-1 loglik from here |
|
| 1942 | 4x |
wx.idx <- Lp$ov.x.idx[[1]] |
| 1943 | 4x |
if (length(wx.idx) > 0L) {
|
| 1944 | ! |
loglik.x.w <- lav_mvnorm_h1_loglik_samplestats( |
| 1945 | ! |
sample.nobs = Lp$nclusters[[1]], |
| 1946 | ! |
sample.cov = S[wx.idx, wx.idx, drop = FALSE] |
| 1947 |
) |
|
| 1948 |
} else {
|
|
| 1949 | 4x |
loglik.x.w <- 0 |
| 1950 |
} |
|
| 1951 |
# extract 'fixed' level-2 loglik |
|
| 1952 | 4x |
bx.idx <- Lp$ov.x.idx[[2]] |
| 1953 | 4x |
if (length(bx.idx) > 0L) {
|
| 1954 | ! |
COVB <- cov(Y2[, bx.idx, drop = FALSE]) * (nclusters - 1) / nclusters |
| 1955 | ! |
loglik.x.b <- lav_mvnorm_h1_loglik_samplestats( |
| 1956 | ! |
sample.nobs = Lp$nclusters[[2]], |
| 1957 | ! |
sample.cov = COVB |
| 1958 |
) |
|
| 1959 |
} else {
|
|
| 1960 | 4x |
loglik.x.b <- 0 |
| 1961 |
} |
|
| 1962 | 4x |
loglik.x <- loglik.x.w + loglik.x.b |
| 1963 | ||
| 1964 | ||
| 1965 | 4x |
S.PW.start <- S.w |
| 1966 | 4x |
if (length(within.idx) > 0L) {
|
| 1967 | ! |
S.PW.start[within.idx, within.idx] <- |
| 1968 | ! |
S[within.idx, within.idx, drop = FALSE] |
| 1969 |
} |
|
| 1970 | ||
| 1971 | 4x |
if (length(between.idx) > 0L) {
|
| 1972 | ! |
S.w[between.idx, ] <- 0 |
| 1973 | ! |
S.w[, between.idx] <- 0 |
| 1974 | ! |
S.PW.start[between.idx, ] <- 0 |
| 1975 | ! |
S.PW.start[, between.idx] <- 0 |
| 1976 |
} |
|
| 1977 | ||
| 1978 | 4x |
if (length(between.idx) > 0L) {
|
| 1979 |
# this is what is needed for MUML: |
|
| 1980 | ! |
S.b[, between.idx] <- |
| 1981 | ! |
(s * nclusters / N) * S.b[, between.idx, drop = FALSE] |
| 1982 | ! |
S.b[between.idx, ] <- |
| 1983 | ! |
(s * nclusters / N) * S.b[between.idx, , drop = FALSE] |
| 1984 | ! |
S.b[between.idx, between.idx] <- |
| 1985 | ! |
(s * lav_matrix_crossprod( |
| 1986 | ! |
Y2c[, between.idx, drop = FALSE], |
| 1987 | ! |
Y2c[, between.idx, drop = FALSE] |
| 1988 | ! |
) / nclusters) |
| 1989 |
} |
|
| 1990 | ||
| 1991 | 4x |
Sigma.B <- (S.b - S.w) / s |
| 1992 | 4x |
Sigma.B[within.idx, ] <- 0 |
| 1993 | 4x |
Sigma.B[, within.idx] <- 0 |
| 1994 | ||
| 1995 |
# what if we have negative variances in Sigma.B? |
|
| 1996 |
# this may happen if 'split' a variable that has no between variance |
|
| 1997 | 4x |
zero.idx <- which(diag(Sigma.B) < 1e-10) |
| 1998 | 4x |
if (length(zero.idx) > 0L) {
|
| 1999 | ! |
Sigma.B[zero.idx, ] <- 0 |
| 2000 | ! |
Sigma.B[, zero.idx] <- 0 |
| 2001 |
} |
|
| 2002 | ||
| 2003 | ||
| 2004 | 4x |
Mu.W <- numeric(P) |
| 2005 | 4x |
Mu.W[within.idx] <- Y1.means[within.idx] |
| 2006 | ||
| 2007 | 4x |
Mu.B <- Y1.means |
| 2008 | 4x |
Mu.B[within.idx] <- 0 |
| 2009 | 4x |
if (length(between.idx) > 0L) {
|
| 2010 |
# replace between.idx by cov(Y2)[,] elements... |
|
| 2011 | ! |
Mu.B[between.idx] <- colMeans(Y2[, between.idx, drop = FALSE], |
| 2012 | ! |
na.rm = TRUE |
| 2013 |
) |
|
| 2014 | ||
| 2015 | ! |
S2 <- (cov(Y2, use = "pairwise.complete.obs") * |
| 2016 | ! |
(nclusters - 1L) / nclusters) |
| 2017 | ||
| 2018 | ! |
Sigma.B[between.idx, between.idx] <- |
| 2019 | ! |
S2[between.idx, between.idx, drop = FALSE] |
| 2020 |
} |
|
| 2021 | ||
| 2022 |
# FIXME: Mu.B not quite ok for (fixed.x) x variables if they |
|
| 2023 |
# occur both at level 1 AND level 2 |
|
| 2024 | 4x |
Mu.B.start <- Mu.B |
| 2025 |
# Mu.B.start[both.idx] <- Mu.B.start[both.idx] - colMeans(Y2c[,both.idx]) |
|
| 2026 | ||
| 2027 |
# sample statistics PER CLUSTER-SIZE |
|
| 2028 | ||
| 2029 |
# summary statistics for complete data, conditional.x = FALSE |
|
| 2030 |
# also needed for h1 (even if conditional.x = TRUE) |
|
| 2031 | 4x |
cov.d <- vector("list", length = ncluster.sizes)
|
| 2032 | 4x |
mean.d <- vector("list", length = ncluster.sizes)
|
| 2033 | 4x |
for (clz in seq_len(ncluster.sizes)) {
|
| 2034 | 8x |
nj <- cluster.sizes[clz] |
| 2035 |
# select clusters with this size |
|
| 2036 | 8x |
d.idx <- which(cluster.size == nj) |
| 2037 | 8x |
ns <- length(d.idx) |
| 2038 |
# NOTE:!!!! |
|
| 2039 |
# reorder columns |
|
| 2040 |
# to match A.inv and m.k later on in objective!!! |
|
| 2041 | 8x |
tmp2 <- Y2[d.idx, |
| 2042 | 8x |
c(between.idx, sort.int(c(both.idx, within.idx))), |
| 2043 | 8x |
drop = FALSE |
| 2044 |
] |
|
| 2045 | 8x |
mean.d[[clz]] <- colMeans(tmp2, na.rm = TRUE) |
| 2046 | 8x |
bad.idx <- which(!is.finite(mean.d[[clz]])) # if nrow = 1 + NA |
| 2047 | 8x |
if (length(bad.idx) > 0L) {
|
| 2048 | ! |
mean.d[[clz]][bad.idx] <- 0 # ugly, only for starting values |
| 2049 |
} |
|
| 2050 | 8x |
if (length(d.idx) > 1L) {
|
| 2051 | 8x |
if (any(is.na(tmp2))) {
|
| 2052 |
# if full column has NA, this will fail... |
|
| 2053 |
# not needed anyway |
|
| 2054 |
# out <- lav_mvnorm_missing_h1_estimate_moments(Y = tmp2, |
|
| 2055 |
# max.iter = 10L) |
|
| 2056 |
# cov.d[[clz]] <- out$Sigma |
|
| 2057 | ! |
cov.d[[clz]] <- 0 |
| 2058 |
} else {
|
|
| 2059 | 8x |
cov.d[[clz]] <- (cov(tmp2, use = "complete.obs") * |
| 2060 | 8x |
(ns - 1) / ns) |
| 2061 |
} |
|
| 2062 |
} else {
|
|
| 2063 | ! |
cov.d[[clz]] <- 0 |
| 2064 |
} |
|
| 2065 |
} # clz |
|
| 2066 | ||
| 2067 |
# new in 0.6-12: |
|
| 2068 |
# summary statistics for complete data, conditional.x = TRUE |
|
| 2069 |
# ONLY for twolevel |
|
| 2070 | 4x |
if (conditional.x) {
|
| 2071 | ! |
within.x.idx <- Lp$within.x.idx[[1]] |
| 2072 | ! |
between.y.idx <- Lp$between.y.idx[[2]] |
| 2073 | ! |
between.x.idx <- Lp$between.x.idx[[2]] |
| 2074 | ! |
y1.idx <- Lp$ov.y.idx[[1]] |
| 2075 | ! |
x1.idx <- c(within.x.idx, between.x.idx) # in that order |
| 2076 | ||
| 2077 |
# data |
|
| 2078 | ! |
Y1.wb <- Y1[, y1.idx, drop = FALSE] |
| 2079 | ! |
Y2.wb <- Y2[, y1.idx, drop = FALSE] |
| 2080 | ! |
if (length(between.y.idx) > 0L) {
|
| 2081 | ! |
Y2.z <- Y2[, between.y.idx, drop = FALSE] |
| 2082 |
} |
|
| 2083 | ! |
if (length(x1.idx) > 0L) {
|
| 2084 | ! |
EXO.wb1 <- cbind(1, Y1[, x1.idx, drop = FALSE]) |
| 2085 | ! |
EXO.wb2 <- cbind(1, Y2[, x1.idx, drop = FALSE]) |
| 2086 |
} else {
|
|
| 2087 | ! |
EXO.wb1 <- matrix(1, nrow(Y1), 1L) |
| 2088 | ! |
EXO.wb2 <- matrix(1, nrow(Y2), 1L) |
| 2089 |
} |
|
| 2090 | ||
| 2091 |
# sample beta.wb (level 1) |
|
| 2092 | ! |
sample.wb <- solve(crossprod(EXO.wb1), crossprod(EXO.wb1, Y1.wb)) |
| 2093 | ! |
sample.yhat.wb1 <- EXO.wb1 %*% sample.wb |
| 2094 | ! |
sample.yres.wb1 <- Y1.wb - sample.yhat.wb1 |
| 2095 | ! |
sample.YYres.wb1 <- crossprod(sample.yres.wb1) |
| 2096 | ! |
sample.XX.wb1 <- crossprod(EXO.wb1) |
| 2097 | ||
| 2098 |
# sample beta.wb (level 2) |
|
| 2099 | ! |
XX.wb2 <- crossprod(EXO.wb2) |
| 2100 | ! |
sample.wb2 <- try(solve(XX.wb2, crossprod(EXO.wb2, Y2.wb)), |
| 2101 | ! |
silent = TRUE |
| 2102 |
) |
|
| 2103 | ! |
if (inherits(sample.wb2, "try-error")) {
|
| 2104 |
# this may happen if the covariate is cluster-centered |
|
| 2105 |
# using the observed cluster means; then the 'means' will |
|
| 2106 |
# be all (near) zero, and there is no variance |
|
| 2107 | ! |
sample.wb2 <- MASS::ginv(XX.wb2) %*% crossprod(EXO.wb2, Y2.wb) |
| 2108 |
} |
|
| 2109 | ! |
sample.yhat.wb2 <- EXO.wb2 %*% sample.wb2 |
| 2110 | ! |
sample.yres.wb2 <- Y2.wb - sample.yhat.wb2 |
| 2111 | ||
| 2112 |
# weighted by cluster.size |
|
| 2113 | ! |
sample.YYres.wb2 <- crossprod( |
| 2114 | ! |
sample.yres.wb2, |
| 2115 | ! |
sample.yres.wb2 * cluster.size |
| 2116 |
) |
|
| 2117 | ! |
sample.YresX.wb2 <- crossprod( |
| 2118 | ! |
sample.yres.wb2, |
| 2119 | ! |
EXO.wb2 * cluster.size |
| 2120 |
) |
|
| 2121 | ! |
sample.XX.wb2 <- crossprod( |
| 2122 | ! |
EXO.wb2, |
| 2123 | ! |
EXO.wb2 * cluster.size |
| 2124 |
) |
|
| 2125 | ||
| 2126 | ||
| 2127 | ! |
sample.clz.Y2.res <- vector("list", ncluster.sizes)
|
| 2128 | ! |
sample.clz.Y2.XX <- vector("list", ncluster.sizes)
|
| 2129 | ! |
sample.clz.Y2.B <- vector("list", ncluster.sizes)
|
| 2130 | ||
| 2131 | ! |
if (length(between.y.idx) > 0L) {
|
| 2132 | ! |
sample.clz.ZZ.res <- vector("list", ncluster.sizes)
|
| 2133 | ! |
sample.clz.ZZ.XX <- vector("list", ncluster.sizes)
|
| 2134 | ! |
sample.clz.ZZ.B <- vector("list", ncluster.sizes)
|
| 2135 | ||
| 2136 | ! |
sample.clz.YZ.res <- vector("list", ncluster.sizes)
|
| 2137 | ! |
sample.clz.YZ.XX <- vector("list", ncluster.sizes)
|
| 2138 | ! |
sample.clz.YresXZ <- vector("list", ncluster.sizes)
|
| 2139 | ! |
sample.clz.XWZres <- vector("list", ncluster.sizes)
|
| 2140 |
} |
|
| 2141 | ! |
for (clz in seq_len(ncluster.sizes)) {
|
| 2142 |
# cluster size |
|
| 2143 | ! |
nj <- cluster.sizes[clz] |
| 2144 | ! |
nj.idx <- which(cluster.size == nj) |
| 2145 | ||
| 2146 |
# Y2 |
|
| 2147 | ! |
Y2.clz <- Y2[nj.idx, y1.idx, drop = FALSE] |
| 2148 | ! |
if (length(x1.idx) > 0L) {
|
| 2149 | ! |
EXO2.clz <- cbind(1, Y2[nj.idx, x1.idx, drop = FALSE]) |
| 2150 |
} else {
|
|
| 2151 | ! |
EXO2.clz <- matrix(1, nrow(Y2.clz), 1L) |
| 2152 |
} |
|
| 2153 | ! |
XX.clz <- crossprod(EXO2.clz) |
| 2154 | ! |
clz.Y2.B <- try(solve(XX.clz, crossprod(EXO2.clz, Y2.clz)), |
| 2155 | ! |
silent = TRUE |
| 2156 |
) |
|
| 2157 | ! |
if (inherits(clz.Y2.B, "try-error")) {
|
| 2158 | ! |
clz.Y2.B <- |
| 2159 | ! |
MASS::ginv(XX.clz) %*% crossprod(EXO2.clz, Y2.clz) |
| 2160 |
} |
|
| 2161 | ! |
clz.Y2.hat <- EXO2.clz %*% clz.Y2.B |
| 2162 | ! |
clz.Y2.res <- Y2.clz - clz.Y2.hat |
| 2163 | ! |
sample.clz.Y2.B[[clz]] <- clz.Y2.B |
| 2164 | ! |
sample.clz.Y2.res[[clz]] <- crossprod(clz.Y2.res) |
| 2165 | ! |
sample.clz.Y2.XX[[clz]] <- crossprod(EXO2.clz) |
| 2166 | ||
| 2167 |
# Z |
|
| 2168 | ! |
if (length(between.y.idx) > 0L) {
|
| 2169 | ! |
Z.clz.z <- Y2[nj.idx, between.y.idx, drop = FALSE] |
| 2170 | ! |
if (length(between.x.idx) > 0L) {
|
| 2171 | ! |
EXO.clz.z <- cbind( |
| 2172 | ! |
1, |
| 2173 | ! |
Y2[nj.idx, between.x.idx, drop = FALSE] |
| 2174 |
) |
|
| 2175 |
} else {
|
|
| 2176 | ! |
EXO.clz.z <- matrix(1, nrow(Z.clz.z), 1L) |
| 2177 |
} |
|
| 2178 | ! |
ZZ.clz <- crossprod(EXO.clz.z) |
| 2179 | ! |
clz.ZZ.B <- try( |
| 2180 | ! |
solve( |
| 2181 | ! |
ZZ.clz, |
| 2182 | ! |
crossprod(EXO.clz.z, Z.clz.z) |
| 2183 |
), |
|
| 2184 | ! |
silent = TRUE |
| 2185 |
) |
|
| 2186 | ! |
if (inherits(clz.ZZ.B, "try-error")) {
|
| 2187 | ! |
clz.ZZ.B <- |
| 2188 | ! |
MASS::ginv(ZZ.clz) %*% crossprod(EXO.clz.z, Z.clz.z) |
| 2189 |
} |
|
| 2190 | ! |
clz.Z.hat <- EXO.clz.z %*% clz.ZZ.B |
| 2191 | ! |
clz.Z.res <- Z.clz.z - clz.Z.hat |
| 2192 | ! |
sample.clz.ZZ.B[[clz]] <- clz.ZZ.B |
| 2193 | ! |
sample.clz.ZZ.res[[clz]] <- crossprod(clz.Z.res) |
| 2194 | ! |
sample.clz.ZZ.XX[[clz]] <- crossprod(EXO.clz.z) |
| 2195 | ||
| 2196 | ! |
sample.clz.YZ.res[[clz]] <- crossprod(clz.Y2.res, clz.Z.res) |
| 2197 | ! |
sample.clz.YZ.XX[[clz]] <- crossprod(EXO2.clz, EXO.clz.z) |
| 2198 | ! |
sample.clz.YresXZ[[clz]] <- crossprod(clz.Y2.res, EXO.clz.z) |
| 2199 | ! |
sample.clz.XWZres[[clz]] <- crossprod(EXO2.clz, clz.Z.res) |
| 2200 |
} |
|
| 2201 |
} # clz |
|
| 2202 |
} # conditional.x |
|
| 2203 | ||
| 2204 | 4x |
YLp[[l]] <- list( |
| 2205 | 4x |
Y1Y1 = Y1Y1, |
| 2206 | 4x |
Y2 = Y2, s = s, S.b = S.b, S.PW.start = S.PW.start, |
| 2207 | 4x |
Sigma.W = S.w, Mu.W = Mu.W, |
| 2208 | 4x |
Sigma.B = Sigma.B, Mu.B = Mu.B, |
| 2209 | 4x |
Mu.B.start = Mu.B.start, loglik.x = loglik.x, |
| 2210 | 4x |
mean.d = mean.d, cov.d = cov.d |
| 2211 |
) |
|
| 2212 | ||
| 2213 |
# if conditional, add more stuff |
|
| 2214 | 4x |
if (conditional.x) {
|
| 2215 | ! |
if (length(between.y.idx) > 0L) {
|
| 2216 | ! |
extra <- list( |
| 2217 | ! |
sample.wb = sample.wb, |
| 2218 | ! |
sample.YYres.wb1 = sample.YYres.wb1, |
| 2219 | ! |
sample.XX.wb1 = sample.XX.wb1, |
| 2220 | ! |
sample.wb2 = sample.wb2, |
| 2221 | ! |
sample.YYres.wb2 = sample.YYres.wb2, |
| 2222 | ! |
sample.YresX.wb2 = sample.YresX.wb2, |
| 2223 | ! |
sample.XX.wb2 = sample.XX.wb2, |
| 2224 | ! |
sample.clz.Y2.res = sample.clz.Y2.res, |
| 2225 | ! |
sample.clz.Y2.XX = sample.clz.Y2.XX, |
| 2226 | ! |
sample.clz.Y2.B = sample.clz.Y2.B, |
| 2227 | ! |
sample.clz.ZZ.res = sample.clz.ZZ.res, |
| 2228 | ! |
sample.clz.ZZ.XX = sample.clz.ZZ.XX, |
| 2229 | ! |
sample.clz.ZZ.B = sample.clz.ZZ.B, |
| 2230 | ! |
sample.clz.YZ.res = sample.clz.YZ.res, |
| 2231 | ! |
sample.clz.YZ.XX = sample.clz.YZ.XX, |
| 2232 | ! |
sample.clz.YresXZ = sample.clz.YresXZ, # zero? |
| 2233 | ! |
sample.clz.XWZres = sample.clz.XWZres |
| 2234 |
) |
|
| 2235 |
} else {
|
|
| 2236 | ! |
extra <- list( |
| 2237 | ! |
sample.wb = sample.wb, |
| 2238 | ! |
sample.YYres.wb1 = sample.YYres.wb1, |
| 2239 | ! |
sample.XX.wb1 = sample.XX.wb1, |
| 2240 | ! |
sample.wb2 = sample.wb2, |
| 2241 | ! |
sample.YYres.wb2 = sample.YYres.wb2, |
| 2242 | ! |
sample.YresX.wb2 = sample.YresX.wb2, |
| 2243 | ! |
sample.XX.wb2 = sample.XX.wb2, |
| 2244 | ! |
sample.clz.Y2.res = sample.clz.Y2.res, |
| 2245 | ! |
sample.clz.Y2.XX = sample.clz.Y2.XX, |
| 2246 | ! |
sample.clz.Y2.B = sample.clz.Y2.B |
| 2247 |
) |
|
| 2248 |
} |
|
| 2249 | ! |
YLp[[l]] <- c(YLp[[l]], extra) |
| 2250 |
} |
|
| 2251 |
} # l |
|
| 2252 | ||
| 2253 | 4x |
YLp |
| 2254 |
} |
| 1 |
lav_points_beziers <- function(x, |
|
| 2 |
y = NULL, |
|
| 3 |
col = par("col"),
|
|
| 4 |
lwd = par("lwd")
|
|
| 5 |
) {
|
|
| 6 | ! |
if (is.null(y)) {
|
| 7 | ! |
if (dim(x)[1L] == 2) {
|
| 8 | ! |
p_x <- x[1L, ] |
| 9 | ! |
p_y <- x[2L, ] |
| 10 |
} else {
|
|
| 11 | ! |
p_x <- x[, 1L] |
| 12 | ! |
p_y <- x[, 2L] |
| 13 |
} |
|
| 14 |
} else {
|
|
| 15 | ! |
p_x <- x |
| 16 | ! |
p_y <- y |
| 17 |
} |
|
| 18 | ! |
stopifnot(length(p_x) == length(p_y)) |
| 19 | ! |
t <- seq(0, 1, length.out = 50) |
| 20 | ! |
if (length(p_x) == 3L) {
|
| 21 | ! |
punten_x <- (1 - t)^2 * p_x[1] + 2 * (1 - t) * t * p_x[2] + t^2 * p_x[3] |
| 22 | ! |
punten_y <- (1 - t)^2 * p_y[1] + 2 * (1 - t) * t * p_y[2] + t^2 * p_y[3] |
| 23 |
} else {
|
|
| 24 | ! |
punten_x <- (1 - t)^3 * p_x[1] + 3 * t * (1 - t)^2 * p_x[2] + |
| 25 | ! |
3 * t^2 * (1 - t) * p_x[3] + t^3 * p_x[4] |
| 26 | ! |
punten_y <- (1 - t)^3 * p_y[1] + 3 * t * (1 - t)^2 * p_y[2] + |
| 27 | ! |
3 * t^2 * (1 - t) * p_y[3] + t^3 * p_y[4] |
| 28 |
} |
|
| 29 | ! |
lines(punten_x, punten_y, col = col, lwd = lwd) |
| 30 |
} |
|
| 31 | ||
| 32 |
lav_plotinfo_rgraph <- function(plotinfo, |
|
| 33 |
sloped.labels = TRUE, |
|
| 34 |
outfile = "", |
|
| 35 |
addgrid = TRUE, |
|
| 36 |
mlovcolors = c("lightgreen", "lightblue"),
|
|
| 37 |
lightness = 1, |
|
| 38 |
italic = TRUE, |
|
| 39 |
auto.subscript = TRUE) {
|
|
| 40 | ! |
font <- ifelse(italic, 3L, 1L) |
| 41 | ! |
node_elements <- function(nodetiepe, noderadius) {
|
| 42 |
# define form, color and anchors for a node type |
|
| 43 | ! |
thetas <- switch(nodetiepe, |
| 44 | ! |
lv = , |
| 45 | ! |
varlv = seq(0, 2 * pi, length.out = 50L), |
| 46 | ! |
ov = seq(pi / 4, 2 * pi, by = pi / 2), |
| 47 | ! |
wov = , |
| 48 | ! |
bov = c( |
| 49 | ! |
seq(pi / 4 - pi / 10, pi / 4 + pi / 10, by = pi / 60), |
| 50 | ! |
seq(3 * pi / 4 - pi / 10, 3 * pi / 4 + pi / 10, by = pi / 60), |
| 51 | ! |
seq(5 * pi / 4 - pi / 10, 5 * pi / 4 + pi / 10, by = pi / 60), |
| 52 | ! |
seq(7 * pi / 4 - pi / 10, 7 * pi / 4 + pi / 10, by = pi / 60) |
| 53 |
), |
|
| 54 | ! |
cv = seq(0, 2 * pi, by = pi / 3), |
| 55 | ! |
const = seq(pi / 2, 2 * pi, by = 2 * pi / 3) |
| 56 |
) |
|
| 57 | ! |
localradius <- noderadius |
| 58 | ! |
if (nodetiepe == "varlv") localradius <- noderadius * .8 |
| 59 | ! |
drawx <- localradius * cos(thetas) |
| 60 | ! |
drawy <- localradius * sin(thetas) |
| 61 | ! |
wovbovflat <- max(drawx) |
| 62 | ! |
boxcol <- switch(nodetiepe, |
| 63 | ! |
lv = NA_integer_, |
| 64 | ! |
varlv = NA_integer_, |
| 65 | ! |
ov = NA_integer_, |
| 66 | ! |
wov = mlovcolors[1L], |
| 67 | ! |
bov = mlovcolors[2L], |
| 68 | ! |
cv = NA_integer_, |
| 69 | ! |
const = NA_integer_ |
| 70 |
) |
|
| 71 | ! |
n <- c(0, switch(nodetiepe, |
| 72 | ! |
lv = , |
| 73 | ! |
varlv = , |
| 74 | ! |
const = localradius, |
| 75 | ! |
ov = localradius * sqrt(2) / 2, |
| 76 | ! |
wov = , |
| 77 | ! |
bov = wovbovflat, |
| 78 | ! |
cv = localradius * sqrt(3) / 2 |
| 79 |
)) |
|
| 80 | ! |
s <- c(0, switch(nodetiepe, |
| 81 | ! |
lv = , |
| 82 | ! |
varlv = -localradius, |
| 83 | ! |
ov = -localradius * sqrt(2) / 2, |
| 84 | ! |
wov = , |
| 85 | ! |
bov = -wovbovflat, |
| 86 | ! |
cv = -localradius * sqrt(3) / 2, |
| 87 | ! |
const = -localradius * 0.5 |
| 88 |
)) |
|
| 89 | ! |
e <- switch(nodetiepe, |
| 90 | ! |
lv = , |
| 91 | ! |
varlv = , |
| 92 | ! |
cv = c(localradius, 0), |
| 93 | ! |
ov = c(localradius * sqrt(2) / 2, 0), |
| 94 | ! |
wov = , |
| 95 | ! |
bov = c(wovbovflat, 0), |
| 96 | ! |
const = c(localradius * sqrt(3) / 2, -localradius * 0.5) |
| 97 |
) |
|
| 98 | ! |
w <- c(-e[1L], e[2L]) |
| 99 | ! |
ne <- switch(nodetiepe, |
| 100 | ! |
lv = , |
| 101 | ! |
varlv = , |
| 102 | ! |
ov = , |
| 103 | ! |
wov = , |
| 104 | ! |
bov = localradius * sqrt(0.5) * c(1, 1), |
| 105 | ! |
cv = localradius * c(0.5, sqrt(3) / 2), |
| 106 | ! |
const = e |
| 107 |
) |
|
| 108 | ! |
nw <- c(-ne[1L], ne[2L]) |
| 109 | ! |
se <- switch(nodetiepe, |
| 110 | ! |
lv = , |
| 111 | ! |
varlv = , |
| 112 | ! |
ov = , |
| 113 | ! |
wov = , |
| 114 | ! |
bov = localradius * sqrt(0.5) * c(1, -1), |
| 115 | ! |
cv = localradius * c(0.5, -sqrt(3) / 2), |
| 116 | ! |
const = e |
| 117 |
) |
|
| 118 | ! |
sw <- c(-se[1L], se[2L]) |
| 119 | ! |
list( |
| 120 | ! |
drawx = drawx, drawy = drawy, boxcol = boxcol, n = n, ne = ne, e = e, |
| 121 | ! |
se = se, s = s, sw = sw, w = w, nw = nw |
| 122 |
) |
|
| 123 |
} |
|
| 124 | ||
| 125 | ! |
vecrotate <- function(vec, angle) {
|
| 126 | ! |
c( |
| 127 | ! |
cos(angle) * vec[1] + sin(angle) * vec[2], |
| 128 | ! |
-sin(angle) * vec[1] + cos(angle) * vec[2] |
| 129 |
) |
|
| 130 |
} |
|
| 131 | ! |
plot_arrow <- function(tip, dirvec) {
|
| 132 | ! |
unitvec <- dirvec / sqrt(sum(dirvec^2)) |
| 133 | ! |
arrowangle <- pi * 25 / 180 |
| 134 | ! |
arrowinset <- 0.4 |
| 135 | ! |
args <- rbind( |
| 136 | ! |
tip, |
| 137 | ! |
tip + vecrotate(-unitvec * arrowlength, arrowangle), |
| 138 | ! |
tip - unitvec * arrowlength * (1 - arrowinset), |
| 139 | ! |
tip + vecrotate(-unitvec * arrowlength, -arrowangle) |
| 140 |
) |
|
| 141 | ! |
polygon(args, col = "black", border = NA) |
| 142 |
} |
|
| 143 | ! |
plot_edge <- function(van, naar, label = "", dubbel = FALSE, |
| 144 | ! |
control = NA_real_, below = FALSE, txtcex = 0.9) {
|
| 145 | ! |
labele <- lav_label_code(label, auto.subscript = auto.subscript)$r |
| 146 | ! |
dirvec <- naar - van |
| 147 | ! |
theta <- atan2(naar[2] - van[2], naar[1] - van[1]) |
| 148 | ! |
srt <- ifelse(sloped.labels, 180 * theta / pi, 0) |
| 149 | ! |
if (srt > 90) srt <- srt - 180 |
| 150 | ! |
if (srt < -90) srt <- srt + 180 |
| 151 | ! |
if (is.na(control[1L])) {
|
| 152 | ! |
args <- rbind(van, naar) |
| 153 | ! |
lines(args, lwd = 2) |
| 154 | ! |
plot_arrow(naar, dirvec) |
| 155 | ! |
if (dubbel) plot_arrow(van, -dirvec) |
| 156 | ! |
midden <- (van + naar) * 0.5 |
| 157 |
} else {
|
|
| 158 |
# gebogen lijn (quadratic lav_points_beziers) |
|
| 159 | ! |
lav_points_beziers(rbind(van, control, naar), lwd = 2) |
| 160 | ! |
midden <- (van + naar) / 4 + control / 2 |
| 161 | ! |
plot_arrow(naar, naar - control) |
| 162 | ! |
if (dubbel) plot_arrow(van, van - control) |
| 163 |
} |
|
| 164 | ! |
if (label != "") {
|
| 165 | ! |
if (below) {
|
| 166 | ! |
if (theta >= 0 && theta < 90) {
|
| 167 | ! |
text(midden[1L], midden[2L], labele, |
| 168 | ! |
adj = c(0, 1), |
| 169 | ! |
srt = srt, cex = txtcex, font = font |
| 170 |
) |
|
| 171 | ! |
} else if (theta >= 90) {
|
| 172 | ! |
text(midden[1L], midden[2L], labele, |
| 173 | ! |
adj = c(1, 1), |
| 174 | ! |
srt = srt, cex = txtcex, font = font |
| 175 |
) |
|
| 176 | ! |
} else if (theta < -90) {
|
| 177 | ! |
text(midden[1L], midden[2L], labele, |
| 178 | ! |
adj = c(0, 1), |
| 179 | ! |
srt = srt, cex = txtcex, font = font |
| 180 |
) |
|
| 181 |
} else {
|
|
| 182 | ! |
text(midden[1L], midden[2L], labele, |
| 183 | ! |
adj = c(1, 1), |
| 184 | ! |
srt = srt, cex = txtcex, font = font |
| 185 |
) |
|
| 186 |
} |
|
| 187 |
} else {
|
|
| 188 | ! |
if (theta >= 0 && theta < 90) {
|
| 189 | ! |
text(midden[1L], midden[2L], labele, |
| 190 | ! |
adj = c(1, 0), |
| 191 | ! |
srt = srt, cex = txtcex, font = font |
| 192 |
) |
|
| 193 | ! |
} else if (theta >= 90) {
|
| 194 | ! |
text(midden[1L], midden[2L], labele, |
| 195 | ! |
adj = c(0, 0), |
| 196 | ! |
srt = srt, cex = txtcex, font = font |
| 197 |
) |
|
| 198 | ! |
} else if (theta < -90) {
|
| 199 | ! |
text(midden[1L], midden[2L], labele, |
| 200 | ! |
adj = c(1, 0), |
| 201 | ! |
srt = srt, cex = txtcex, font = font |
| 202 |
) |
|
| 203 |
} else {
|
|
| 204 | ! |
text(midden[1L], midden[2L], labele, |
| 205 | ! |
adj = c(0, 0), |
| 206 | ! |
srt = srt, cex = txtcex, font = font |
| 207 |
) |
|
| 208 |
} |
|
| 209 |
} |
|
| 210 |
} |
|
| 211 |
} |
|
| 212 | ! |
plot_var <- function(waar, noderadius, label = "", side = "n", txtcex = 0.9) {
|
| 213 | ! |
labele <- lav_label_code(label, auto.subscript = auto.subscript)$r |
| 214 | ! |
thetarange <- c(pi / 6, 11 * pi / 6) |
| 215 | ! |
if (side == "s") thetarange <- thetarange + pi / 2 |
| 216 | ! |
if (side == "e") thetarange <- thetarange + pi |
| 217 | ! |
if (side == "n") thetarange <- thetarange + 3 * pi / 2 |
| 218 | ! |
localradius <- noderadius * 0.8 |
| 219 | ! |
middelpt <- switch(side, |
| 220 | ! |
n = c(0, localradius), |
| 221 | ! |
w = c(-localradius, 0), |
| 222 | ! |
s = c(0, -localradius), |
| 223 | ! |
e = c(localradius, 0) |
| 224 |
) |
|
| 225 | ! |
middelpt <- middelpt + waar |
| 226 |
# cirkelsegment |
|
| 227 | ! |
thetas <- seq(thetarange[1L], thetarange[2L], length.out = 40) |
| 228 | ! |
straal <- localradius |
| 229 | ! |
xs <- middelpt[1] + cos(thetas) * straal |
| 230 | ! |
ys <- middelpt[2] + sin(thetas) * straal |
| 231 | ! |
lines(xs, ys) |
| 232 |
# pijlen |
|
| 233 | ! |
plot_arrow(c(xs[1], ys[1]), c(sin(thetarange[1]), -cos(thetarange[1]))) |
| 234 | ! |
plot_arrow(c(xs[40], ys[40]), c(-sin(thetarange[2]), cos(thetarange[2]))) |
| 235 |
# label |
|
| 236 | ! |
if (label != "") {
|
| 237 | ! |
text(middelpt[1L], middelpt[2L], labele, |
| 238 | ! |
adj = 0.5, cex = txtcex * 0.8, |
| 239 | ! |
font = font |
| 240 |
) |
|
| 241 |
} |
|
| 242 |
} |
|
| 243 | ! |
plot_node <- function(waar, tiepe, label = "", txtcex = 0.9) {
|
| 244 | ! |
labele <- lav_label_code(label, auto.subscript = auto.subscript)$r |
| 245 | ! |
elems <- node_elements(tiepe, noderadius) |
| 246 | ! |
x <- waar[1] + elems$drawx |
| 247 | ! |
y <- waar[2] + elems$drawy |
| 248 | ! |
polygon(x, y, col = elems$boxcol, lwd = 1) |
| 249 | ! |
text(waar[1L], waar[2L], labele, adj = 0.5, cex = txtcex, font = font) |
| 250 |
} |
|
| 251 | ! |
mlrij <- plotinfo$mlrij |
| 252 | ! |
if (is.null(mlrij)) {
|
| 253 | ! |
lav_msg_stop(gettext( |
| 254 | ! |
"plotinfo hasn't been processed by lav_plotinfo_positions!" |
| 255 |
)) |
|
| 256 |
} |
|
| 257 | ! |
nodes <- plotinfo$nodes |
| 258 | ! |
edges <- plotinfo$edges |
| 259 | ! |
noderadius <- 0.3 |
| 260 | ! |
arrowlength <- noderadius / 3 |
| 261 | ! |
rijen <- max(nodes$rij) |
| 262 | ! |
kolommen <- max(nodes$kolom) |
| 263 | ! |
if (outfile != "") png(outfile, 960, 960, "px") |
| 264 | ! |
opar <- par(mar = c(1L, 1L, 1L, 1L) + 0.1) |
| 265 | ! |
plot.default( |
| 266 | ! |
x = c(0, lightness * kolommen + 1), |
| 267 | ! |
c(0, lightness * rijen + 1), type = "n", |
| 268 | ! |
xlab = "", ylab = "", axes = FALSE, asp = 1 |
| 269 |
) |
|
| 270 | ! |
if (addgrid) {
|
| 271 | ! |
abline( |
| 272 | ! |
v = seq.int(kolommen) * lightness, |
| 273 | ! |
h = seq.int(rijen) * lightness, |
| 274 | ! |
lwd = 1, |
| 275 | ! |
lty = "dotted", col = "lightgray" |
| 276 |
) |
|
| 277 | ! |
text(seq.int(kolommen) * lightness, 0.3, |
| 278 | ! |
labels = seq.int(kolommen), adj = 1, cex = 0.7 |
| 279 |
) |
|
| 280 | ! |
text(0.3, seq.int(rijen) * lightness, |
| 281 | ! |
labels = seq.int(rijen, 1), adj = 1, cex = 0.7 |
| 282 |
) |
|
| 283 |
} |
|
| 284 | ! |
if (mlrij > 0L) abline(h = rijen - mlrij + 1, lwd = 2) |
| 285 | ! |
for (j in seq.int(nrow(edges))) {
|
| 286 | ! |
if (edges$naar[j] != edges$van[j]) {
|
| 287 | ! |
van <- which(nodes$id == edges$van[j]) |
| 288 | ! |
naar <- which(nodes$id == edges$naar[j]) |
| 289 | ! |
adrvan <- lightness * |
| 290 | ! |
c(nodes$kolom[van], rijen - nodes$rij[van] + 1) |
| 291 | ! |
elems <- node_elements(nodes$tiepe[van], noderadius) |
| 292 | ! |
adrvan <- adrvan + elems[[edges$vananker[j]]] |
| 293 | ! |
adrnaar <- lightness * |
| 294 | ! |
c(nodes$kolom[naar], rijen - nodes$rij[naar] + 1) |
| 295 | ! |
elems <- node_elements(nodes$tiepe[naar], noderadius) |
| 296 | ! |
adrnaar <- adrnaar + elems[[edges$naaranker[j]]] |
| 297 | ! |
if (is.na(edges$controlpt.rij[j])) {
|
| 298 | ! |
plot_edge(adrvan, adrnaar, edges$label[j], |
| 299 | ! |
dubbel = (edges$tiepe[j] == "~~"), |
| 300 | ! |
below = edges$labelbelow[j] |
| 301 |
) |
|
| 302 |
} else {
|
|
| 303 | ! |
controlpt <- lightness * c( |
| 304 | ! |
edges$controlpt.kol[j], |
| 305 | ! |
rijen - edges$controlpt.rij[j] + 1 |
| 306 |
) |
|
| 307 | ! |
plot_edge(adrvan, adrnaar, edges$label[j], |
| 308 | ! |
dubbel = (edges$tiepe[j] == "~~"), |
| 309 | ! |
below = edges$labelbelow[j], |
| 310 | ! |
control = controlpt |
| 311 |
) |
|
| 312 |
} |
|
| 313 |
} else {
|
|
| 314 | ! |
van <- which(nodes$id == edges$van[j]) |
| 315 | ! |
adrvan <- lightness * c(nodes$kolom[van], rijen - nodes$rij[van] + 1) |
| 316 | ! |
elems <- node_elements(nodes$tiepe[van], noderadius) |
| 317 | ! |
adrvan <- adrvan + elems[[edges$vananker[j]]] |
| 318 | ! |
plot_var(adrvan, noderadius, edges$label[j], edges$vananker[j]) |
| 319 |
} |
|
| 320 |
} |
|
| 321 | ! |
for (j in seq.int(nrow(nodes))) {
|
| 322 | ! |
plot_node( |
| 323 | ! |
lightness * |
| 324 | ! |
c(nodes$kolom[j], rijen - nodes$rij[j] + 1), |
| 325 | ! |
nodes$tiepe[j], |
| 326 | ! |
nodes$naam[j] |
| 327 |
) |
|
| 328 |
} |
|
| 329 | ! |
par(opar) |
| 330 | ! |
if (outfile != "") dev.off() |
| 331 | ! |
invisible(NULL) |
| 332 |
} |
| 1 |
# rotation algorithms for multiple groups |
|
| 2 |
# |
|
| 3 |
# YR 22 Dec 2025 -- initial version |
|
| 4 |
# |
|
| 5 |
# - rstarts only affects the 'initial' rotation |
|
| 6 | ||
| 7 |
# main function to rotate a list of matrices 'Alist' |
|
| 8 |
lav_matrix_rotate_mg <- function(Alist = NULL, # original matrices |
|
| 9 |
orthogonal = FALSE, # default is oblique |
|
| 10 |
method = "geomin", # default rot method |
|
| 11 |
method.args = list( |
|
| 12 |
geomin.epsilon = 0.01, |
|
| 13 |
orthomax.gamma = 1, |
|
| 14 |
cf.gamma = 0, |
|
| 15 |
oblimin.gamma = 0, |
|
| 16 |
promax.kappa = 4, |
|
| 17 |
target = matrix(0, 0, 0), |
|
| 18 |
target.mask = matrix(0, 0, 0) |
|
| 19 |
), |
|
| 20 |
init.rotList = NULL, # initial rotation matrix |
|
| 21 |
init.ROT.check = TRUE, # check if init ROT is ok |
|
| 22 |
rstarts = 30L, # number of random starts |
|
| 23 |
# row.weights = "default", # row weighting |
|
| 24 |
# std.ov = FALSE, # rescale ov |
|
| 25 |
# ov.var = NULL, # ov variances |
|
| 26 |
# algorithm = "gpa", # rotation algorithm |
|
| 27 |
mg.algorithm = "pairwise", |
|
| 28 |
mg.agreement.method = "procrustes", |
|
| 29 |
mg.agreement.weight = 0.5, |
|
| 30 |
reflect = TRUE, # refect sign |
|
| 31 |
order.lv.by = "index", # how to order the lv's |
|
| 32 |
# gpa.tol = 0.00001, # stopping tol gpa |
|
| 33 |
tol = 1e-07, # stopping tol others |
|
| 34 |
keep.rep = FALSE, # store replications |
|
| 35 |
max.iter = 10000L) { # max iterations
|
|
| 36 | ||
| 37 |
# check Alist |
|
| 38 | ! |
if (!is.list(Alist)) {
|
| 39 | ! |
lav_msg_stop(gettext("Alist does not seem to be a list"))
|
| 40 |
} |
|
| 41 | ! |
ngroups <- length(Alist) |
| 42 | ||
| 43 |
# check A |
|
| 44 | ! |
A <- Alist[[1]] |
| 45 | ! |
if (!inherits(A, "matrix")) {
|
| 46 | ! |
lav_msg_stop(gettext("A does not seem to be a matrix"))
|
| 47 |
} |
|
| 48 | ||
| 49 | ! |
P <- nrow(A) |
| 50 | ! |
M <- ncol(A) |
| 51 | ! |
if (M < 2L) { # single dimension
|
| 52 | ! |
res <- list( |
| 53 | ! |
lambdaList = Alist, rotList = NULL, |
| 54 | ! |
orthogonal = orthogonal, method = "none", |
| 55 | ! |
method.args = list(), row.weights = "none", |
| 56 | ! |
algorithm = "none", iter = 0L, converged = TRUE, |
| 57 | ! |
method.value = 0 |
| 58 |
) |
|
| 59 | ! |
return(res) |
| 60 |
} |
|
| 61 | ||
| 62 |
# method |
|
| 63 | ! |
method <- tolower(method) |
| 64 | ||
| 65 |
# no promax (for now) |
|
| 66 | ! |
if (method == "promax") {
|
| 67 | ! |
lav_msg_stop(gettext("mg-promax + agreement not supported"))
|
| 68 |
} |
|
| 69 | ||
| 70 |
# check init.ROT per group |
|
| 71 | ! |
if (!is.null(init.rotList) && init.ROT.check) {
|
| 72 | ! |
for(g in seq_len(ngroups)) {
|
| 73 | ! |
init.ROT <- init.rotList[[g]] |
| 74 | ! |
if (!inherits(init.ROT, "matrix")) {
|
| 75 | ! |
lav_msg_stop(gettext("init.ROT does not seem to a matrix"))
|
| 76 |
} |
|
| 77 | ! |
if (nrow(init.ROT) != M) {
|
| 78 | ! |
lav_msg_stop(gettextf( |
| 79 | ! |
"nrow(init.ROT) = %1$s does not equal ncol(A) = %2$s", |
| 80 | ! |
nrow(init.ROT), M |
| 81 |
)) |
|
| 82 |
} |
|
| 83 | ! |
if (nrow(init.ROT) != ncol(init.ROT)) {
|
| 84 | ! |
lav_msg_stop(gettextf( |
| 85 | ! |
"nrow(init.ROT) = %1$s does not equal ncol(init.ROT) = %2$s", |
| 86 | ! |
nrow(init.ROT), ncol(init.ROT) |
| 87 |
)) |
|
| 88 |
} |
|
| 89 |
# rotation matrix? |
|
| 90 | ! |
if (!lav_matrix_rotate_check(init.ROT, orthogonal = orthogonal)) {
|
| 91 | ! |
lav_msg_stop(gettext("init.ROT does not look like a rotation matrix"))
|
| 92 |
} |
|
| 93 |
} # group |
|
| 94 |
} # check init.rotList |
|
| 95 | ||
| 96 |
# determine method function name |
|
| 97 | ! |
if (method %in% c( |
| 98 | ! |
"cf-quartimax", "cf-varimax", "cf-equamax", |
| 99 | ! |
"cf-parsimax", "cf-facparsim" |
| 100 |
)) {
|
|
| 101 | ! |
method.fname <- "lav_matrix_rotate_cf" |
| 102 | ! |
method.args$cf.gamma <- switch(method, |
| 103 | ! |
"cf-quartimax" = 0, |
| 104 | ! |
"cf-varimax" = 1 / P, |
| 105 | ! |
"cf-equamax" = M / (2 * P), |
| 106 | ! |
"cf-parsimax" = (M - 1) / (P + M - 2), |
| 107 | ! |
"cf-facparsim" = 1 |
| 108 |
) |
|
| 109 | ! |
} else if (method %in% c("bi-quartimin", "biquartimin")) {
|
| 110 | ! |
method.fname <- "lav_matrix_rotate_biquartimin" |
| 111 | ! |
} else if (method %in% c("bi-geomin", "bigeomin")) {
|
| 112 | ! |
method.fname <- "lav_matrix_rotate_bigeomin" |
| 113 | ! |
} else if (method == "target.strict") {
|
| 114 | ! |
method.fname <- "lav_matrix_rotate_target" |
| 115 |
} else {
|
|
| 116 | ! |
method.fname <- paste("lav_matrix_rotate_", method, sep = "")
|
| 117 |
} |
|
| 118 | ||
| 119 |
# check if rotation method exists |
|
| 120 | ! |
check <- try(get(method.fname), silent = TRUE) |
| 121 | ! |
if (inherits(check, "try-error")) {
|
| 122 | ! |
lav_msg_stop(gettext("unknown rotation method:"), method.fname)
|
| 123 |
} |
|
| 124 | ||
| 125 |
# if target, check target matrix |
|
| 126 | ! |
if (method == "target.strict" || method == "pst") {
|
| 127 | ! |
target <- method.args$target |
| 128 | ! |
if (is.list(target)) {
|
| 129 | ! |
method.args$target <- target <- target[[1L]] # always take the first group |
| 130 |
} |
|
| 131 |
# check dimension of target/A |
|
| 132 | ! |
if (nrow(target) != nrow(A)) {
|
| 133 | ! |
lav_msg_stop(gettext("nrow(target) != nrow(A)"))
|
| 134 |
} |
|
| 135 | ! |
if (ncol(target) != ncol(A)) {
|
| 136 | ! |
lav_msg_stop(gettext("ncol(target) != ncol(A)"))
|
| 137 |
} |
|
| 138 |
} |
|
| 139 | ! |
if (method == "pst") {
|
| 140 | ! |
target.mask <- method.args$target.mask |
| 141 | ! |
if (is.list(target.mask)) {
|
| 142 | ! |
method.args$target.mask <- target.mask <- target.mask[[1L]] |
| 143 |
} |
|
| 144 |
# check dimension of target.mask/A |
|
| 145 | ! |
if (nrow(target.mask) != nrow(A)) {
|
| 146 | ! |
lav_msg_stop(gettext("nrow(target.mask) != nrow(A)"))
|
| 147 |
} |
|
| 148 | ! |
if (ncol(target.mask) != ncol(A)) {
|
| 149 | ! |
lav_msg_stop(gettext("col(target.mask) != ncol(A)"))
|
| 150 |
} |
|
| 151 |
} |
|
| 152 |
# we keep this here, so lav_matrix_rotate() can be used independently |
|
| 153 | ! |
if (method == "target.strict" && anyNA(target)) {
|
| 154 | ! |
method <- "pst" |
| 155 | ! |
method.fname <- "lav_matrix_rotate_pst" |
| 156 | ! |
target.mask <- matrix(1, nrow = nrow(target), ncol = ncol(target)) |
| 157 | ! |
target.mask[is.na(target)] <- 0 |
| 158 | ! |
method.args$target.mask <- target.mask |
| 159 |
} |
|
| 160 | ||
| 161 |
# set orthogonal option |
|
| 162 | ! |
if (missing(orthogonal)) {
|
| 163 |
# the default is oblique, except for varimax, entropy and a few others |
|
| 164 | ! |
if (method %in% c( |
| 165 | ! |
"varimax", "entropy", "mccammon", |
| 166 | ! |
"tandem1", "tandem2" |
| 167 |
)) {
|
|
| 168 | ! |
orthogonal <- TRUE |
| 169 |
} else {
|
|
| 170 | ! |
orthogonal <- FALSE |
| 171 |
} |
|
| 172 |
} else {
|
|
| 173 | ! |
if (!orthogonal && method %in% c( |
| 174 | ! |
"varimax", "entropy", "mccammon", |
| 175 | ! |
"tandem1", "tandem2" |
| 176 |
)) {
|
|
| 177 | ! |
lav_msg_warn(gettextf( |
| 178 | ! |
"rotation method %s may not work with oblique rotation.", |
| 179 | ! |
dQuote(method) |
| 180 |
)) |
|
| 181 |
} |
|
| 182 |
} |
|
| 183 | ||
| 184 |
# 0. initialize: rotate each group separately + reorder |
|
| 185 | ! |
Alist.orig <- Alist |
| 186 | ! |
orderList <- vector("list", length = ngroups)
|
| 187 | ! |
for (g in seq_len(ngroups)) {
|
| 188 | ! |
if (lav_verbose()) {
|
| 189 | ! |
cat(" group = ", g, "\n")
|
| 190 |
} |
|
| 191 | ! |
res0 <- lav_matrix_rotate( |
| 192 | ! |
A = Alist[[g]], |
| 193 | ! |
orthogonal = orthogonal, |
| 194 | ! |
method = method, |
| 195 | ! |
method.args = method.args, |
| 196 | ! |
init.ROT = NULL, |
| 197 | ! |
init.ROT.check = FALSE, |
| 198 | ! |
rstarts = rstarts, |
| 199 | ! |
row.weights = "none", |
| 200 | ! |
std.ov = FALSE, |
| 201 | ! |
ov.var = NULL, |
| 202 | ! |
algorithm = "pairwise", |
| 203 | ! |
reflect = reflect, |
| 204 | ! |
order.lv.by = order.lv.by, |
| 205 | ! |
tol = tol, |
| 206 | ! |
max.iter = max.iter, |
| 207 | ! |
group = g |
| 208 |
) |
|
| 209 | ! |
if (g > 1L) {
|
| 210 |
# reorder factors to align with the first group |
|
| 211 | ! |
order.idx <- lav_efa_find_best_order( |
| 212 | ! |
lambda_ref = Alist[[1]], |
| 213 | ! |
lambda_target = res0$LAMBDA |
| 214 |
) |
|
| 215 | ! |
Alist[[g]] <- res0$LAMBDA[, order.idx, drop = FALSE] |
| 216 | ! |
orderList[[g]] <- order.idx |
| 217 |
} else {
|
|
| 218 | ! |
Alist[[g]] <- res0$LAMBDA |
| 219 | ! |
orderList[[g]] <- res0$order.idx |
| 220 |
} |
|
| 221 |
} # group |
|
| 222 | ||
| 223 |
# # set row.weights |
|
| 224 |
# row.weights <- tolower(row.weights) |
|
| 225 |
# if (row.weights == "default") {
|
|
| 226 |
# # the default is "none", except for varimax |
|
| 227 |
# if (method %in% c("varimax", "promax")) {
|
|
| 228 |
# row.weights <- "kaiser" |
|
| 229 |
# } else {
|
|
| 230 |
# row.weights <- "none" |
|
| 231 |
# } |
|
| 232 |
# } |
|
| 233 | ||
| 234 |
# # check algorithm |
|
| 235 |
# algorithm <- tolower(algorithm) |
|
| 236 |
# if (algorithm %in% c("gpa", "pairwise", "none")) {
|
|
| 237 |
# # nothing to do |
|
| 238 |
# } else {
|
|
| 239 |
# lav_msg_stop(gettext("algorithm must be gpa or pairwise"))
|
|
| 240 |
# } |
|
| 241 | ||
| 242 |
# 1. compute row weigths |
|
| 243 | ||
| 244 |
# # 1.a cov -> cor? |
|
| 245 |
# if (std.ov) {
|
|
| 246 |
# A <- A * 1 / sqrt(ov.var) |
|
| 247 |
# } |
|
| 248 |
# |
|
| 249 |
# if (row.weights == "none") {
|
|
| 250 |
# weights <- rep(1.0, P) |
|
| 251 |
# } else if (row.weights == "kaiser") {
|
|
| 252 |
# weights <- lav_matrix_rotate_kaiser_weights(A) |
|
| 253 |
# } else if (row.weights == "cureton-mulaik") {
|
|
| 254 |
# weights <- lav_matrix_rotate_cm_weights(A) |
|
| 255 |
# } else {
|
|
| 256 |
# lav_msg_stop(gettext("row.weights can be none, kaiser or cureton-mulaik"))
|
|
| 257 |
# } |
|
| 258 |
# A <- A * weights |
|
| 259 | ||
| 260 | ||
| 261 |
# 2. rotate |
|
| 262 | ||
| 263 |
# multiple random starts? |
|
| 264 |
# if (rstarts > 0L) {
|
|
| 265 |
# REP <- lapply(seq_len(rstarts), function(rep) {
|
|
| 266 |
# # random start (always orthogonal) |
|
| 267 |
# # init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE) |
|
| 268 |
# # init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = orthogonal) |
|
| 269 |
# |
|
| 270 |
# if (lav_verbose()) {
|
|
| 271 |
# cat("\n")
|
|
| 272 |
# cat("rstart = ", sprintf("%4d", rep), " start:\n")
|
|
| 273 |
# } |
|
| 274 |
# |
|
| 275 |
# # mg-pairwise + agreement |
|
| 276 |
# rotList <- lav_matrix_rotate_pairwise_mg( |
|
| 277 |
# Alist = Alist, |
|
| 278 |
# orthogonal = orthogonal, |
|
| 279 |
# random.ROT = TRUE, |
|
| 280 |
# method.fname = method.fname, |
|
| 281 |
# method.args = method.args, |
|
| 282 |
# tol = tol, |
|
| 283 |
# max.iter = max.iter |
|
| 284 |
# ) |
|
| 285 |
# info <- attr(rotList, "info") |
|
| 286 |
# attr(rotList, "info") <- NULL |
|
| 287 |
# res <- list(value = info$method.value, rotList = rotList) |
|
| 288 |
# |
|
| 289 |
# if (lav_verbose()) {
|
|
| 290 |
# cat( |
|
| 291 |
# "rstart = ", sprintf("%4d", rep),
|
|
| 292 |
# " end; current crit = ", sprintf("%17.15f", res$value), "\n"
|
|
| 293 |
# ) |
|
| 294 |
# } |
|
| 295 |
# res |
|
| 296 |
# }) |
|
| 297 |
# best.idx <- which.min(sapply(REP, "[[", "value")) |
|
| 298 |
# rotList <- REP[[best.idx]]$rotList |
|
| 299 |
# if (keep.rep) {
|
|
| 300 |
# info <- list(method.value = REP[[best.idx]]$value, REP = REP) |
|
| 301 |
# } else {
|
|
| 302 |
# info <- list(method.value = REP[[best.idx]]$value) |
|
| 303 |
# } |
|
| 304 |
# } else { # just a single rstart
|
|
| 305 |
# initial rotation matrix |
|
| 306 |
# if (is.null(init.ROT)) {
|
|
| 307 |
# init.ROT <- diag(M) |
|
| 308 |
# } |
|
| 309 | ||
| 310 | ! |
if (lav_verbose()) {
|
| 311 | ! |
cat(" mg-pairwise + agreement rotation:\n")
|
| 312 |
} |
|
| 313 | ! |
rotList <- lav_matrix_rotate_pairwise_mg( |
| 314 | ! |
Alist = Alist, |
| 315 | ! |
orthogonal = orthogonal, |
| 316 | ! |
random.ROT = FALSE, |
| 317 | ! |
method.fname = method.fname, |
| 318 | ! |
method.args = method.args, |
| 319 | ! |
mg.agreement.method = mg.agreement.method, |
| 320 | ! |
mg.agreement.weight = mg.agreement.weight, |
| 321 | ! |
tol = tol, |
| 322 | ! |
max.iter = max.iter |
| 323 |
) |
|
| 324 | ! |
info <- attr(rotList, "info") |
| 325 | ! |
attr(rotList, "info") <- NULL |
| 326 |
#} |
|
| 327 | ! |
lambdaList <- vector("list", length = ngroups)
|
| 328 | ! |
for (g in seq_len(ngroups)) {
|
| 329 | ! |
A <- Alist[[g]] |
| 330 | ! |
ROT <- rotList[[g]] |
| 331 | ||
| 332 | ! |
if (orthogonal) {
|
| 333 |
# LAMBDA <- A %*% solve(t(ROT)) |
|
| 334 |
# note: when ROT is orthogonal, solve(t(ROT)) == ROT |
|
| 335 | ! |
LAMBDA <- A %*% ROT |
| 336 |
} else {
|
|
| 337 |
# LAMBDA <- A %*% solve(t(ROT)) |
|
| 338 | ! |
LAMBDA <- t(solve(ROT, t(A))) |
| 339 |
} |
|
| 340 | ||
| 341 |
# # 3. undo row weighting |
|
| 342 |
# LAMBDA <- LAMBDA / weights |
|
| 343 | ||
| 344 |
# # 3.b undo cov -> cor |
|
| 345 |
# if (std.ov) {
|
|
| 346 |
# LAMBDA <- LAMBDA * sqrt(ov.var) |
|
| 347 |
# } |
|
| 348 | ||
| 349 |
# put back in List |
|
| 350 | ! |
lambdaList[[g]] <- LAMBDA |
| 351 |
} # group |
|
| 352 | ||
| 353 |
# re-compute final rotation matrix, using Alist.orig |
|
| 354 |
# because in step 0, we already rotated (per group) |
|
| 355 | ! |
rotList <- vector("list", length = ngroups)
|
| 356 | ! |
if (orthogonal) {
|
| 357 | ! |
for (g in seq_len(ngroups)) {
|
| 358 | ! |
rotList[[g]] <- solve( |
| 359 | ! |
crossprod(Alist.orig[[g]]), |
| 360 | ! |
crossprod(Alist.orig[[g]], lambdaList[[g]]) |
| 361 |
) |
|
| 362 |
} |
|
| 363 |
} else {
|
|
| 364 | ! |
for (g in seq_len(ngroups)) {
|
| 365 |
# to be compatible with GPa |
|
| 366 | ! |
ROTt.inv <- solve( |
| 367 | ! |
crossprod(Alist.orig[[g]]), |
| 368 | ! |
crossprod(Alist.orig[[g]], lambdaList[[g]]) |
| 369 |
) |
|
| 370 | ! |
rotList[[g]] <- solve(t(ROTt.inv)) |
| 371 |
} |
|
| 372 |
} |
|
| 373 | ||
| 374 |
# 6. return results as a list |
|
| 375 | ! |
res <- list( |
| 376 | ! |
lambdaList = lambdaList, rotList = rotList, |
| 377 | ! |
orderList = orderList, |
| 378 | ! |
orthogonal = orthogonal, method = method, |
| 379 | ! |
method.args = method.args, row.weights = "none" |
| 380 |
) |
|
| 381 | ||
| 382 |
# add method info |
|
| 383 | ! |
res <- c(res, info) |
| 384 | ||
| 385 | ! |
res |
| 386 |
} |
|
| 387 | ||
| 388 | ||
| 389 |
# pairwise rotation algorithm with direct line search |
|
| 390 |
# (see lav_matrix_rotate_pairwise() |
|
| 391 |
# |
|
| 392 |
# but adapted to handle multiple groups + an agreement criterion |
|
| 393 |
# |
|
| 394 |
lav_matrix_rotate_pairwise_mg <- function(Alist = NULL, # original matrices |
|
| 395 |
orthogonal = FALSE, |
|
| 396 |
random.ROT = FALSE, |
|
| 397 |
method.fname = NULL, # crit function |
|
| 398 |
method.args = list(), # method args |
|
| 399 |
tol = 1e-8, |
|
| 400 |
mg.agreement.weight = 0.50, |
|
| 401 |
mg.agreement.method = "procrustes", |
|
| 402 |
scale = TRUE, |
|
| 403 |
max.iter = 1000L) {
|
|
| 404 |
# first group is 'A' |
|
| 405 | ! |
A <- Alist[[1]] |
| 406 | ! |
ngroups <- length(Alist) |
| 407 | ||
| 408 |
# number of columns |
|
| 409 | ! |
M <- ncol(A) |
| 410 | ||
| 411 |
# initial LAMBDA + PSI |
|
| 412 | ! |
lambdaList <- Alist |
| 413 | ! |
psiList <- rep(list(diag(M)), ngroups) |
| 414 | ||
| 415 |
# random initial rotation? |
|
| 416 | ! |
if (random.ROT) {
|
| 417 | ! |
for (g in seq_len(ngroups)) {
|
| 418 | ! |
init.ROT <- lav_matrix_rotate_gen(M = M, orthogonal = TRUE) |
| 419 | ! |
if (orthogonal) {
|
| 420 | ! |
lambdaList[[g]] <- Alist[[g]] %*% init.ROT |
| 421 |
} else {
|
|
| 422 | ! |
lambdaList[[g]] <- t(solve(init.ROT, t(Alist[[g]]))) |
| 423 | ! |
psiList[[g]] <- crossprod(init.ROT) |
| 424 |
} |
|
| 425 |
} |
|
| 426 |
} |
|
| 427 | ||
| 428 |
# using the current LAMBDA, evaluate the user-specified |
|
| 429 |
# rotation criteron; return Q (the criterion) only |
|
| 430 | ! |
Q.current <- lav_matrix_rotate_mg_agreement( |
| 431 | ! |
lambdaList = lambdaList, method.fname = method.fname, |
| 432 | ! |
method.args = method.args, |
| 433 | ! |
mg.agreement.method = mg.agreement.method, |
| 434 | ! |
w = mg.agreement.weight, scale = scale |
| 435 |
) |
|
| 436 | ||
| 437 |
# if verbose, print |
|
| 438 | ! |
if (lav_verbose()) {
|
| 439 | ! |
Q.mg <- attr(Q.current, "Q.mg") |
| 440 | ! |
A.mg <- attr(Q.current, "A.mg") |
| 441 | ! |
cat( |
| 442 | ! |
" iter = ", sprintf("%4d", 0),
|
| 443 | ! |
" Q = ", sprintf("%13.11f", Q.current),
|
| 444 | ! |
" Q.rot = ", sprintf("%13.11f", Q.mg),
|
| 445 | ! |
" Q.agr = ", sprintf("%13.11f", A.mg), "\n"
|
| 446 |
) |
|
| 447 |
} |
|
| 448 | ||
| 449 |
# plane combinations |
|
| 450 | ! |
if (orthogonal) {
|
| 451 | ! |
PLANE <- utils::combn(M, 2) |
| 452 |
} else {
|
|
| 453 | ! |
tmp <- utils::combn(M, 2) |
| 454 | ! |
PLANE <- cbind(tmp, tmp[c(2, 1), , drop = FALSE]) |
| 455 |
} |
|
| 456 | ||
| 457 |
# define objective function -- orthogonal |
|
| 458 | ! |
objf_orth <- function(g = 1L, theta = 0, A = NULL, col1 = 0L, col2 = 0L) {
|
| 459 |
# construct ROT |
|
| 460 | ! |
ROT <- diag(M) |
| 461 | ! |
ROT[col1, col1] <- base::cos(theta) |
| 462 | ! |
ROT[col1, col2] <- base::sin(theta) |
| 463 | ! |
ROT[col2, col1] <- -1 * base::sin(theta) |
| 464 | ! |
ROT[col2, col2] <- base::cos(theta) |
| 465 | ||
| 466 |
# rotate |
|
| 467 | ! |
lambdaList[[g]] <- A %*% ROT |
| 468 | ||
| 469 |
# evaluate criterion |
|
| 470 | ! |
Q <- lav_matrix_rotate_mg_agreement( |
| 471 | ! |
lambdaList = lambdaList, method.fname = method.fname, |
| 472 | ! |
method.args = method.args, mg.agreement.method = mg.agreement.method, |
| 473 | ! |
w = mg.agreement.weight, scale = scale |
| 474 |
) |
|
| 475 | ||
| 476 | ! |
Q |
| 477 |
} |
|
| 478 | ||
| 479 |
# define objective function -- oblique |
|
| 480 | ! |
objf_obliq <- function(g = 1, delta = 0, A = NULL, col1 = 0L, col2 = 0L, |
| 481 | ! |
psi12 = 0) {
|
| 482 |
# construct ROT |
|
| 483 | ! |
ROT <- diag(M) |
| 484 | ||
| 485 |
# gamma |
|
| 486 | ! |
gamma2 <- 1 + (2 * delta * psi12) + (delta * delta) |
| 487 | ||
| 488 | ! |
ROT[col1, col1] <- sqrt(abs(gamma2)) |
| 489 | ! |
ROT[col1, col2] <- -1 * delta |
| 490 | ! |
ROT[col2, col1] <- 0 |
| 491 | ! |
ROT[col2, col2] <- 1 |
| 492 | ||
| 493 |
# rotate |
|
| 494 | ! |
lambdaList[[g]] <- A %*% ROT |
| 495 | ||
| 496 |
# evaluate criterion |
|
| 497 | ! |
Q <- lav_matrix_rotate_mg_agreement( |
| 498 | ! |
lambdaList = lambdaList, method.fname = method.fname, |
| 499 | ! |
method.args = method.args, mg.agreement.method = mg.agreement.method, |
| 500 | ! |
w = mg.agreement.weight, scale = scale |
| 501 |
) |
|
| 502 | ||
| 503 | ! |
Q |
| 504 |
} |
|
| 505 | ||
| 506 |
# start iterations |
|
| 507 | ! |
converged <- FALSE |
| 508 | ! |
Q.old <- Q.current |
| 509 | ! |
for (iter in seq_len(max.iter)) {
|
| 510 |
# for each group |
|
| 511 | ! |
for (g in seq_len(ngroups)) {
|
| 512 |
# rotate - one cycle |
|
| 513 | ! |
for (pl in seq_len(ncol(PLANE))) {
|
| 514 |
# choose plane |
|
| 515 | ! |
col1 <- PLANE[1, pl] |
| 516 | ! |
col2 <- PLANE[2, pl] |
| 517 | ||
| 518 |
# optimize |
|
| 519 | ! |
if (orthogonal) {
|
| 520 | ! |
out <- optimize( |
| 521 | ! |
f = objf_orth, interval = c(-pi / 4, +pi / 4), |
| 522 | ! |
g = g, |
| 523 | ! |
A = lambdaList[[g]], col1 = col1, col2 = col2, |
| 524 | ! |
maximum = FALSE, tol = .Machine$double.eps^0.25 |
| 525 |
) |
|
| 526 |
# best rotation - for this plane |
|
| 527 | ! |
theta <- out$minimum |
| 528 | ||
| 529 |
# construct ROT |
|
| 530 | ! |
ROT <- diag(M) |
| 531 | ! |
ROT[col1, col1] <- base::cos(theta) |
| 532 | ! |
ROT[col1, col2] <- base::sin(theta) |
| 533 | ! |
ROT[col2, col1] <- -1 * base::sin(theta) |
| 534 | ! |
ROT[col2, col2] <- base::cos(theta) |
| 535 |
} else {
|
|
| 536 | ! |
psi12 <- psiList[[g]][col1, col2] |
| 537 | ! |
out <- optimize( |
| 538 | ! |
f = objf_obliq, interval = c(-1, +1), |
| 539 | ! |
g = g, |
| 540 | ! |
A = lambdaList[[g]], col1 = col1, col2 = col2, |
| 541 | ! |
psi12 = psi12, |
| 542 | ! |
maximum = FALSE, tol = .Machine$double.eps^0.25 |
| 543 |
) |
|
| 544 | ||
| 545 |
# best rotation - for this plane |
|
| 546 | ! |
delta <- out$minimum |
| 547 | ||
| 548 |
# construct ROT |
|
| 549 | ! |
ROT <- diag(M) |
| 550 | ||
| 551 |
# gamma |
|
| 552 | ! |
gamma2 <- 1 + (2 * delta * psi12) + (delta * delta) |
| 553 | ! |
gamma <- sqrt(abs(gamma2)) |
| 554 | ||
| 555 | ! |
ROT[col1, col1] <- gamma |
| 556 | ! |
ROT[col1, col2] <- -1 * delta |
| 557 | ! |
ROT[col2, col1] <- 0 |
| 558 | ! |
ROT[col2, col2] <- 1 |
| 559 |
} |
|
| 560 | ||
| 561 |
# rotate |
|
| 562 | ! |
lambdaList[[g]] <- lambdaList[[g]] %*% ROT |
| 563 | ||
| 564 | ! |
if (!orthogonal) {
|
| 565 | ! |
PSI <- psiList[[g]] |
| 566 |
# rotate PSI |
|
| 567 | ! |
PSI[col1, ] <- (1 / gamma) * PSI[col1, ] + (delta / gamma) * PSI[col2, ] |
| 568 | ! |
PSI[, col1] <- PSI[col1, ] |
| 569 | ! |
PSI[col1, col1] <- 1 |
| 570 | ! |
psiList[[g]] <- PSI |
| 571 |
} |
|
| 572 |
} # all planes |
|
| 573 |
} # ngroups |
|
| 574 | ||
| 575 |
# check for convergence |
|
| 576 | ! |
Q.current <- lav_matrix_rotate_mg_agreement( |
| 577 | ! |
lambdaList = lambdaList, method.fname = method.fname, |
| 578 | ! |
method.args = method.args, mg.agreement.method = mg.agreement.method, |
| 579 | ! |
w = mg.agreement.weight, scale = scale |
| 580 |
) |
|
| 581 | ||
| 582 |
# absolute change in Q |
|
| 583 | ! |
diff <- abs(Q.old - Q.current) |
| 584 | ||
| 585 |
# if verbose, print |
|
| 586 | ! |
if (lav_verbose()) {
|
| 587 | ! |
Q.mg <- attr(Q.current, "Q.mg") |
| 588 | ! |
A.mg <- attr(Q.current, "A.mg") |
| 589 | ! |
cat( |
| 590 | ! |
" iter = ", sprintf("%4d", iter),
|
| 591 | ! |
" Q = ", sprintf("%13.11f", Q.current),
|
| 592 | ! |
" Q.rot = ", sprintf("%13.11f", Q.mg),
|
| 593 | ! |
" Q.agr = ", sprintf("%13.11f", A.mg),
|
| 594 | ! |
" change = ", sprintf("%13.11f", diff), "\n"
|
| 595 |
) |
|
| 596 |
} |
|
| 597 | ||
| 598 | ! |
if (!is.finite(diff)) {
|
| 599 |
# something went wrong ... bail out |
|
| 600 | ! |
lav_msg_warn(gettextf("mg-pairwise rotation algorithm failed!"))
|
| 601 | ! |
break |
| 602 | ! |
} else if (diff < tol) {
|
| 603 | ! |
converged <- TRUE |
| 604 | ! |
break |
| 605 |
} else {
|
|
| 606 | ! |
Q.old <- Q.current |
| 607 |
} |
|
| 608 |
} # iter |
|
| 609 | ||
| 610 |
# warn if no convergence |
|
| 611 | ! |
if (!converged) {
|
| 612 | ! |
lav_msg_warn(gettextf( |
| 613 | ! |
"mg-pairwise rotation algorithm did not converge after %s iterations", |
| 614 | ! |
max.iter |
| 615 |
)) |
|
| 616 |
} |
|
| 617 | ||
| 618 |
# compute final rotation matrix |
|
| 619 | ! |
rotList <- vector("list", length = ngroups)
|
| 620 | ! |
if (orthogonal) {
|
| 621 | ! |
for (g in seq_len(ngroups)) {
|
| 622 | ! |
rotList[[g]] <- solve( |
| 623 | ! |
crossprod(Alist[[g]]), |
| 624 | ! |
crossprod(Alist[[g]], lambdaList[[g]]) |
| 625 |
) |
|
| 626 |
} |
|
| 627 |
} else {
|
|
| 628 | ! |
for (g in seq_len(ngroups)) {
|
| 629 |
# to be compatible with GPa |
|
| 630 | ! |
ROTt.inv <- solve( |
| 631 | ! |
crossprod(Alist[[g]]), |
| 632 | ! |
crossprod(Alist[[g]], lambdaList[[g]]) |
| 633 |
) |
|
| 634 | ! |
rotList[[g]] <- solve(t(ROTt.inv)) |
| 635 |
} |
|
| 636 |
} |
|
| 637 | ||
| 638 |
# algorithm information |
|
| 639 | ! |
info <- list( |
| 640 | ! |
algorithm = "mg-pairwise", |
| 641 | ! |
iter = iter, |
| 642 | ! |
converged = converged, |
| 643 | ! |
method.value = Q.current |
| 644 |
) |
|
| 645 | ||
| 646 | ! |
attr(rotList, "info") <- info |
| 647 | ||
| 648 | ! |
rotList |
| 649 |
} |
| 1 |
# compute model implied statistics |
|
| 2 |
# per block |
|
| 3 | ||
| 4 |
# YR 7 May 2022: add cov.x and mean.x if conditional.x (so that we do |
|
| 5 |
# no longer depend on SampleStats) |
|
| 6 | ||
| 7 |
lav_model_implied <- function(lavmodel = NULL, GLIST = NULL, delta = TRUE) {
|
|
| 8 | 7839x |
stopifnot(inherits(lavmodel, "lavModel")) |
| 9 | ||
| 10 |
# state or final? |
|
| 11 | 180x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 12 | ||
| 13 |
# model-implied variance/covariance matrix ('sigma hat')
|
|
| 14 | 7839x |
Sigma.hat <- lav_model_sigma( |
| 15 | 7839x |
lavmodel = lavmodel, GLIST = GLIST, |
| 16 | 7839x |
delta = delta |
| 17 |
) |
|
| 18 | ||
| 19 |
# model-implied mean structure ('mu hat')
|
|
| 20 | 7839x |
if (lavmodel@meanstructure) {
|
| 21 | 6490x |
Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST) |
| 22 |
} else {
|
|
| 23 | 1349x |
Mu.hat <- vector("list", length = lavmodel@nblocks)
|
| 24 |
} |
|
| 25 | ||
| 26 |
# if conditional.x, slopes, cov.x, mean.x |
|
| 27 | 7839x |
if (lavmodel@conditional.x) {
|
| 28 | 5819x |
SLOPES <- lav_model_pi(lavmodel = lavmodel, GLIST = GLIST) |
| 29 | ||
| 30 |
# per block, because for some blocks, cov.x may not exist |
|
| 31 | 5819x |
COV.X <- vector("list", lavmodel@nblocks)
|
| 32 | 5819x |
MEAN.X <- vector("list", lavmodel@nblocks)
|
| 33 | 5819x |
for (b in seq_len(lavmodel@nblocks)) {
|
| 34 | 5819x |
mm.in.block <- (seq_len(lavmodel@nmat[b]) + |
| 35 | 5819x |
cumsum(c(0, lavmodel@nmat))[b]) |
| 36 | 5819x |
MLIST <- lavmodel@GLIST[mm.in.block] |
| 37 | 5819x |
cov.x.idx <- which(names(MLIST) == "cov.x") |
| 38 | 5819x |
if (length(cov.x.idx) > 0L) {
|
| 39 | 5819x |
COV.X[[b]] <- MLIST[[cov.x.idx]] |
| 40 |
} else {
|
|
| 41 | ! |
COV.X[[b]] <- matrix(0, 0L, 0L) |
| 42 |
} |
|
| 43 | 5819x |
mean.x.idx <- which(names(MLIST) == "mean.x") |
| 44 | 5819x |
if (length(mean.x.idx) > 0L) {
|
| 45 | 5819x |
MEAN.X[[b]] <- MLIST[[mean.x.idx]] |
| 46 |
} else {
|
|
| 47 | ! |
MEAN.X[[b]] <- matrix(0, 0L, 1L) |
| 48 |
} |
|
| 49 |
} |
|
| 50 |
} else {
|
|
| 51 | 2020x |
SLOPES <- vector("list", length = lavmodel@nblocks)
|
| 52 |
} |
|
| 53 | ||
| 54 |
# if categorical, model-implied thresholds |
|
| 55 | 7839x |
if (lavmodel@categorical) {
|
| 56 | 5819x |
TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST) |
| 57 |
} else {
|
|
| 58 | 2020x |
TH <- vector("list", length = lavmodel@nblocks)
|
| 59 |
} |
|
| 60 | ||
| 61 | 7839x |
if (lavmodel@group.w.free) {
|
| 62 | ! |
w.idx <- which(names(lavmodel@GLIST) == "gw") |
| 63 | ! |
GW <- unname(GLIST[w.idx]) |
| 64 | ! |
GW <- lapply(GW, as.numeric) |
| 65 |
} else {
|
|
| 66 | 7839x |
GW <- vector("list", length = lavmodel@nblocks)
|
| 67 |
} |
|
| 68 | ||
| 69 | 7839x |
if (lavmodel@conditional.x) {
|
| 70 | 5819x |
implied <- list( |
| 71 | 5819x |
res.cov = Sigma.hat, res.int = Mu.hat, |
| 72 | 5819x |
res.slopes = SLOPES, cov.x = COV.X, mean.x = MEAN.X, |
| 73 | 5819x |
res.th = TH, group.w = GW |
| 74 |
) |
|
| 75 |
} else {
|
|
| 76 | 2020x |
implied <- list(cov = Sigma.hat, mean = Mu.hat, th = TH, group.w = GW) |
| 77 |
} |
|
| 78 | ||
| 79 | 7839x |
implied |
| 80 |
} |
|
| 81 | ||
| 82 |
# convert 'conditional.x = TRUE' to 'conditional.x = FALSE' |
|
| 83 |
lav_model_implied_cond2uncond <- function(lavimplied) {
|
|
| 84 |
# check for res.cov |
|
| 85 | 7x |
if (is.null(lavimplied$res.cov[[1]])) {
|
| 86 |
# already unconditional |
|
| 87 | 7x |
return(lavimplied) |
| 88 |
} else {
|
|
| 89 | ! |
nblocks <- length(lavimplied$res.cov) |
| 90 |
} |
|
| 91 | ||
| 92 | ! |
COV <- vector("list", length = nblocks)
|
| 93 | ! |
MEAN <- vector("list", length = nblocks)
|
| 94 | ||
| 95 |
# reconstruct COV/MEAN per block |
|
| 96 | ! |
for (b in seq_len(nblocks)) {
|
| 97 | ! |
res.Sigma <- lavimplied$res.cov[[b]] |
| 98 | ! |
res.slopes <- lavimplied$res.slopes[[b]] |
| 99 | ! |
res.int <- lavimplied$res.int[[b]] |
| 100 | ! |
S.xx <- lavimplied$cov.x[[b]] |
| 101 | ! |
M.x <- lavimplied$mean.x[[b]] |
| 102 | ||
| 103 | ! |
S.yx <- res.slopes %*% S.xx |
| 104 | ! |
S.xy <- t(S.yx) |
| 105 | ! |
S.yy <- res.Sigma + tcrossprod(S.yx, res.slopes) |
| 106 | ! |
COV[[b]] <- rbind(cbind(S.yy, S.yx), cbind(S.xy, S.xx)) |
| 107 | ||
| 108 | ! |
Mu.y <- as.vector(res.int + res.slopes %*% M.x) |
| 109 | ! |
Mu.x <- as.vector(M.x) |
| 110 | ! |
MEAN[[b]] <- matrix(c(Mu.y, Mu.x), ncol = 1L) |
| 111 |
} |
|
| 112 | ||
| 113 |
# we ignore res.th for now, as we do not support categorical data |
|
| 114 |
# in the two-level setting anyway |
|
| 115 | ! |
implied <- list( |
| 116 | ! |
cov = COV, mean = MEAN, th = lavimplied$res.th, |
| 117 | ! |
group.w = lavimplied$group.w |
| 118 |
) |
|
| 119 | ||
| 120 | ! |
implied |
| 121 |
} |
| 1 |
# various rotation criteria and their gradients |
|
| 2 |
# YR 05 April 2019: initial version |
|
| 3 |
# YR 14 June 2019: add more rotation criteria |
|
| 4 |
# YR 22 Dec 2025: add multigroup rotation criteria |
|
| 5 | ||
| 6 |
# references: |
|
| 7 |
# |
|
| 8 |
# Bernaards, C. A., & Jennrich, R. I. (2005). Gradient projection algorithms |
|
| 9 |
# and software for arbitrary rotation criteria in factor analysis. Educational |
|
| 10 |
# and Psychological Measurement, 65(5), 676-696. |
|
| 11 |
# old website: http://web.archive.org/web/20180708170331/http://www.stat.ucla.edu/research/gpa/splusfunctions.net |
|
| 12 |
# |
|
| 13 |
# Browne, M. W. (2001). An overview of analytic rotation in exploratory factor |
|
| 14 |
# analysis. Multivariate behavioral research, 36(1), 111-150. |
|
| 15 |
# |
|
| 16 |
# Mulaik, S. A. (2010). Foundations of factor analysis (Second Edition). |
|
| 17 |
# Boca Raton: Chapman and Hall/CRC. |
|
| 18 |
# |
|
| 19 |
# De Roover, K., & Vermunt, J. K. (2019). On the exploratory road to unraveling |
|
| 20 |
# factor loading non-invariance: A new multigroup rotation approach. Structural |
|
| 21 |
# Equation Modeling: A Multidisciplinary Journal, 26(6), 905-923. |
|
| 22 | ||
| 23 |
# Note: this is YR's implementation, not a copy of the GPArotation |
|
| 24 |
# package |
|
| 25 |
# |
|
| 26 |
# Why did I write my own functions (and not use the GPArotation): |
|
| 27 |
# - to better understand what is going on |
|
| 28 |
# - to have direct access to the gradient functions |
|
| 29 |
# - to avoid yet another dependency |
|
| 30 |
# - to simplify further experiments |
|
| 31 | ||
| 32 | ||
| 33 |
# Orthomax family (Harman, 1960) |
|
| 34 |
# |
|
| 35 |
# gamma = 0 -> quartimax |
|
| 36 |
# gamma = 1/2 -> biquartimax |
|
| 37 |
# gamma = 1/P -> equamax |
|
| 38 |
# gamma = 1 -> varimax |
|
| 39 |
# |
|
| 40 |
lav_matrix_rotate_orthomax <- function(LAMBDA = NULL, orthomax.gamma = 1, |
|
| 41 |
..., grad = FALSE) {
|
|
| 42 | ! |
L2 <- LAMBDA * LAMBDA |
| 43 |
# center L2 column-wise |
|
| 44 | ! |
cL2 <- t(t(L2) - orthomax.gamma * colMeans(L2)) |
| 45 | ! |
out <- -1 * sum(L2 * cL2) / 4 |
| 46 | ||
| 47 | ! |
if (grad) {
|
| 48 | ! |
attr(out, "grad") <- -1 * LAMBDA * cL2 |
| 49 |
} |
|
| 50 | ||
| 51 | ! |
out |
| 52 |
} |
|
| 53 | ||
| 54 |
# Crawford-Ferguson (1970) family |
|
| 55 |
# |
|
| 56 |
# combine penalization for 1) row complexity, and 2) column complexity |
|
| 57 |
# if combined with orthogonal rotation, this is equivalent to the |
|
| 58 |
# orthomax family: |
|
| 59 |
# |
|
| 60 |
# quartimax -> gamma = 0 (only row complexity) |
|
| 61 |
# varimax -> gamma = 1/nrow |
|
| 62 |
# equamax -> gamma = ncol/(2*nrow) |
|
| 63 |
# parsimax -> gamma = (ncol - 1)/(nrow + ncol - 2) |
|
| 64 |
# factor parsimony -> gamma = 1 (only column complexity) |
|
| 65 |
# |
|
| 66 |
# the Crawford-Ferguson family is also equivalent to the oblimin family |
|
| 67 |
# if the latter is restricted to orthogonal rotation |
|
| 68 |
# |
|
| 69 |
lav_matrix_rotate_cf <- function(LAMBDA = NULL, cf.gamma = 0, ..., |
|
| 70 |
grad = FALSE) {
|
|
| 71 |
# check if gamma is between 0 and 1? |
|
| 72 | ! |
nRow <- nrow(LAMBDA) |
| 73 | ! |
nCol <- ncol(LAMBDA) |
| 74 | ! |
ROW1 <- matrix(1.0, nCol, nCol) |
| 75 | ! |
diag(ROW1) <- 0.0 |
| 76 | ! |
COL1 <- matrix(1.0, nRow, nRow) |
| 77 | ! |
diag(COL1) <- 0.0 |
| 78 | ||
| 79 | ! |
L2 <- LAMBDA * LAMBDA |
| 80 | ! |
LR <- L2 %*% ROW1 |
| 81 | ! |
LC <- COL1 %*% L2 |
| 82 | ||
| 83 | ! |
f1 <- sum(L2 * LR) / 4 |
| 84 | ! |
f2 <- sum(L2 * LC) / 4 |
| 85 | ||
| 86 | ! |
out <- (1 - cf.gamma) * f1 + cf.gamma * f2 |
| 87 | ||
| 88 | ! |
if (grad) {
|
| 89 | ! |
attr(out, "grad") <- ((1 - cf.gamma) * LAMBDA * LR) + |
| 90 | ! |
(cf.gamma * LAMBDA * LC) |
| 91 |
} |
|
| 92 | ||
| 93 | ! |
out |
| 94 |
} |
|
| 95 | ||
| 96 |
# Oblimin family (Carroll, 1960; Harman, 1976) |
|
| 97 |
# |
|
| 98 |
# quartimin -> gamma = 0 |
|
| 99 |
# biquartimin -> gamma = 1/2 |
|
| 100 |
# covarimin -> gamma = 1 |
|
| 101 |
# |
|
| 102 |
# if combined with orthogonal rotation, this is equivalent to the |
|
| 103 |
# orthomax family (they have the same optimizers): |
|
| 104 |
# |
|
| 105 |
# gamma = 0 -> quartimax |
|
| 106 |
# gamma = 1/2 -> biquartimax |
|
| 107 |
# gamma = 1 -> varimax |
|
| 108 |
# gamma = P/2 -> equamax |
|
| 109 |
# |
|
| 110 |
lav_matrix_rotate_oblimin <- function(LAMBDA = NULL, oblimin.gamma = 0, ..., |
|
| 111 |
grad = FALSE) {
|
|
| 112 | ! |
nRow <- nrow(LAMBDA) |
| 113 | ! |
nCol <- ncol(LAMBDA) |
| 114 | ! |
ROW1 <- matrix(1.0, nCol, nCol) |
| 115 | ! |
diag(ROW1) <- 0.0 |
| 116 | ||
| 117 | ! |
L2 <- LAMBDA * LAMBDA |
| 118 | ! |
LR <- L2 %*% ROW1 |
| 119 | ! |
Jp <- matrix(1, nRow, nRow) / nRow |
| 120 | ||
| 121 |
# see Jennrich (2002, p. 11) |
|
| 122 | ! |
tmp <- (diag(nRow) - oblimin.gamma * Jp) %*% LR |
| 123 | ||
| 124 |
# same as t( t(L2) - gamma * colMeans(L2) ) %*% ROW1 |
|
| 125 | ||
| 126 | ! |
out <- sum(L2 * tmp) / 4 |
| 127 | ||
| 128 | ! |
if (grad) {
|
| 129 | ! |
attr(out, "grad") <- LAMBDA * tmp |
| 130 |
} |
|
| 131 | ||
| 132 | ! |
out |
| 133 |
} |
|
| 134 | ||
| 135 | ||
| 136 |
# quartimax criterion |
|
| 137 |
# Carroll (1953); Saunders (1953) Neuhaus & Wrigley (1954); Ferguson (1954) |
|
| 138 |
# we use here the equivalent 'Ferguson, 1954' variant |
|
| 139 |
# (See Mulaik 2010, p. 303) |
|
| 140 |
lav_matrix_rotate_quartimax <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 141 | ! |
L2 <- LAMBDA * LAMBDA |
| 142 | ! |
out <- -1 * sum(L2 * L2) / 4 |
| 143 | ||
| 144 | ! |
if (grad) {
|
| 145 | ! |
attr(out, "grad") <- -1 * LAMBDA * L2 |
| 146 |
} |
|
| 147 | ||
| 148 | ! |
out |
| 149 |
} |
|
| 150 | ||
| 151 | ||
| 152 |
# varimax criterion |
|
| 153 |
# Kaiser (1958, 1959) |
|
| 154 |
# |
|
| 155 |
# special case of the Orthomax family (Harman, 1960), where gamma = 1 |
|
| 156 |
# see Jennrich (2001, p. 296) |
|
| 157 |
lav_matrix_rotate_varimax <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 158 | ! |
L2 <- LAMBDA * LAMBDA |
| 159 |
# center L2 column-wise |
|
| 160 | ! |
cL2 <- t(t(L2) - colMeans(L2)) |
| 161 | ! |
out <- -1 * abs(sum(L2 * cL2)) / 4 # abs needed? |
| 162 | ||
| 163 | ! |
if (grad) {
|
| 164 | ! |
attr(out, "grad") <- -1 * LAMBDA * cL2 |
| 165 |
} |
|
| 166 | ||
| 167 | ! |
out |
| 168 |
} |
|
| 169 | ||
| 170 |
# quartimin criterion (part of Carroll's oblimin family |
|
| 171 |
lav_matrix_rotate_quartimin <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 172 | ! |
nCol <- ncol(LAMBDA) |
| 173 | ! |
ROW1 <- matrix(1.0, nCol, nCol) |
| 174 | ! |
diag(ROW1) <- 0.0 |
| 175 | ||
| 176 | ! |
L2 <- LAMBDA * LAMBDA |
| 177 | ! |
LR <- L2 %*% ROW1 |
| 178 | ||
| 179 | ! |
out <- sum(L2 * LR) / 4 |
| 180 | ||
| 181 | ! |
if (grad) {
|
| 182 | ! |
attr(out, "grad") <- LAMBDA * LR |
| 183 |
} |
|
| 184 | ||
| 185 | ! |
out |
| 186 |
} |
|
| 187 | ||
| 188 |
# Browne's (2001) version of Yates (1984) geomin criterion |
|
| 189 |
# |
|
| 190 |
# we use the exp/log trick as in Bernaard & Jennrich (2005, p. 687) |
|
| 191 |
lav_matrix_rotate_geomin <- function(LAMBDA = NULL, geomin.epsilon = 0.01, |
|
| 192 |
..., grad = FALSE) {
|
|
| 193 | 12272x |
nCol <- ncol(LAMBDA) |
| 194 | ||
| 195 | 12272x |
L2 <- LAMBDA * LAMBDA |
| 196 | 12272x |
L2 <- L2 + geomin.epsilon |
| 197 | ||
| 198 | 12272x |
if (geomin.epsilon < sqrt(.Machine$double.eps)) {
|
| 199 |
# Yates's original formula |
|
| 200 | ! |
tmp <- apply(L2, 1, prod)^(1 / nCol) |
| 201 |
} else {
|
|
| 202 | 12272x |
tmp <- exp(rowSums(log(L2)) / nCol) |
| 203 |
} |
|
| 204 | ||
| 205 | 12272x |
out <- sum(tmp) |
| 206 | ||
| 207 | 12272x |
if (grad) {
|
| 208 | 12272x |
attr(out, "grad") <- (2 / nCol) * LAMBDA / L2 * tmp |
| 209 |
} |
|
| 210 | ||
| 211 | 12272x |
out |
| 212 |
} |
|
| 213 | ||
| 214 |
# simple entropy |
|
| 215 |
# seems to only work for orthogonal rotation |
|
| 216 |
lav_matrix_rotate_entropy <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 217 | ! |
L2 <- LAMBDA * LAMBDA |
| 218 | ||
| 219 |
# handle zero elements -> replace by '1', so log(1) == 0 |
|
| 220 | ! |
L2[L2 == 0] <- 1 |
| 221 | ||
| 222 | ! |
out <- -1 * sum(L2 * log(L2)) / 2 |
| 223 | ||
| 224 | ! |
if (grad) {
|
| 225 | ! |
attr(out, "grad") <- -LAMBDA * log(L2) - LAMBDA |
| 226 |
} |
|
| 227 | ||
| 228 | ! |
out |
| 229 |
} |
|
| 230 | ||
| 231 |
# McCammon's (1966) Minimum Entropy Criterion |
|
| 232 |
# |
|
| 233 |
# for p-vector x, where x > 0 and sum(x) = 1, we have |
|
| 234 |
# - entropy(x) == 0, if there is only one 1, and all zeroes |
|
| 235 |
# - entropy(x) == max == log(p) if all elements are 1/p |
|
| 236 |
# - entropy(x) is similar as complexity(x), but also measure of equality |
|
| 237 |
# of elements of x |
|
| 238 |
# |
|
| 239 |
# works only ok with orthogonal rotation! |
|
| 240 | ||
| 241 |
lav_matrix_rotate_mccammon <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 242 | ! |
nCol <- ncol(LAMBDA) |
| 243 | ! |
nRow <- nrow(LAMBDA) |
| 244 | ! |
L2 <- LAMBDA * LAMBDA |
| 245 | ||
| 246 |
# entropy function (Browne, 2001, eq 9) |
|
| 247 | ! |
f_entropy <- function(x) {
|
| 248 | ! |
-1 * sum(ifelse(x > 0, x * log(x), 0)) |
| 249 |
} |
|
| 250 | ||
| 251 |
# sums of rows/columns/all |
|
| 252 | ! |
sumi. <- rowSums(L2) |
| 253 | ! |
sum.j <- colSums(L2) |
| 254 | ! |
sum.. <- sum(L2) |
| 255 | ||
| 256 | ||
| 257 | ! |
Q1 <- f_entropy(t(L2) / sum.j) # encouraging columns with few large, |
| 258 |
# and many small elements |
|
| 259 | ! |
Q2 <- f_entropy(sum.j / sum..) # encouraging equal column sums |
| 260 | ||
| 261 |
# minimize |
|
| 262 | ! |
out <- log(Q1) - log(Q2) |
| 263 | ||
| 264 | ! |
if (grad) { # See Bernaards and Jennrich 2005 page 685+686
|
| 265 | ! |
H <- -(log(t(t(L2) / sum.j)) + 1) |
| 266 | ! |
G1 <- t(t(H) / sum.j - rowSums(t(L2 * H) / (sum.j * sum.j))) |
| 267 | ||
| 268 | ! |
h <- -(log(sum.j / sum..) + 1) |
| 269 | ! |
alpha <- as.numeric(h %*% sum.j) / (sum.. * sum..) # paper divides by |
| 270 |
# sum.., not sum..^2?? |
|
| 271 | ! |
G2 <- matrix(h / sum.. - alpha, nRow, nCol, byrow = TRUE) |
| 272 | ||
| 273 | ! |
attr(out, "grad") <- 2 * LAMBDA * (G1 / Q1 - G2 / Q2) |
| 274 |
} |
|
| 275 | ||
| 276 | ! |
out |
| 277 |
} |
|
| 278 | ||
| 279 | ||
| 280 |
# Infomax |
|
| 281 |
# McKeon (1968, unpublished) and Browne (2001) |
|
| 282 |
# Treat LAMBDA^2 as a contingency table, and use simplicity function based |
|
| 283 |
# on tests for association; most effective was LRT for association |
|
| 284 |
# (see Agresti, 1990, eq 3.13) which is maximized for max simplicity |
|
| 285 |
# |
|
| 286 |
# McKeon: criterion may be regarded as a measure of information about row |
|
| 287 |
# categories conveyed by column categories (and vice versa); hence infomax |
|
| 288 | ||
| 289 |
# - favors perfect cluster |
|
| 290 |
# - discourages general factor |
|
| 291 |
# - both for orthogonal and oblique rotation |
|
| 292 | ||
| 293 |
# |
|
| 294 |
# Note: typo in Browne (2001), see last paragraph of Bernaards and |
|
| 295 |
# Jennrich (2005) page 684 |
|
| 296 |
lav_matrix_rotate_infomax <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 297 | ! |
nCol <- ncol(LAMBDA) |
| 298 | ! |
nRow <- nrow(LAMBDA) |
| 299 | ! |
L2 <- LAMBDA * LAMBDA |
| 300 | ||
| 301 |
# entropy function (Browne, 2001, eq 9) |
|
| 302 | ! |
f_entropy <- function(x) {
|
| 303 | ! |
-1 * sum(ifelse(x > 0, x * log(x), 0)) |
| 304 |
} |
|
| 305 | ||
| 306 |
# sums of rows/columns/all |
|
| 307 | ! |
sumi. <- rowSums(L2) |
| 308 | ! |
sum.j <- colSums(L2) |
| 309 | ! |
sum.. <- sum(L2) |
| 310 | ||
| 311 | ! |
Q1 <- f_entropy(L2 / sum..) # Bernaards & Jennrich version!! (Browne |
| 312 |
# divides by sum.j, like in McCammon) |
|
| 313 | ! |
Q2 <- f_entropy(sum.j / sum..) |
| 314 | ! |
Q3 <- f_entropy(sumi. / sum..) |
| 315 | ||
| 316 |
# minimize |
|
| 317 | ! |
out <- log(nCol) + Q1 - Q2 - Q3 |
| 318 | ||
| 319 | ! |
if (grad) {
|
| 320 | ! |
H <- -(log(L2 / sum..) + 1) |
| 321 | ! |
alpha <- sum(L2 * H) / (sum.. * sum..) |
| 322 | ! |
G1 <- H / sum.. - alpha |
| 323 | ||
| 324 | ! |
hj <- -(log(sum.j / sum..) + 1) |
| 325 | ! |
alphaj <- as.numeric(hj %*% sum.j) / (sum.. * sum..) |
| 326 | ! |
G2 <- matrix(hj, nRow, nCol, byrow = TRUE) / sum.. - alphaj |
| 327 | ||
| 328 | ! |
hi <- -(log(sumi. / sum..) + 1) |
| 329 | ! |
alphai <- as.numeric(sumi. %*% hi) / (sum.. * sum..) |
| 330 | ! |
G3 <- matrix(hi, nRow, nCol) / sum.. - alphai |
| 331 | ||
| 332 | ! |
attr(out, "grad") <- 2 * LAMBDA * (G1 - G2 - G3) |
| 333 |
} |
|
| 334 | ||
| 335 | ! |
out |
| 336 |
} |
|
| 337 | ||
| 338 |
# oblimax |
|
| 339 |
# Harman, 1976; Saunders, 1961 |
|
| 340 |
# |
|
| 341 |
# for orthogonal rotation, oblimax is equivalent to quartimax |
|
| 342 |
lav_matrix_rotate_oblimax <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 343 | ! |
L2 <- LAMBDA * LAMBDA |
| 344 | ||
| 345 |
# minimize version |
|
| 346 | ! |
out <- -log(sum(L2 * L2)) + 2 * log(sum(L2)) |
| 347 | ||
| 348 | ! |
if (grad) {
|
| 349 | ! |
attr(out, "grad") <- (-4 * L2 * LAMBDA / (sum(L2 * L2)) |
| 350 | ! |
+ 4 * LAMBDA / (sum(L2))) |
| 351 |
} |
|
| 352 | ||
| 353 | ! |
out |
| 354 |
} |
|
| 355 | ||
| 356 |
# Bentler's Invariant Pattern Simplicity |
|
| 357 |
# Bentler (1977) |
|
| 358 |
# |
|
| 359 |
# |
|
| 360 |
lav_matrix_rotate_bentler <- function(LAMBDA = NULL, ..., grad = FALSE) {
|
|
| 361 | ! |
L2 <- LAMBDA * LAMBDA |
| 362 | ||
| 363 | ! |
L2tL2 <- crossprod(L2) |
| 364 | ! |
L2tL2.inv <- lav_matrix_symmetric_inverse(S = L2tL2, logdet = TRUE) |
| 365 | ! |
L2tL2.logdet <- attr(L2tL2.inv, "logdet") |
| 366 | ||
| 367 | ! |
DIag <- diag(L2tL2) |
| 368 | ! |
DIag.inv <- diag(1 / DIag) |
| 369 | ! |
DIag.logdet <- sum(log(DIag)) # add small constant? |
| 370 | ||
| 371 |
# minimize version |
|
| 372 | ! |
out <- -(L2tL2.logdet - DIag.logdet) / 4 |
| 373 | ||
| 374 | ! |
if (grad) {
|
| 375 | ! |
attr(out, "grad") <- -LAMBDA * (L2 %*% (L2tL2.inv - DIag.inv)) |
| 376 |
} |
|
| 377 | ||
| 378 | ! |
out |
| 379 |
} |
|
| 380 | ||
| 381 | ||
| 382 |
# The Tandem criteria |
|
| 383 |
# Comrey (1967) |
|
| 384 |
# |
|
| 385 |
# only for sequential use: |
|
| 386 |
# - tandem1 is used to determine the number of factors |
|
| 387 |
# (it removes the minor factors) |
|
| 388 |
# - tandomII is used for final rotation |
|
| 389 |
# |
|
| 390 |
lav_matrix_rotate_tandem1 <- function(LAMBDA, ..., grad = FALSE) {
|
|
| 391 | ! |
L2 <- LAMBDA * LAMBDA |
| 392 | ! |
LL <- tcrossprod(LAMBDA) |
| 393 | ! |
LL2 <- LL * LL |
| 394 | ||
| 395 |
# minimize version |
|
| 396 | ! |
out <- -1 * sum(L2 * (LL2 %*% L2)) |
| 397 | ||
| 398 | ! |
if (grad) {
|
| 399 | ! |
tmp1 <- 4 * LAMBDA * (LL2 %*% L2) |
| 400 | ! |
tmp2 <- 4 * (LL * (L2 %*% t(L2))) %*% LAMBDA |
| 401 | ! |
attr(out, "grad") <- -tmp1 - tmp2 |
| 402 |
} |
|
| 403 | ||
| 404 | ! |
out |
| 405 |
} |
|
| 406 | ||
| 407 |
lav_matrix_rotate_tandem2 <- function(LAMBDA, ..., grad = FALSE) {
|
|
| 408 | ! |
L2 <- LAMBDA * LAMBDA |
| 409 | ! |
LL <- tcrossprod(LAMBDA) |
| 410 | ! |
LL2 <- LL * LL |
| 411 | ||
| 412 |
# minimize version |
|
| 413 | ! |
out <- sum(L2 * ((1 - LL2) %*% L2)) |
| 414 | ||
| 415 | ! |
if (grad) {
|
| 416 | ! |
tmp1 <- 4 * LAMBDA * ((1 - LL2) %*% L2) |
| 417 | ! |
tmp2 <- 4 * (LL * tcrossprod(L2, L2)) %*% LAMBDA |
| 418 | ! |
attr(out, "grad") <- tmp1 - tmp2 |
| 419 |
} |
|
| 420 | ||
| 421 | ! |
out |
| 422 |
} |
|
| 423 | ||
| 424 | ||
| 425 |
# simplimax |
|
| 426 |
# Kiers (1994) |
|
| 427 |
# |
|
| 428 |
# oblique rotation method |
|
| 429 |
# designed to rotate so that a given number 'k' of small loadings are |
|
| 430 |
# as close to zero as possible |
|
| 431 |
# |
|
| 432 |
# may be viewed as partially specified target rotation with |
|
| 433 |
# dynamically chosen weights |
|
| 434 |
# |
|
| 435 |
lav_matrix_rotate_simplimax <- function(LAMBDA = NULL, k = nrow(LAMBDA), |
|
| 436 |
..., grad = FALSE) {
|
|
| 437 | ! |
L2 <- LAMBDA * LAMBDA |
| 438 | ||
| 439 |
# 'k' smallest element of L2 |
|
| 440 | ! |
small.element <- sort(L2)[k] |
| 441 | ||
| 442 |
# which elements are smaller than (or equal than) 'small.element'? |
|
| 443 | ! |
ID <- sign(L2 <= small.element) |
| 444 | ||
| 445 |
# minimize version |
|
| 446 | ! |
out <- sum(L2 * ID) |
| 447 | ||
| 448 | ! |
if (grad) {
|
| 449 | ! |
attr(out, "grad") <- 2 * ID * LAMBDA |
| 450 |
} |
|
| 451 | ||
| 452 | ! |
out |
| 453 |
} |
|
| 454 | ||
| 455 | ||
| 456 |
# target rotation |
|
| 457 |
# Harman, 1976 |
|
| 458 |
# |
|
| 459 |
# LAMBDA is rotated toward a specified target matrix 'target' |
|
| 460 |
# |
|
| 461 |
# Note: 'target' must be fully specified; if there are any NAs |
|
| 462 |
# use lav_matrix_rotate_pst() instead |
|
| 463 |
# |
|
| 464 |
lav_matrix_rotate_target <- function(LAMBDA = NULL, target = NULL, |
|
| 465 |
..., grad = FALSE) {
|
|
| 466 |
# squared difference |
|
| 467 | ! |
DIFF <- LAMBDA - target |
| 468 | ! |
DIFF2 <- DIFF * DIFF |
| 469 | ||
| 470 | ! |
out <- sum(DIFF2, na.rm = TRUE) |
| 471 | ||
| 472 | ! |
if (grad) {
|
| 473 | ! |
tmp <- 2 * DIFF |
| 474 |
# change NAs to zero |
|
| 475 | ! |
tmp[is.na(tmp)] <- 0 |
| 476 | ! |
attr(out, "grad") <- tmp |
| 477 |
} |
|
| 478 | ||
| 479 | ! |
out |
| 480 |
} |
|
| 481 | ||
| 482 |
# partially specified target rotation |
|
| 483 |
# |
|
| 484 |
# Browne 1972a, 1972b |
|
| 485 |
# |
|
| 486 |
# a pre-specified weight matrix W with ones/zeroes determines |
|
| 487 |
# which elements of (LAMBDA - target) are used by the rotation criterion |
|
| 488 |
# |
|
| 489 |
# if 'target' contains NAs, they should correspond to '0' values in the |
|
| 490 |
# target.mask matrix |
|
| 491 |
# |
|
| 492 |
lav_matrix_rotate_pst <- function(LAMBDA = NULL, target = NULL, |
|
| 493 |
target.mask = NULL, ..., grad = FALSE) {
|
|
| 494 |
# mask target+LAMBDA |
|
| 495 | ! |
target <- target.mask * target |
| 496 | ! |
LAMBDA <- target.mask * LAMBDA |
| 497 | ||
| 498 |
# squared difference |
|
| 499 | ! |
DIFF <- LAMBDA - target |
| 500 | ! |
DIFF2 <- DIFF * DIFF |
| 501 | ||
| 502 |
# minimize |
|
| 503 | ! |
out <- sum(DIFF2, na.rm = TRUE) |
| 504 | ||
| 505 | ! |
if (grad) {
|
| 506 | ! |
tmp <- 2 * DIFF |
| 507 |
# change NAs to zero |
|
| 508 | ! |
tmp[is.na(tmp)] <- 0 |
| 509 | ! |
attr(out, "grad") <- tmp |
| 510 |
} |
|
| 511 | ||
| 512 | ! |
out |
| 513 |
} |
|
| 514 | ||
| 515 | ||
| 516 |
# bi-quartimin |
|
| 517 |
# |
|
| 518 |
# Jennrich & Bentler 2011 |
|
| 519 |
# |
|
| 520 |
lav_matrix_rotate_biquartimin <- function(LAMBDA, ..., grad = FALSE) {
|
|
| 521 |
# see Matlab code page 549 |
|
| 522 | ! |
stopifnot(ncol(LAMBDA) > 1L) |
| 523 | ||
| 524 |
# remove first column |
|
| 525 | ! |
LAMBDA.group <- LAMBDA[, -1, drop = FALSE] |
| 526 | ||
| 527 |
# apply quartimin on the 'group' part |
|
| 528 | ! |
out <- lav_matrix_rotate_quartimin(LAMBDA.group, ..., grad = grad) |
| 529 | ||
| 530 | ! |
if (grad) {
|
| 531 | ! |
tmp <- attr(out, "grad") |
| 532 | ! |
attr(out, "grad") <- cbind(0, tmp) |
| 533 |
} |
|
| 534 | ||
| 535 | ! |
out |
| 536 |
} |
|
| 537 | ||
| 538 | ||
| 539 |
# bi-geomin |
|
| 540 |
# |
|
| 541 |
# Jennrich & Bentler 2012 |
|
| 542 |
# |
|
| 543 |
lav_matrix_rotate_bigeomin <- function(LAMBDA, geomin.epsilon = 0.01, ..., |
|
| 544 |
grad = FALSE) {
|
|
| 545 | ! |
stopifnot(ncol(LAMBDA) > 1L) |
| 546 | ||
| 547 |
# remove first column |
|
| 548 | ! |
LAMBDA.group <- LAMBDA[, -1, drop = FALSE] |
| 549 | ||
| 550 |
# apply geomin on the 'group' part |
|
| 551 | ! |
out <- lav_matrix_rotate_geomin(LAMBDA.group, |
| 552 | ! |
geomin.epsilon = geomin.epsilon, ..., |
| 553 | ! |
grad = grad |
| 554 |
) |
|
| 555 | ||
| 556 | ! |
if (grad) {
|
| 557 | ! |
tmp <- attr(out, "grad") |
| 558 | ! |
attr(out, "grad") <- cbind(0, tmp) |
| 559 |
} |
|
| 560 | ||
| 561 | ! |
out |
| 562 |
} |
|
| 563 | ||
| 564 |
# multiple group rotation + agreement |
|
| 565 |
lav_matrix_rotate_mg_agreement <- function(lambdaList, method.fname = "geomin", |
|
| 566 |
method.args = list(), |
|
| 567 |
mg.agreement.method = "procrustes", |
|
| 568 |
w = 0.5, scale = TRUE) {
|
|
| 569 | ! |
ngroups <- length(lambdaList) |
| 570 | ||
| 571 |
# 0. rescale, so all columns have the same (average) sum-of-squares |
|
| 572 | ! |
if (scale) {
|
| 573 | ! |
SS.LIST <- lapply(lambdaList, function(x) colSums(x * x)) |
| 574 | ! |
SS.ave <- Reduce("+", SS.LIST) / length(SS.LIST)
|
| 575 | ! |
for (g in seq_len(ngroups)) {
|
| 576 | ! |
lambdaList[[g]] <- t(t(lambdaList[[g]]) / sqrt(SS.LIST[[g]]) * sqrt(SS.ave)) |
| 577 |
} |
|
| 578 |
} |
|
| 579 | ||
| 580 |
# 1. simple structure crit for each group |
|
| 581 | ! |
Q.group <- numeric(ngroups) |
| 582 | ! |
for (g in seq_len(ngroups)) {
|
| 583 | ! |
Q.group[g] <- do.call(method.fname, c( |
| 584 | ! |
list(LAMBDA = lambdaList[[g]]), |
| 585 | ! |
method.args, list(grad = FALSE) |
| 586 |
)) |
|
| 587 |
} |
|
| 588 |
# FIXME: should we 'weight' the groups, based on sample size? |
|
| 589 | ! |
Q.mg <- sum(Q.group) |
| 590 | ||
| 591 |
# 2. agreement (generalized procrustes) across all groups |
|
| 592 | ! |
if (mg.agreement.method == "procrustes") {
|
| 593 | ! |
A.mg <- 0 |
| 594 | ! |
pairs <- utils::combn(seq_len(ngroups), 2L) |
| 595 | ! |
for (p in seq_len(ncol(pairs))) {
|
| 596 | ! |
g1 <- pairs[1L, p] |
| 597 | ! |
g2 <- pairs[2L, p] |
| 598 | ! |
diff <- (lambdaList[[g1]] - lambdaList[[g2]]) |
| 599 | ! |
diff2 <- diff * diff |
| 600 |
# FiXME: should we 'weight' the groups, based on sample size? |
|
| 601 | ! |
A.mg <- A.mg + sum(diff2) |
| 602 |
} |
|
| 603 |
} else {
|
|
| 604 | ! |
lav_msg_stop(gettext("only mg.agreement.method procrustes is supported for now"))
|
| 605 |
} |
|
| 606 | ||
| 607 | ! |
out <- (w * A.mg) + ((1 - w) * Q.mg) |
| 608 | ||
| 609 | ! |
attr(out, "Q.mg") <- Q.mg |
| 610 | ! |
attr(out, "A.mg") <- A.mg |
| 611 | ||
| 612 | ! |
out |
| 613 |
} |
|
| 614 | ||
| 615 |
# gradient check |
|
| 616 |
ilav_matrix_rotate_grad_test <- function(crit = NULL, ..., |
|
| 617 |
LAMBDA = NULL, |
|
| 618 |
nRow = 20L, nCol = 5L) {
|
|
| 619 |
# test matrix |
|
| 620 | ! |
if (is.null(LAMBDA)) {
|
| 621 | ! |
LAMBDA <- matrix(rnorm(nRow * nCol), nRow, nCol) |
| 622 |
} |
|
| 623 | ||
| 624 | ! |
ff <- function(x, ...) {
|
| 625 | ! |
Lambda <- matrix(x, nRow, nCol) |
| 626 | ! |
crit(Lambda, ..., grad = FALSE) |
| 627 |
} |
|
| 628 | ||
| 629 | ! |
GQ1 <- matrix( |
| 630 | ! |
numDeriv::grad(func = ff, x = as.vector(LAMBDA), ...), |
| 631 | ! |
nRow, nCol |
| 632 |
) |
|
| 633 | ! |
GQ2 <- attr(crit(LAMBDA, ..., grad = TRUE), "grad") |
| 634 | ||
| 635 | ! |
if (lav_verbose()) {
|
| 636 | ! |
print(list(LAMBDA = LAMBDA, GQ1 = GQ1, GQ2 = GQ2)) |
| 637 |
} |
|
| 638 | ||
| 639 | ! |
all.equal(GQ1, GQ2, tolerance = 1e-07) |
| 640 |
} |
|
| 641 | ||
| 642 |
ilav_matrix_rotate_grad_test_all <- function() {
|
|
| 643 |
# Orthomax family with various values for gamma |
|
| 644 | ! |
for (gamma in seq(0, 1, 0.2)) {
|
| 645 | ! |
check <- ilav_matrix_rotate_grad_test( |
| 646 | ! |
crit = lav_matrix_rotate_orthomax, |
| 647 | ! |
gamma = gamma |
| 648 |
) |
|
| 649 | ! |
if (is.logical(check) && check) {
|
| 650 | ! |
cat( |
| 651 | ! |
"orthomax + gamma = ", sprintf("%3.1f", gamma),
|
| 652 | ! |
": OK\n" |
| 653 |
) |
|
| 654 |
} else {
|
|
| 655 | ! |
cat( |
| 656 | ! |
"orthomax + gamma = ", sprintf("%3.1f", gamma),
|
| 657 | ! |
": FAILED\n" |
| 658 |
) |
|
| 659 |
} |
|
| 660 |
} |
|
| 661 | ||
| 662 |
# Crawford-Ferguson with various values for gamma |
|
| 663 | ! |
for (gamma in seq(0, 1, 0.2)) {
|
| 664 | ! |
check <- ilav_matrix_rotate_grad_test( |
| 665 | ! |
crit = lav_matrix_rotate_cf, |
| 666 | ! |
gamma = gamma |
| 667 |
) |
|
| 668 | ! |
if (is.logical(check) && check) {
|
| 669 | ! |
cat( |
| 670 | ! |
"Crawford-Ferguson + gamma = ", sprintf("%3.1f", gamma),
|
| 671 | ! |
": OK\n" |
| 672 |
) |
|
| 673 |
} else {
|
|
| 674 | ! |
cat( |
| 675 | ! |
"Crawford-Ferguson + gamma = ", sprintf("%3.1f", gamma),
|
| 676 | ! |
": FAILED\n" |
| 677 |
) |
|
| 678 |
} |
|
| 679 |
} |
|
| 680 | ||
| 681 |
# Oblimin family with various values for gamma |
|
| 682 | ! |
for (gamma in seq(0, 1, 0.2)) {
|
| 683 | ! |
check <- ilav_matrix_rotate_grad_test( |
| 684 | ! |
crit = lav_matrix_rotate_oblimin, |
| 685 | ! |
gamma = gamma |
| 686 |
) |
|
| 687 | ! |
if (is.logical(check) && check) {
|
| 688 | ! |
cat( |
| 689 | ! |
"Oblimin + gamma = ", sprintf("%3.1f", gamma),
|
| 690 | ! |
": OK\n" |
| 691 |
) |
|
| 692 |
} else {
|
|
| 693 | ! |
cat( |
| 694 | ! |
"Oblimin + gamma = ", sprintf("%3.1f", gamma),
|
| 695 | ! |
": FAILED\n" |
| 696 |
) |
|
| 697 |
} |
|
| 698 |
} |
|
| 699 | ||
| 700 |
# quartimax |
|
| 701 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_quartimax) |
| 702 | ! |
if (is.logical(check) && check) {
|
| 703 | ! |
cat("quartimax: OK\n")
|
| 704 |
} else {
|
|
| 705 | ! |
cat("quartimax: FAILED\n")
|
| 706 |
} |
|
| 707 | ||
| 708 |
# varimax |
|
| 709 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_varimax) |
| 710 | ! |
if (is.logical(check) && check) {
|
| 711 | ! |
cat("varimax: OK\n")
|
| 712 |
} else {
|
|
| 713 | ! |
cat("varimax: FAILED\n")
|
| 714 |
} |
|
| 715 | ||
| 716 |
# quartimin |
|
| 717 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_quartimin) |
| 718 | ! |
if (is.logical(check) && check) {
|
| 719 | ! |
cat("quartimin: OK\n")
|
| 720 |
} else {
|
|
| 721 | ! |
cat("quartimin: FAILED\n")
|
| 722 |
} |
|
| 723 | ||
| 724 |
# geomin |
|
| 725 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_geomin) |
| 726 | ! |
if (is.logical(check) && check) {
|
| 727 | ! |
cat("geomin: OK\n")
|
| 728 |
} else {
|
|
| 729 | ! |
cat("geomin: FAILED\n")
|
| 730 |
} |
|
| 731 | ||
| 732 |
# simple entropy |
|
| 733 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_entropy) |
| 734 | ! |
if (is.logical(check) && check) {
|
| 735 | ! |
cat("entropy: OK\n")
|
| 736 |
} else {
|
|
| 737 | ! |
cat("entropy: FAILED\n")
|
| 738 |
} |
|
| 739 | ||
| 740 |
# McCammon entropy criterion |
|
| 741 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_mccammon) |
| 742 | ! |
if (is.logical(check) && check) {
|
| 743 | ! |
cat("McCammon: OK\n")
|
| 744 |
} else {
|
|
| 745 | ! |
cat("McCammon: FAILED\n")
|
| 746 |
} |
|
| 747 | ||
| 748 |
# infomax |
|
| 749 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_infomax) |
| 750 | ! |
if (is.logical(check) && check) {
|
| 751 | ! |
cat("infomax: OK\n")
|
| 752 |
} else {
|
|
| 753 | ! |
cat("infomax: FAILED\n")
|
| 754 |
} |
|
| 755 | ||
| 756 |
# oblimax |
|
| 757 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_oblimax) |
| 758 | ! |
if (is.logical(check) && check) {
|
| 759 | ! |
cat("oblimax: OK\n")
|
| 760 |
} else {
|
|
| 761 | ! |
cat("oblimax: FAILED\n")
|
| 762 |
} |
|
| 763 | ||
| 764 |
# bentler |
|
| 765 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_bentler) |
| 766 | ! |
if (is.logical(check) && check) {
|
| 767 | ! |
cat("bentler: OK\n")
|
| 768 |
} else {
|
|
| 769 | ! |
cat("bentler: FAILED\n")
|
| 770 |
} |
|
| 771 | ||
| 772 |
# simplimax |
|
| 773 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_simplimax) |
| 774 | ! |
if (is.logical(check) && check) {
|
| 775 | ! |
cat("simplimax: OK\n")
|
| 776 |
} else {
|
|
| 777 | ! |
cat("simplimax: FAILED\n")
|
| 778 |
} |
|
| 779 | ||
| 780 |
# tandem1 |
|
| 781 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_tandem1) |
| 782 | ! |
if (is.logical(check) && check) {
|
| 783 | ! |
cat("tandem1: OK\n")
|
| 784 |
} else {
|
|
| 785 | ! |
cat("tandem1: FAILED\n")
|
| 786 |
} |
|
| 787 | ||
| 788 |
# tandem2 |
|
| 789 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_tandem2) |
| 790 | ! |
if (is.logical(check) && check) {
|
| 791 | ! |
cat("tandem2: OK\n")
|
| 792 |
} else {
|
|
| 793 | ! |
cat("tandem2: FAILED\n")
|
| 794 |
} |
|
| 795 | ||
| 796 |
# bi-quartimin |
|
| 797 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_biquartimin) |
| 798 | ! |
if (is.logical(check) && check) {
|
| 799 | ! |
cat("biquartimin: OK\n")
|
| 800 |
} else {
|
|
| 801 | ! |
cat("biquartimin: FAILED\n")
|
| 802 |
} |
|
| 803 | ||
| 804 |
# bi-quartimin |
|
| 805 | ! |
check <- ilav_matrix_rotate_grad_test(crit = lav_matrix_rotate_bigeomin) |
| 806 | ! |
if (is.logical(check) && check) {
|
| 807 | ! |
cat("bigeomin: OK\n")
|
| 808 |
} else {
|
|
| 809 | ! |
cat("bigeomin: FAILED\n")
|
| 810 |
} |
|
| 811 |
} |
| 1 |
# construct 1D, 2D or pattern-based frequency tables |
|
| 2 |
# YR. 10 April 2013 |
|
| 3 |
# Notes: |
|
| 4 |
# - we do NOT make a distinction here between unordered and ordered categorical |
|
| 5 |
# variables |
|
| 6 |
# - object can be a matrix (most likely with integers), a full data frame, |
|
| 7 |
# a fitted lavaan object, or a lavData object |
|
| 8 |
# - 11 May 2013: added collapse=TRUE, min.std.resid options (suggested |
|
| 9 |
# by Myrsini Katsikatsou |
|
| 10 |
# - 11 June 2013: added dimension, to get one-way and two-way (three-way?) |
|
| 11 |
# tables |
|
| 12 |
# - 20 Sept 2013: - allow for sample-based or model-based cell probabilities |
|
| 13 |
# re-organize/re-name to provide a more consistent interface |
|
| 14 |
# rows in the output can be either: cells, tables or patterns |
|
| 15 |
# - dimension=0 equals type="pattern |
|
| 16 |
# - collapse=TRUE is replaced by type="table" |
|
| 17 |
# - changed names of statistics: std.resid is now GR.average |
|
| 18 |
# - added many more statistics; some based on the model, some |
|
| 19 |
# on the unrestricted model |
|
| 20 |
# - 8 Nov 2013: - skip empty cells for G2, instead of adding 0.5 to obs |
|
| 21 |
# - 7 Feb 2016: - take care of conditional.x = TRUE |
|
| 22 | ||
| 23 |
lavTables <- function(object, |
|
| 24 |
# what type of table? |
|
| 25 |
dimension = 2L, |
|
| 26 |
type = "cells", |
|
| 27 |
# if raw data, additional attributes |
|
| 28 |
categorical = NULL, |
|
| 29 |
group = NULL, |
|
| 30 |
# which statistics / fit indices? |
|
| 31 |
statistic = "default", |
|
| 32 |
G2.min = 3.0, # needed for G2.{p/n}large
|
|
| 33 |
X2.min = 3.0, # needed for X2.{p/n}large
|
|
| 34 |
# pvalues for statistics? |
|
| 35 |
p.value = FALSE, |
|
| 36 |
# Bonferonni |
|
| 37 |
# alpha.adj = FALSE, |
|
| 38 |
# output format |
|
| 39 |
output = "data.frame", |
|
| 40 |
patternAsString = TRUE) {
|
|
| 41 |
# check object |
|
| 42 | 60x |
object <- lav_object_check_version(object) |
| 43 | ||
| 44 |
# check input |
|
| 45 | 60x |
if (!(dimension == 0L || dimension == 1L || dimension == 2L)) {
|
| 46 | ! |
lav_msg_stop(gettext( |
| 47 | ! |
"dimension must be 0, 1 or 2 for pattern, one-way or two-way tables")) |
| 48 |
} |
|
| 49 | 60x |
stopifnot(type %in% c("cells", "table", "pattern"))
|
| 50 | 60x |
if (type == "pattern") {
|
| 51 | ! |
dimension <- 0L |
| 52 |
} |
|
| 53 | ||
| 54 |
# extract or create lavdata |
|
| 55 | 60x |
lavdata <- lav_lavdata(object, ordered = categorical, group = group) |
| 56 | ||
| 57 |
# is 'object' a lavaan object? |
|
| 58 | 60x |
lavobject <- NULL |
| 59 | 60x |
if (inherits(object, "lavaan")) {
|
| 60 | 60x |
lavobject <- object |
| 61 |
} |
|
| 62 | ||
| 63 |
# case 1: response patterns |
|
| 64 | 60x |
if (dimension == 0L) {
|
| 65 | 20x |
out <- lav_tables_pattern( |
| 66 | 20x |
lavobject = lavobject, lavdata = lavdata, |
| 67 | 20x |
statistic = statistic, |
| 68 | 20x |
patternAsString = patternAsString |
| 69 |
) |
|
| 70 |
# output format |
|
| 71 | 20x |
if (output == "data.frame") {
|
| 72 | 20x |
class(out) <- c("lavaan.data.frame", "data.frame")
|
| 73 |
} else {
|
|
| 74 | ! |
lav_msg_warn(gettextf("output option `%s' is not available; ignored.",
|
| 75 | ! |
output)) |
| 76 |
} |
|
| 77 | ||
| 78 |
# case 2: one-way/univariate |
|
| 79 | 40x |
} else if (dimension == 1L) {
|
| 80 | 20x |
out <- lav_tables_oneway( |
| 81 | 20x |
lavobject = lavobject, lavdata = lavdata, |
| 82 | 20x |
statistic = statistic |
| 83 |
) |
|
| 84 | ||
| 85 |
# output format |
|
| 86 | 20x |
if (output == "data.frame") {
|
| 87 | 20x |
class(out) <- c("lavaan.data.frame", "data.frame")
|
| 88 |
} else {
|
|
| 89 | ! |
lav_msg_warn(gettextf("output option `%s' is not available; ignored.",
|
| 90 | ! |
output)) |
| 91 |
} |
|
| 92 | ||
| 93 |
# case 3a: two-way/pairwise/bivariate + cells |
|
| 94 | 20x |
} else if (dimension == 2L && type == "cells") {
|
| 95 | 20x |
out <- lav_tables_pairwise_cells( |
| 96 | 20x |
lavobject = lavobject, |
| 97 | 20x |
lavdata = lavdata, |
| 98 | 20x |
statistic = statistic |
| 99 |
) |
|
| 100 |
# output format |
|
| 101 | 20x |
if (output == "data.frame") {
|
| 102 | 20x |
class(out) <- c("lavaan.data.frame", "data.frame")
|
| 103 | ! |
} else if (output == "table") {
|
| 104 | ! |
out <- lav_tables_cells_format(out, lavdata = lavdata) |
| 105 |
} else {
|
|
| 106 | ! |
lav_msg_warn(gettextf("output option `%s' is not available; ignored.",
|
| 107 | ! |
output)) |
| 108 |
} |
|
| 109 | ||
| 110 |
# case 3b: two-way/pairwise/bivariate + collapsed table |
|
| 111 | ! |
} else if (dimension == 2L && (type == "table" || type == "tables")) {
|
| 112 | ! |
out <- lav_tables_pairwise_table( |
| 113 | ! |
lavobject = lavobject, |
| 114 | ! |
lavdata = lavdata, |
| 115 | ! |
statistic = statistic, |
| 116 | ! |
G2.min = G2.min, |
| 117 | ! |
X2.min = X2.min, |
| 118 | ! |
p.value = p.value |
| 119 |
) |
|
| 120 |
# output format |
|
| 121 | ! |
if (output == "data.frame") {
|
| 122 | ! |
class(out) <- c("lavaan.data.frame", "data.frame")
|
| 123 | ! |
} else if (output == "table") {
|
| 124 | ! |
out <- lav_tables_table_format(out, |
| 125 | ! |
lavdata = lavdata, |
| 126 | ! |
lavobject = lavobject |
| 127 |
) |
|
| 128 |
} else {
|
|
| 129 | ! |
lav_msg_warn(gettext("output option `%s' is not available; ignored.",
|
| 130 | ! |
output)) |
| 131 |
} |
|
| 132 |
} |
|
| 133 | ||
| 134 | 60x |
if ((is.data.frame(out) && nrow(out) == 0L) || |
| 135 | 60x |
(is.list(out) && length(out) == 0L)) {
|
| 136 |
# empty table (perhaps, no categorical variables) |
|
| 137 | 58x |
return(invisible(out)) |
| 138 |
} |
|
| 139 | ||
| 140 | 2x |
out |
| 141 |
} |
|
| 142 | ||
| 143 |
# shortcut, always dim=2, type="cells" |
|
| 144 |
# lavTablesFit <- function(object, |
|
| 145 |
# # if raw data, additional attributes |
|
| 146 |
# categorical = NULL, |
|
| 147 |
# group = NULL, |
|
| 148 |
# # which statistics / fit indices? |
|
| 149 |
# statistic = "default", |
|
| 150 |
# G2.min = 3.0, |
|
| 151 |
# X2.min = 3.0, |
|
| 152 |
# # pvalues for statistics? |
|
| 153 |
# p.value = FALSE, |
|
| 154 |
# # output format |
|
| 155 |
# output = "data.frame") {
|
|
| 156 |
# |
|
| 157 |
# lavTables(object = object, dimension = 2L, type = "table", |
|
| 158 |
# categorical = categorical, group = group, |
|
| 159 |
# statistic = statistic, |
|
| 160 |
# G2.min = G2.min, X2.min = X2.min, p.value = p.value, |
|
| 161 |
# output = output, patternAsString = FALSE) |
|
| 162 |
# } |
|
| 163 | ||
| 164 |
# lavTables1D <- function(object, |
|
| 165 |
# # if raw data, additional attributes |
|
| 166 |
# categorical = NULL, |
|
| 167 |
# group = NULL, |
|
| 168 |
# # which statistics / fit indices? |
|
| 169 |
# statistic = "default", |
|
| 170 |
# # output format |
|
| 171 |
# output = "data.frame") {
|
|
| 172 |
# |
|
| 173 |
# lavTables(object = object, dimension = 1L, |
|
| 174 |
# categorical = categorical, group = group, |
|
| 175 |
# statistic = statistic, p.value = FALSE, |
|
| 176 |
# output = output, patternAsString = FALSE) |
|
| 177 |
# } |
|
| 178 | ||
| 179 | ||
| 180 |
lav_tables_pattern <- function(lavobject = NULL, lavdata = NULL, |
|
| 181 |
statistic = NULL, patternAsString = TRUE) {
|
|
| 182 |
# this only works if we have 'categorical' variables |
|
| 183 | 20x |
cat.idx <- which(lavdata@ov$type %in% c("ordered", "factor"))
|
| 184 | 20x |
if (length(cat.idx) == 0L) {
|
| 185 | 19x |
lav_msg_warn(gettext("no categorical variables are found"))
|
| 186 | 19x |
return(data.frame( |
| 187 | 19x |
pattern = character(0L), nobs = integer(0L), |
| 188 | 19x |
obs.freq = integer(0L), obs.prop = numeric(0L) |
| 189 |
)) |
|
| 190 |
} |
|
| 191 |
# no support yet for mixture of endogenous ordered + numeric variables |
|
| 192 | 1x |
if (!is.null(lavobject) && |
| 193 | 1x |
length(lav_object_vnames(lavobject, "ov.nox")) > length(cat.idx)) {
|
| 194 | 1x |
lav_msg_warn(gettext("some endogenous variables are not categorical"))
|
| 195 | 1x |
return(data.frame( |
| 196 | 1x |
pattern = character(0L), nobs = integer(0L), |
| 197 | 1x |
obs.freq = integer(0L), obs.prop = numeric(0L) |
| 198 |
)) |
|
| 199 |
} |
|
| 200 | ||
| 201 |
# default statistics |
|
| 202 | ! |
if (!is.null(lavobject)) {
|
| 203 | ! |
if (length(statistic) == 1L && statistic == "default") {
|
| 204 | ! |
statistic <- c("G2", "X2")
|
| 205 |
} else {
|
|
| 206 | ! |
stopifnot(statistic %in% c("G2.un", "X2.un", "G2", "X2"))
|
| 207 |
} |
|
| 208 |
} else {
|
|
| 209 |
# only data |
|
| 210 | ! |
if (length(statistic) == 1L && statistic == "default") {
|
| 211 |
# if data, none by default |
|
| 212 | ! |
statistic <- character(0L) |
| 213 |
} else {
|
|
| 214 | ! |
stopifnot(statistic %in% c("G2.un", "X2.un"))
|
| 215 |
} |
|
| 216 |
} |
|
| 217 | ||
| 218 |
# first, create basic table with response patterns |
|
| 219 | ! |
for (g in 1:lavdata@ngroups) {
|
| 220 | ! |
pat <- lav_data_resp_patterns(lavdata@X[[g]])$pat |
| 221 | ! |
obs.freq <- as.integer(rownames(pat)) |
| 222 | ! |
if (patternAsString) {
|
| 223 | ! |
pat <- data.frame( |
| 224 | ! |
pattern = apply(pat, 1, paste, collapse = ""), |
| 225 | ! |
stringsAsFactors = FALSE |
| 226 |
) |
|
| 227 |
} else {
|
|
| 228 | ! |
pat <- as.data.frame(pat, stringsAsFactors = FALSE) |
| 229 | ! |
names(pat) <- lavdata@ov.names[[g]] |
| 230 |
} |
|
| 231 |
# pat$id <- 1:nrow(pat) |
|
| 232 | ! |
if (lavdata@ngroups > 1L) {
|
| 233 | ! |
pat$group <- rep(g, nrow(pat)) |
| 234 |
} |
|
| 235 | ! |
NOBS <- sum(obs.freq) |
| 236 | ! |
pat$nobs <- rep(NOBS, nrow(pat)) |
| 237 | ! |
pat$obs.freq <- obs.freq |
| 238 | ! |
rownames(pat) <- NULL |
| 239 | ! |
if (g == 1L) {
|
| 240 | ! |
out <- pat |
| 241 |
} else {
|
|
| 242 | ! |
out <- rbind(out, pat) |
| 243 |
} |
|
| 244 |
} |
|
| 245 | ||
| 246 | ! |
out$obs.prop <- out$obs.freq / out$nobs |
| 247 | ||
| 248 | ! |
if (any(c("X2.un", "G2.un") %in% statistic)) {
|
| 249 |
# not a good statistic... we only have uni+bivariate information |
|
| 250 | ! |
lav_msg_warn(gettext( |
| 251 | ! |
"limited information used for thresholds and correlations; |
| 252 | ! |
but X2/G2 assumes full information")) |
| 253 | ! |
PI <- lav_tables_resp_pi( |
| 254 | ! |
lavobject = lavobject, lavdata = lavdata, |
| 255 | ! |
est = "h1" |
| 256 |
) |
|
| 257 | ||
| 258 | ! |
out$est.prop.un <- unlist(PI) |
| 259 | ! |
if ("G2.un" %in% statistic) {
|
| 260 | ! |
out$G2.un <- lav_tables_stat_G2( |
| 261 | ! |
out$obs.prop, out$est.prop.un, |
| 262 | ! |
out$nobs |
| 263 |
) |
|
| 264 |
} |
|
| 265 | ! |
if ("X2.un" %in% statistic) {
|
| 266 | ! |
out$X2.un <- lav_tables_stat_X2( |
| 267 | ! |
out$obs.prop, out$est.prop.un, |
| 268 | ! |
out$nobs |
| 269 |
) |
|
| 270 |
} |
|
| 271 |
} |
|
| 272 | ! |
if (any(c("X2", "G2") %in% statistic)) {
|
| 273 | ! |
if (lavobject@Options$estimator %in% c("FML")) {
|
| 274 |
# ok, nothing to say |
|
| 275 | ! |
} else if (lavobject@Options$estimator %in% |
| 276 | ! |
c("WLS", "DWLS", "PML", "ULS")) {
|
| 277 | ! |
lav_msg_warn(gettextf( |
| 278 | ! |
"estimator %s is not using full information while est.prop is |
| 279 | ! |
using full information", lavobject@Options$estimator)) |
| 280 |
} else {
|
|
| 281 | ! |
lav_msg_stop(gettextf( |
| 282 | ! |
"estimator %s is not supported.", lavobject@Options$estimator)) |
| 283 |
} |
|
| 284 | ||
| 285 | ! |
PI <- lav_tables_resp_pi( |
| 286 | ! |
lavobject = lavobject, lavdata = lavdata, |
| 287 | ! |
est = "h0" |
| 288 |
) |
|
| 289 | ||
| 290 | ! |
out$est.prop <- unlist(PI) |
| 291 | ! |
if ("G2" %in% statistic) {
|
| 292 | ! |
out$G2 <- lav_tables_stat_G2( |
| 293 | ! |
out$obs.prop, out$est.prop, |
| 294 | ! |
out$nobs |
| 295 |
) |
|
| 296 |
} |
|
| 297 | ! |
if ("X2" %in% statistic) {
|
| 298 | ! |
out$X2 <- lav_tables_stat_X2( |
| 299 | ! |
out$obs.prop, out$est.prop, |
| 300 | ! |
out$nobs |
| 301 |
) |
|
| 302 |
} |
|
| 303 |
} |
|
| 304 | ||
| 305 |
# remove nobs? |
|
| 306 |
# out$nobs <- NULL |
|
| 307 | ||
| 308 | ! |
out |
| 309 |
} |
|
| 310 | ||
| 311 |
# pairwise tables, rows = table cells |
|
| 312 |
lav_tables_pairwise_cells <- function(lavobject = NULL, lavdata = NULL, |
|
| 313 |
statistic = character(0L)) {
|
|
| 314 |
# this only works if we have at least two 'categorical' variables |
|
| 315 | 20x |
cat.idx <- which(lavdata@ov$type %in% c("ordered", "factor"))
|
| 316 | 20x |
if (length(cat.idx) == 0L) {
|
| 317 | 19x |
lav_msg_warn(gettext("no categorical variables are found"))
|
| 318 | 19x |
return(data.frame( |
| 319 | 19x |
id = integer(0L), lhs = character(0L), rhs = character(0L), |
| 320 | 19x |
nobs = integer(0L), row = integer(0L), col = integer(0L), |
| 321 | 19x |
obs.freq = integer(0L), obs.prop = numeric(0L) |
| 322 |
)) |
|
| 323 |
} |
|
| 324 | 1x |
if (length(cat.idx) == 1L) {
|
| 325 | ! |
lav_msg_warn(gettext("at least two categorical variables are needed"))
|
| 326 | ! |
return(data.frame( |
| 327 | ! |
id = integer(0L), lhs = character(0L), rhs = character(0L), |
| 328 | ! |
nobs = integer(0L), row = integer(0L), col = integer(0L), |
| 329 | ! |
obs.freq = integer(0L), obs.prop = numeric(0L) |
| 330 |
)) |
|
| 331 |
} |
|
| 332 | ||
| 333 |
# default statistics |
|
| 334 | 1x |
if (!is.null(lavobject)) {
|
| 335 | 1x |
if (length(statistic) == 1L && statistic == "default") {
|
| 336 | 1x |
statistic <- c("X2")
|
| 337 |
} else {
|
|
| 338 | ! |
stopifnot(statistic %in% c( |
| 339 | ! |
"cor", "th", "X2", "G2", |
| 340 | ! |
"cor.un", "th.un", "X2.un", "G2.un" |
| 341 |
)) |
|
| 342 |
} |
|
| 343 |
} else {
|
|
| 344 | ! |
if (length(statistic) == 1L && statistic == "default") {
|
| 345 |
# if data, none by default |
|
| 346 | ! |
statistic <- character(0L) |
| 347 |
} else {
|
|
| 348 | ! |
stopifnot(statistic %in% c("cor.un", "th.un", "X2.un", "G2.un"))
|
| 349 |
} |
|
| 350 |
} |
|
| 351 | ||
| 352 |
# initial table, observed cell frequencies |
|
| 353 | 1x |
out <- lav_tables_pairwise_freq_cell( |
| 354 | 1x |
lavdata = lavdata, |
| 355 | 1x |
as.data.frame. = TRUE |
| 356 |
) |
|
| 357 | 1x |
out$obs.prop <- out$obs.freq / out$nobs |
| 358 | ||
| 359 | 1x |
if (any(c("cor.un", "th.un", "X2.un", "G2.un") %in% statistic)) {
|
| 360 | ! |
PI <- lav_tables_pairwise_sample_pi( |
| 361 | ! |
lavobject = lavobject, |
| 362 | ! |
lavdata = lavdata |
| 363 |
) |
|
| 364 | ! |
out$est.prop.un <- unlist(PI) |
| 365 | ! |
if ("G2.un" %in% statistic) {
|
| 366 | ! |
out$G2.un <- lav_tables_stat_G2( |
| 367 | ! |
out$obs.prop, out$est.prop.un, |
| 368 | ! |
out$nobs |
| 369 |
) |
|
| 370 |
} |
|
| 371 | ! |
if ("X2.un" %in% statistic) {
|
| 372 | ! |
out$X2.un <- lav_tables_stat_X2( |
| 373 | ! |
out$obs.prop, out$est.prop.un, |
| 374 | ! |
out$nobs |
| 375 |
) |
|
| 376 |
} |
|
| 377 | ||
| 378 | ! |
if ("cor.un" %in% statistic) {
|
| 379 | ! |
COR <- attr(PI, "COR") |
| 380 | ! |
cor.all <- unlist(lapply(COR, function(x) {
|
| 381 | ! |
x[lower.tri(x, diag = FALSE)] |
| 382 |
})) |
|
| 383 | ! |
out$cor.un <- cor.all[out$id] |
| 384 |
} |
|
| 385 |
} |
|
| 386 | 1x |
if (any(c("cor", "th", "X2", "G2") %in% statistic)) {
|
| 387 | 1x |
PI <- lav_tables_pairwise_model_pi(lavobject = lavobject) |
| 388 | 1x |
out$est.prop <- unlist(PI) |
| 389 | 1x |
if ("G2" %in% statistic) {
|
| 390 | ! |
out$G2 <- lav_tables_stat_G2( |
| 391 | ! |
out$obs.prop, out$est.prop, |
| 392 | ! |
out$nobs |
| 393 |
) |
|
| 394 |
} |
|
| 395 | 1x |
if ("X2" %in% statistic) {
|
| 396 | 1x |
out$X2 <- lav_tables_stat_X2( |
| 397 | 1x |
out$obs.prop, out$est.prop, |
| 398 | 1x |
out$nobs |
| 399 |
) |
|
| 400 |
} |
|
| 401 | 1x |
if ("cor" %in% statistic) {
|
| 402 | ! |
COR <- attr(PI, "COR") |
| 403 | ! |
cor.all <- unlist(lapply(COR, function(x) {
|
| 404 | ! |
x[lower.tri(x, diag = FALSE)] |
| 405 |
})) |
|
| 406 | ! |
out$cor <- cor.all[out$id] |
| 407 |
} |
|
| 408 |
} |
|
| 409 | ||
| 410 | 1x |
out |
| 411 |
} |
|
| 412 | ||
| 413 |
# G2 statistic |
|
| 414 |
lav_tables_stat_G2 <- function(obs.prop = NULL, est.prop = NULL, nobs = NULL) {
|
|
| 415 |
# not defined if out$obs.prop is (close to) zero |
|
| 416 | ! |
zero.idx <- which(obs.prop < .Machine$double.eps) |
| 417 | ! |
if (length(zero.idx)) {
|
| 418 | ! |
obs.prop[zero.idx] <- as.numeric(NA) |
| 419 |
} |
|
| 420 |
# the usual G2 formula |
|
| 421 | ! |
G2 <- 2 * nobs * (obs.prop * log(obs.prop / est.prop)) |
| 422 | ! |
G2 |
| 423 |
} |
|
| 424 | ||
| 425 |
# X2 (aka X2) statistic |
|
| 426 |
lav_tables_stat_X2 <- function(obs.prop = NULL, est.prop = NULL, nobs = NULL) {
|
|
| 427 | 2x |
res.prop <- obs.prop - est.prop |
| 428 | 2x |
X2 <- nobs * (res.prop * res.prop) / est.prop |
| 429 | 2x |
X2 |
| 430 |
} |
|
| 431 | ||
| 432 |
# pairwise tables, rows = tables |
|
| 433 |
lav_tables_pairwise_table <- function(lavobject = NULL, lavdata = NULL, |
|
| 434 |
statistic = character(0L), |
|
| 435 |
G2.min = 3.0, |
|
| 436 |
X2.min = 3.0, |
|
| 437 |
p.value = FALSE) {
|
|
| 438 |
# default statistics |
|
| 439 | ! |
if (!is.null(lavobject)) {
|
| 440 | ! |
if (length(statistic) == 1L && statistic == "default") {
|
| 441 | ! |
statistic <- c("X2", "X2.average")
|
| 442 |
} else {
|
|
| 443 | ! |
stopifnot(statistic %in% c( |
| 444 | ! |
"X2", "G2", "X2.un", "G2.un", |
| 445 | ! |
"cor", "cor.un", |
| 446 | ! |
"RMSEA.un", "RMSEA", |
| 447 | ! |
"G2.average", |
| 448 | ! |
"G2.nlarge", |
| 449 | ! |
"G2.plarge", |
| 450 | ! |
"X2.average", |
| 451 | ! |
"X2.nlarge", |
| 452 | ! |
"X2.plarge" |
| 453 |
)) |
|
| 454 |
} |
|
| 455 |
} else {
|
|
| 456 | ! |
if (length(statistic) == 1L && statistic == "default") {
|
| 457 |
# if data, none by default |
|
| 458 | ! |
statistic <- character(0L) |
| 459 |
} else {
|
|
| 460 | ! |
stopifnot(statistic %in% c( |
| 461 | ! |
"cor.un", "X2.un", "G2.un", |
| 462 | ! |
"RMSEA.un" |
| 463 |
)) |
|
| 464 |
} |
|
| 465 |
} |
|
| 466 | ||
| 467 |
# identify 'categorical' variables |
|
| 468 |
# cat.idx <- which(lavdata@ov$type %in% c("ordered","factor"))
|
|
| 469 | ||
| 470 |
# pairwise tables |
|
| 471 |
# pairwise.tables <- utils::combn(vartable$name[cat.idx], m=2L) |
|
| 472 |
# pairwise.tables <- rbind(seq_len(ncol(pairwise.tables)), |
|
| 473 |
# pairwise.tables) |
|
| 474 |
# ntables <- ncol(pairwise.tables) |
|
| 475 | ||
| 476 |
# initial table, observed cell frequencies |
|
| 477 |
# out <- as.data.frame(t(pairwise.tables)) |
|
| 478 |
# names(out) <- c("id", "lhs", "rhs")
|
|
| 479 | ||
| 480 |
# collapse approach |
|
| 481 | ! |
stat.cell <- character(0) |
| 482 | ! |
if (any(c("G2", "G2.average", "G2.plarge", "G2.nlarge") %in% statistic)) {
|
| 483 | ! |
stat.cell <- c(stat.cell, "G2") |
| 484 |
} |
|
| 485 | ! |
if (any(c("X2", "X2.average", "X2.plarge", "X2.nlarge") %in% statistic)) {
|
| 486 | ! |
stat.cell <- c(stat.cell, "X2") |
| 487 |
} |
|
| 488 | ! |
if ("G2" %in% statistic || "RMSEA" %in% statistic) {
|
| 489 | ! |
stat.cell <- c(stat.cell, "G2") |
| 490 |
} |
|
| 491 | ! |
if ("X2.un" %in% statistic) {
|
| 492 | ! |
stat.cell <- c(stat.cell, "X2.un") |
| 493 |
} |
|
| 494 | ! |
if ("G2.un" %in% statistic || "RMSEA.un" %in% statistic) {
|
| 495 | ! |
stat.cell <- c(stat.cell, "G2.un") |
| 496 |
} |
|
| 497 | ! |
if ("cor.un" %in% statistic) {
|
| 498 | ! |
stat.cell <- c(stat.cell, "cor.un") |
| 499 |
} |
|
| 500 | ! |
if ("cor" %in% statistic) {
|
| 501 | ! |
stat.cell <- c(stat.cell, "cor") |
| 502 |
} |
|
| 503 | ||
| 504 |
# get table with table cells |
|
| 505 | ! |
out.cell <- lav_tables_pairwise_cells( |
| 506 | ! |
lavobject = lavobject, |
| 507 | ! |
lavdata = lavdata, |
| 508 | ! |
statistic = stat.cell |
| 509 |
) |
|
| 510 |
# only 1 row per table |
|
| 511 | ! |
row.idx <- which(!duplicated(out.cell$id)) |
| 512 | ! |
if (is.null(out.cell$group)) {
|
| 513 | ! |
out <- out.cell[row.idx, c("lhs", "rhs", "nobs"), drop = FALSE]
|
| 514 |
} else {
|
|
| 515 | ! |
out <- out.cell[row.idx, c("lhs", "rhs", "group", "nobs"), drop = FALSE]
|
| 516 |
} |
|
| 517 | ||
| 518 |
# df |
|
| 519 | ! |
if (length(statistic) > 0L) {
|
| 520 | ! |
nrow <- tapply(out.cell$row, INDEX = out.cell$id, FUN = max) |
| 521 | ! |
ncol <- tapply(out.cell$col, INDEX = out.cell$id, FUN = max) |
| 522 | ! |
out$df <- nrow * ncol - nrow - ncol |
| 523 |
} |
|
| 524 | ||
| 525 |
# cor |
|
| 526 | ! |
if ("cor" %in% statistic) {
|
| 527 | ! |
out$cor <- out.cell[row.idx, "cor"] |
| 528 |
} |
|
| 529 | ||
| 530 |
# cor.un |
|
| 531 | ! |
if ("cor.un" %in% statistic) {
|
| 532 | ! |
out$cor.un <- out.cell[row.idx, "cor.un"] |
| 533 |
} |
|
| 534 | ||
| 535 |
# X2 |
|
| 536 | ! |
if ("X2" %in% statistic) {
|
| 537 | ! |
out$X2 <- tapply(out.cell$X2, |
| 538 | ! |
INDEX = out.cell$id, FUN = sum, |
| 539 | ! |
na.rm = TRUE |
| 540 |
) |
|
| 541 | ! |
if (p.value) {
|
| 542 | ! |
out$X2.pval <- pchisq(out$X2, df = out$df, lower.tail = FALSE) |
| 543 |
} |
|
| 544 |
} |
|
| 545 | ! |
if ("X2.un" %in% statistic) {
|
| 546 | ! |
out$X2.un <- tapply(out.cell$X2.un, |
| 547 | ! |
INDEX = out.cell$id, FUN = sum, |
| 548 | ! |
na.rm = TRUE |
| 549 |
) |
|
| 550 | ! |
if (p.value) {
|
| 551 | ! |
out$X2.un.pval <- pchisq(out$X2.un, df = out$df, lower.tail = FALSE) |
| 552 |
} |
|
| 553 |
} |
|
| 554 | ||
| 555 |
# G2 |
|
| 556 | ! |
if ("G2" %in% statistic) {
|
| 557 | ! |
out$G2 <- tapply(out.cell$G2, |
| 558 | ! |
INDEX = out.cell$id, FUN = sum, |
| 559 | ! |
na.rm = TRUE |
| 560 |
) |
|
| 561 | ! |
if (p.value) {
|
| 562 | ! |
out$G2.pval <- pchisq(out$G2, df = out$df, lower.tail = FALSE) |
| 563 |
} |
|
| 564 |
} |
|
| 565 | ! |
if ("G2.un" %in% statistic) {
|
| 566 | ! |
out$G2.un <- tapply(out.cell$G2.un, |
| 567 | ! |
INDEX = out.cell$id, FUN = sum, |
| 568 | ! |
na.rm = TRUE |
| 569 |
) |
|
| 570 | ! |
if (p.value) {
|
| 571 | ! |
out$G2.un.pval <- pchisq(out$G2.un, df = out$df, lower.tail = FALSE) |
| 572 |
} |
|
| 573 |
} |
|
| 574 | ||
| 575 | ! |
if ("RMSEA" %in% statistic) {
|
| 576 | ! |
G2 <- tapply(out.cell$G2, INDEX = out.cell$id, FUN = sum, na.rm = TRUE) |
| 577 |
# note: there seems to be a mistake in Appendix 1 eqs 43/44 of Joreskog |
|
| 578 |
# SSI paper (2005) 'SEM with ordinal variables using LISREL' |
|
| 579 |
# 2*N*d should N*d |
|
| 580 | ! |
out$RMSEA <- sqrt(pmax(0, (G2 - out$df) / (out$nobs * out$df))) |
| 581 | ! |
if (p.value) {
|
| 582 |
# note: MUST use 1 - pchisq (instead of lower.tail = FALSE) |
|
| 583 |
# because for ncp > 80, routine only computes lower tail |
|
| 584 | ! |
out$RMSEA.pval <- 1.0 - pchisq(G2, |
| 585 | ! |
ncp = 0.1 * 0.1 * out$nobs * out$df, |
| 586 | ! |
df = out$df, lower.tail = TRUE |
| 587 |
) |
|
| 588 |
} |
|
| 589 |
} |
|
| 590 | ! |
if ("RMSEA.un" %in% statistic) {
|
| 591 | ! |
G2 <- tapply(out.cell$G2.un, |
| 592 | ! |
INDEX = out.cell$id, FUN = sum, |
| 593 | ! |
na.rm = TRUE |
| 594 |
) |
|
| 595 |
# note: there seems to be a mistake in Appendix 1 eqs 43/44 of Joreskog |
|
| 596 |
# SSI paper (2005) 'SEM with ordinal variables using LISREL' |
|
| 597 |
# 2*N*d should N*d |
|
| 598 | ! |
out$RMSEA.un <- sqrt(pmax(0, (G2 - out$df) / (out$nobs * out$df))) |
| 599 | ! |
if (p.value) {
|
| 600 |
# note: MUST use 1 - pchisq (instead of lower.tail = FALSE) |
|
| 601 |
# because for ncp > 80, routine only computes lower tail |
|
| 602 | ! |
out$RMSEA.un.pval <- 1.0 - pchisq(G2, |
| 603 | ! |
ncp = 0.1 * 0.1 * out$nobs * out$df, |
| 604 | ! |
df = out$df, lower.tail = TRUE |
| 605 |
) |
|
| 606 |
} |
|
| 607 |
} |
|
| 608 | ||
| 609 | ! |
if ("G2.average" %in% statistic) {
|
| 610 | ! |
out$G2.average <- tapply(out.cell$G2, |
| 611 | ! |
INDEX = out.cell$id, FUN = mean, |
| 612 | ! |
na.rm = TRUE |
| 613 |
) |
|
| 614 |
} |
|
| 615 | ||
| 616 | ! |
if ("G2.nlarge" %in% statistic) {
|
| 617 | ! |
out$G2.min <- rep(G2.min, length(out$lhs)) |
| 618 | ! |
out$G2.nlarge <- tapply(out.cell$G2, |
| 619 | ! |
INDEX = out.cell$id, |
| 620 | ! |
FUN = function(x) sum(x > G2.min, na.rm = TRUE) |
| 621 |
) |
|
| 622 |
} |
|
| 623 | ||
| 624 | ! |
if ("G2.plarge" %in% statistic) {
|
| 625 | ! |
out$G2.min <- rep(G2.min, length(out$lhs)) |
| 626 | ! |
out$G2.plarge <- tapply(out.cell$G2, |
| 627 | ! |
INDEX = out.cell$id, |
| 628 | ! |
FUN = function(x) sum(x > G2.min, na.rm = TRUE) / length(x) |
| 629 |
) |
|
| 630 |
} |
|
| 631 | ||
| 632 | ! |
if ("X2.average" %in% statistic) {
|
| 633 | ! |
out$X2.average <- tapply(out.cell$X2, |
| 634 | ! |
INDEX = out.cell$id, FUN = mean, |
| 635 | ! |
na.rm = TRUE |
| 636 |
) |
|
| 637 |
} |
|
| 638 | ||
| 639 | ! |
if ("X2.nlarge" %in% statistic) {
|
| 640 | ! |
out$X2.min <- rep(X2.min, length(out$lhs)) |
| 641 | ! |
out$X2.nlarge <- tapply(out.cell$X2, |
| 642 | ! |
INDEX = out.cell$id, |
| 643 | ! |
FUN = function(x) sum(x > X2.min, na.rm = TRUE) |
| 644 |
) |
|
| 645 |
} |
|
| 646 | ||
| 647 | ! |
if ("X2.plarge" %in% statistic) {
|
| 648 | ! |
out$X2.min <- rep(X2.min, length(out$lhs)) |
| 649 | ! |
out$X2.plarge <- tapply(out.cell$X2, |
| 650 | ! |
INDEX = out.cell$id, |
| 651 | ! |
FUN = function(x) sum(x > X2.min, na.rm = TRUE) / length(x) |
| 652 |
) |
|
| 653 |
} |
|
| 654 | ||
| 655 | ! |
out |
| 656 |
} |
|
| 657 | ||
| 658 | ||
| 659 |
lav_tables_oneway <- function(lavobject = NULL, lavdata = NULL, |
|
| 660 |
statistic = NULL) {
|
|
| 661 |
# shortcuts |
|
| 662 | 20x |
vartable <- lavdata@ov |
| 663 | 20x |
X <- lavdata@X |
| 664 | ||
| 665 |
# identify 'categorical' variables |
|
| 666 | 20x |
cat.idx <- which(vartable$type %in% c("ordered", "factor"))
|
| 667 | 20x |
ncat <- length(cat.idx) |
| 668 | ||
| 669 |
# do we have any categorical variables? |
|
| 670 | 20x |
if (length(cat.idx) == 0L) {
|
| 671 | 19x |
lav_msg_warn(gettext("no categorical variables are found"))
|
| 672 | 19x |
return(data.frame( |
| 673 | 19x |
id = integer(0L), lhs = character(0L), rhs = character(0L), |
| 674 | 19x |
nobs = integer(0L), |
| 675 | 19x |
obs.freq = integer(0L), obs.prop = numeric(0L), |
| 676 | 19x |
est.prop = numeric(0L), X2 = numeric(0L) |
| 677 |
)) |
|
| 678 |
} else {
|
|
| 679 | 1x |
labels <- strsplit(vartable$lnam[cat.idx], "\\|") |
| 680 |
} |
|
| 681 | ||
| 682 |
# ok, we have an overview of all categorical variables in the data |
|
| 683 | 1x |
ngroups <- length(X) |
| 684 | ||
| 685 |
# for each group, for each categorical variable, collect information |
|
| 686 | 1x |
TABLES <- vector("list", length = ngroups)
|
| 687 | 1x |
for (g in 1:ngroups) {
|
| 688 | 1x |
TABLES[[g]] <- lapply(seq_len(ncat), |
| 689 | 1x |
FUN = function(x) {
|
| 690 | 4x |
idx <- cat.idx[x] |
| 691 | 4x |
nrow <- vartable$nlev[idx] |
| 692 | 4x |
ncell <- nrow |
| 693 | 4x |
nvar <- length(lavdata@ov.names[[g]]) |
| 694 | 4x |
id <- (g - 1) * nvar + x |
| 695 | ||
| 696 |
# compute observed frequencies |
|
| 697 | 4x |
FREQ <- tabulate(X[[g]][, idx], nbins = ncell) |
| 698 | ||
| 699 | 4x |
list( |
| 700 | 4x |
id = rep.int(id, ncell), |
| 701 | 4x |
lhs = rep.int(vartable$name[idx], ncell), |
| 702 |
# op = rep.int("freq", ncell),
|
|
| 703 | 4x |
rhs = labels[[x]], |
| 704 | 4x |
group = rep.int(g, ncell), |
| 705 | 4x |
nobs = rep.int(sum(FREQ), ncell), |
| 706 | 4x |
obs.freq = FREQ, |
| 707 | 4x |
obs.prop = FREQ / sum(FREQ) |
| 708 |
) |
|
| 709 |
} |
|
| 710 |
) |
|
| 711 |
} |
|
| 712 | ||
| 713 | 1x |
for (g in 1:ngroups) {
|
| 714 | 1x |
TABLE <- TABLES[[g]] |
| 715 | 1x |
TABLE <- lapply(TABLE, as.data.frame, stringsAsFactors = FALSE) |
| 716 | 1x |
if (g == 1L) {
|
| 717 | 1x |
out <- do.call(rbind, TABLE) |
| 718 |
} else {
|
|
| 719 | ! |
out <- rbind(out, do.call(rbind, TABLE)) |
| 720 |
} |
|
| 721 |
} |
|
| 722 | 1x |
if (g == 1) {
|
| 723 |
# remove group column |
|
| 724 | 1x |
out$group <- NULL |
| 725 |
} |
|
| 726 | ||
| 727 |
# default statistics |
|
| 728 | 1x |
if (!is.null(lavobject)) {
|
| 729 | 1x |
if (length(statistic) == 1L && statistic == "default") {
|
| 730 | 1x |
statistic <- c("X2")
|
| 731 |
} else {
|
|
| 732 | ! |
stopifnot(statistic %in% c( |
| 733 | ! |
"th.un", |
| 734 | ! |
"th", "G2", "X2" |
| 735 |
)) |
|
| 736 |
} |
|
| 737 | ||
| 738 |
# sample based |
|
| 739 |
# note, there is no G2.un or X2.un: always saturated! |
|
| 740 | 1x |
if ("th.un" %in% statistic) {
|
| 741 |
# sample based |
|
| 742 | ! |
th <- unlist(lapply(1:lavdata@ngroups, function(x) {
|
| 743 | ! |
if (lavobject@Model@conditional.x) {
|
| 744 | ! |
TH <- lavobject@SampleStats@res.th[[x]][ |
| 745 | ! |
lavobject@SampleStats@th.idx[[x]] > 0 |
| 746 |
] |
|
| 747 |
} else {
|
|
| 748 | ! |
TH <- lavobject@SampleStats@th[[x]][ |
| 749 | ! |
lavobject@SampleStats@th.idx[[x]] > 0 |
| 750 |
] |
|
| 751 |
} |
|
| 752 | ! |
TH.IDX <- lavobject@SampleStats@th.idx[[x]][ |
| 753 | ! |
lavobject@SampleStats@th.idx[[x]] > 0 |
| 754 |
] |
|
| 755 | ! |
unname(unlist(tapply(TH, |
| 756 | ! |
INDEX = TH.IDX, |
| 757 | ! |
function(y) c(y, Inf) |
| 758 |
))) |
|
| 759 |
})) |
|
| 760 |
# overwrite obs.prop |
|
| 761 |
# NOTE: if we have exogenous variables, obs.prop will NOT |
|
| 762 |
# correspond with qnorm(th) |
|
| 763 | ! |
out$obs.prop <- unname(unlist(tapply(th, |
| 764 | ! |
INDEX = out$id, |
| 765 | ! |
FUN = function(x) {
|
| 766 | ! |
(pnorm(c(x, Inf)) - |
| 767 | ! |
pnorm(c(-Inf, x)))[-(length(x) + 1)] |
| 768 |
} |
|
| 769 |
))) |
|
| 770 | ||
| 771 | ! |
out$th.un <- th |
| 772 |
} |
|
| 773 | ||
| 774 |
# model based |
|
| 775 | 1x |
if (any(c("th", "G2", "X2") %in% statistic)) {
|
| 776 |
# model based |
|
| 777 | 1x |
th.h0 <- unlist(lapply(1:lavdata@ngroups, function(x) {
|
| 778 | 1x |
if (lavobject@Model@conditional.x) {
|
| 779 | 1x |
TH <- lavobject@implied$res.th[[x]][ |
| 780 | 1x |
lavobject@SampleStats@th.idx[[x]] > 0 |
| 781 |
] |
|
| 782 |
} else {
|
|
| 783 | ! |
TH <- lavobject@implied$th[[x]][ |
| 784 | ! |
lavobject@SampleStats@th.idx[[x]] > 0 |
| 785 |
] |
|
| 786 |
} |
|
| 787 | 1x |
TH.IDX <- lavobject@SampleStats@th.idx[[x]][ |
| 788 | 1x |
lavobject@SampleStats@th.idx[[x]] > 0 |
| 789 |
] |
|
| 790 | 1x |
unname(unlist(tapply(TH, |
| 791 | 1x |
INDEX = TH.IDX, |
| 792 | 1x |
function(x) c(x, Inf) |
| 793 |
))) |
|
| 794 |
})) |
|
| 795 | ||
| 796 | 1x |
est.prop <- unname(unlist(tapply(th.h0, |
| 797 | 1x |
INDEX = out$id, |
| 798 | 1x |
FUN = function(x) {
|
| 799 | 4x |
(pnorm(c(x, Inf)) - |
| 800 | 4x |
pnorm(c(-Inf, x)))[-(length(x) + 1)] |
| 801 |
} |
|
| 802 |
))) |
|
| 803 | 1x |
out$est.prop <- est.prop |
| 804 | ||
| 805 | 1x |
if ("th" %in% statistic) {
|
| 806 | ! |
out$th <- th.h0 |
| 807 |
} |
|
| 808 | 1x |
if ("G2" %in% statistic) {
|
| 809 | ! |
out$G2 <- lav_tables_stat_G2( |
| 810 | ! |
out$obs.prop, out$est.prop, |
| 811 | ! |
out$nobs |
| 812 |
) |
|
| 813 |
} |
|
| 814 | 1x |
if ("X2" %in% statistic) {
|
| 815 | 1x |
out$X2 <- lav_tables_stat_X2( |
| 816 | 1x |
out$obs.prop, out$est.prop, |
| 817 | 1x |
out$nobs |
| 818 |
) |
|
| 819 |
} |
|
| 820 |
} |
|
| 821 |
} else {
|
|
| 822 | ! |
if (length(statistic) == 1L && statistic == "default") {
|
| 823 |
# if data, none by default |
|
| 824 | ! |
statistic <- character(0L) |
| 825 |
} else {
|
|
| 826 | ! |
stopifnot(statistic %in% c("th.un"))
|
| 827 |
} |
|
| 828 | ||
| 829 | ! |
if ("th.un" %in% statistic) {
|
| 830 | ! |
out$th.un <- unlist(tapply(out$obs.prop, |
| 831 | ! |
INDEX = out$id, |
| 832 | ! |
FUN = function(x) qnorm(cumsum(x)) |
| 833 |
)) |
|
| 834 |
} |
|
| 835 |
} |
|
| 836 | ||
| 837 | 1x |
out |
| 838 |
} |
|
| 839 | ||
| 840 |
# HJ 15/1/2023 MODIFIED to add sampling weights |
|
| 841 |
# compute pairwise (two-way) frequency tables |
|
| 842 |
lav_tables_pairwise_freq_cell <- function(lavdata = NULL, |
|
| 843 |
as.data.frame. = TRUE) {
|
|
| 844 |
# shortcuts |
|
| 845 | 1x |
vartable <- as.data.frame(lavdata@ov, stringsAsFactors = FALSE) |
| 846 | 1x |
X <- lavdata@X |
| 847 | 1x |
ov.names <- lavdata@ov.names |
| 848 | 1x |
ngroups <- lavdata@ngroups |
| 849 | 1x |
wt <- lavdata@weights |
| 850 | ||
| 851 |
# identify 'categorical' variables |
|
| 852 | 1x |
cat.idx <- which(vartable$type %in% c("ordered", "factor"))
|
| 853 | ||
| 854 |
# do we have any categorical variables? |
|
| 855 | 1x |
if (length(cat.idx) == 0L) {
|
| 856 | ! |
lav_msg_stop(gettext("no categorical variables are found"))
|
| 857 | 1x |
} else if (length(cat.idx) == 1L) {
|
| 858 | ! |
lav_msg_stop(gettext("at least two categorical variables are needed"))
|
| 859 |
} |
|
| 860 | ||
| 861 |
# pairwise tables |
|
| 862 | 1x |
pairwise.tables <- utils::combn(vartable$name[cat.idx], m = 2L) |
| 863 | 1x |
pairwise.tables <- rbind(pairwise.tables, seq_len(ncol(pairwise.tables))) |
| 864 | 1x |
ntables <- ncol(pairwise.tables) |
| 865 | ||
| 866 |
# for each group, for each pairwise table, collect information |
|
| 867 | 1x |
TABLES <- vector("list", length = ngroups)
|
| 868 | 1x |
for (g in 1:ngroups) {
|
| 869 | 1x |
TABLES[[g]] <- apply(pairwise.tables, |
| 870 | 1x |
MARGIN = 2, |
| 871 | 1x |
FUN = function(x) {
|
| 872 | 6x |
idx1 <- which(vartable$name == x[1]) |
| 873 | 6x |
idx2 <- which(vartable$name == x[2]) |
| 874 | 6x |
id <- (g - 1) * ntables + as.numeric(x[3]) |
| 875 | 6x |
nrow <- vartable$nlev[idx1] |
| 876 | 6x |
ncol <- vartable$nlev[idx2] |
| 877 | 6x |
ncell <- nrow * ncol |
| 878 | ||
| 879 |
# compute two-way observed frequencies |
|
| 880 | 6x |
Y1 <- X[[g]][, idx1] |
| 881 | 6x |
Y2 <- X[[g]][, idx2] |
| 882 |
# FREQ <- table(Y1, Y2) # we loose missings; useNA is ugly |
|
| 883 | 6x |
FREQ <- lav_bvord_freq(Y1, Y2) |
| 884 | ||
| 885 |
# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 886 | ||
| 887 |
# If we want to use weighted frequencies we can use the code |
|
| 888 |
# below. However, it will probably make sense only when the |
|
| 889 |
# weights are normalised. If they're not, we may get quite ugly |
|
| 890 |
# and nonsensical numbers here. So for now, just keep the |
|
| 891 |
# lavtables as is (using non-weighted frequencies). |
|
| 892 |
# |
|
| 893 |
# FREQ <- lav_bvord_freq(Y1, Y2, wt[[g]]) |
|
| 894 | ||
| 895 |
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 896 | ||
| 897 | ||
| 898 | 6x |
list( |
| 899 | 6x |
id = rep.int(id, ncell), |
| 900 | 6x |
lhs = rep.int(x[1], ncell), |
| 901 |
# op = rep.int("table", ncell),
|
|
| 902 | 6x |
rhs = rep.int(x[2], ncell), |
| 903 | 6x |
group = rep.int(g, ncell), |
| 904 | 6x |
nobs = rep.int(sum(FREQ), ncell), |
| 905 | 6x |
row = rep.int(seq_len(nrow), times = ncol), |
| 906 | 6x |
col = rep(seq_len(ncol), each = nrow), |
| 907 | 6x |
obs.freq = lav_matrix_vec(FREQ) # col by col! |
| 908 |
) |
|
| 909 |
} |
|
| 910 |
) |
|
| 911 |
} |
|
| 912 | ||
| 913 | 1x |
if (as.data.frame.) {
|
| 914 | 1x |
for (g in 1:ngroups) {
|
| 915 | 1x |
TABLE <- TABLES[[g]] |
| 916 | 1x |
TABLE <- lapply(TABLE, as.data.frame, stringsAsFactors = FALSE) |
| 917 | 1x |
if (g == 1) {
|
| 918 | 1x |
out <- do.call(rbind, TABLE) |
| 919 |
} else {
|
|
| 920 | ! |
out <- rbind(out, do.call(rbind, TABLE)) |
| 921 |
} |
|
| 922 |
} |
|
| 923 | 1x |
if (g == 1) {
|
| 924 |
# remove group column |
|
| 925 | 1x |
out$group <- NULL |
| 926 |
} |
|
| 927 |
} else {
|
|
| 928 | ! |
if (ngroups == 1L) {
|
| 929 | ! |
out <- TABLES[[1]] |
| 930 |
} else {
|
|
| 931 | ! |
out <- TABLES |
| 932 |
} |
|
| 933 |
} |
|
| 934 | ||
| 935 | 1x |
out |
| 936 |
} |
|
| 937 | ||
| 938 | ||
| 939 |
# low-level function to compute expected proportions per cell |
|
| 940 |
# object |
|
| 941 |
lav_tables_pairwise_model_pi <- function(lavobject = NULL) {
|
|
| 942 | 1x |
stopifnot(lavobject@Model@categorical) |
| 943 | ||
| 944 |
# shortcuts |
|
| 945 | 1x |
lavmodel <- lavobject@Model |
| 946 | 1x |
implied <- lavobject@implied |
| 947 | 1x |
ngroups <- lavobject@Data@ngroups |
| 948 | 1x |
ov.types <- lavobject@Data@ov$type |
| 949 | 1x |
th.idx <- lavobject@Model@th.idx |
| 950 | 1x |
Sigma.hat <- if (lavmodel@conditional.x) implied$res.cov else implied$cov |
| 951 | 1x |
TH <- if (lavmodel@conditional.x) implied$res.th else implied$th |
| 952 | ||
| 953 | 1x |
PI <- vector("list", length = ngroups)
|
| 954 | 1x |
for (g in 1:ngroups) {
|
| 955 | 1x |
Sigmahat <- Sigma.hat[[g]] |
| 956 | 1x |
cors <- Sigmahat[lower.tri(Sigmahat)] |
| 957 | 1x |
if (any(abs(cors) > 1)) {
|
| 958 | 1x |
lav_msg_warn(gettext( |
| 959 | 1x |
"some model-implied correlations are larger than 1.0")) |
| 960 |
} |
|
| 961 | 1x |
nvar <- nrow(Sigmahat) |
| 962 | ||
| 963 |
# shortcut for all ordered - tablewise |
|
| 964 | 1x |
if (all(ov.types == "ordered") && !is.null(lavobject@Cache[[g]]$long)) {
|
| 965 |
# FREQ.OBS <- c(FREQ.OBS, lavobject@Cache[[g]]$bifreq) |
|
| 966 | ! |
long2 <- lav_pml_longvec_th_rho( |
| 967 | ! |
no.x = nvar, |
| 968 | ! |
all.thres = TH[[g]], |
| 969 | ! |
index.var.of.thres = th.idx[[g]], |
| 970 | ! |
rho.xixj = cors |
| 971 |
) |
|
| 972 |
# get expected probability per table, per pair |
|
| 973 | ! |
PI[[g]] <- lav_pml_expprob_vec( |
| 974 | ! |
ind.vec = lavobject@Cache[[g]]$long, |
| 975 | ! |
th.rho.vec = long2 |
| 976 |
) |
|
| 977 |
} else {
|
|
| 978 | 1x |
PI.group <- integer(0) |
| 979 |
# order! first i, then j, lav_matrix_vec(table)! |
|
| 980 | 1x |
for (i in seq_len(nvar - 1L)) {
|
| 981 | 13x |
for (j in (i + 1L):nvar) {
|
| 982 | 91x |
if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
|
| 983 | 6x |
PI.table <- lav_bvord_noexo_pi( |
| 984 | 6x |
rho = Sigmahat[i, j], |
| 985 | 6x |
th.y1 = TH[[g]][th.idx[[g]] == i], |
| 986 | 6x |
th.y2 = TH[[g]][th.idx[[g]] == j] |
| 987 |
) |
|
| 988 | 6x |
PI.group <- c(PI.group, lav_matrix_vec(PI.table)) |
| 989 |
} |
|
| 990 |
} |
|
| 991 |
} |
|
| 992 | 1x |
PI[[g]] <- PI.group |
| 993 |
} |
|
| 994 |
} # g |
|
| 995 | ||
| 996 |
# add COR/TH/TH.IDX |
|
| 997 | 1x |
attr(PI, "COR") <- Sigma.hat |
| 998 | 1x |
attr(PI, "TH") <- TH |
| 999 | 1x |
attr(PI, "TH.IDX") <- th.idx |
| 1000 | ||
| 1001 | 1x |
PI |
| 1002 |
} |
|
| 1003 | ||
| 1004 |
# low-level function to compute expected proportions per cell |
|
| 1005 |
# using sample-based correlations + thresholds |
|
| 1006 |
# |
|
| 1007 |
# object can be either lavData or lavaan class |
|
| 1008 |
lav_tables_pairwise_sample_pi <- function(lavobject = NULL, lavdata = NULL) {
|
|
| 1009 |
# get COR, TH and th.idx |
|
| 1010 | ! |
if (!is.null(lavobject)) {
|
| 1011 | ! |
if (lavobject@Model@conditional.x) {
|
| 1012 | ! |
COR <- lavobject@SampleStats@res.cov |
| 1013 | ! |
TH <- lavobject@SampleStats@res.th |
| 1014 |
} else {
|
|
| 1015 | ! |
COR <- lavobject@SampleStats@cov |
| 1016 | ! |
TH <- lavobject@SampleStats@th |
| 1017 |
} |
|
| 1018 | ! |
TH.IDX <- lavobject@SampleStats@th.idx |
| 1019 | ! |
} else if (!is.null(lavdata)) {
|
| 1020 | ! |
fit.un <- lav_object_cor(object = lavdata, se = "none", output = "fit") |
| 1021 | ! |
if (fit.un@Model@conditional.x) {
|
| 1022 | ! |
COR <- fit.un@SampleStats@res.cov |
| 1023 | ! |
TH <- fit.un@SampleStats@res.th |
| 1024 |
} else {
|
|
| 1025 | ! |
COR <- fit.un@SampleStats@cov |
| 1026 | ! |
TH <- fit.un@SampleStats@th |
| 1027 |
} |
|
| 1028 | ! |
TH.IDX <- fit.un@SampleStats@th.idx |
| 1029 |
} else {
|
|
| 1030 | ! |
lav_msg_stop(gettext("both lavobject and lavdata are NULL"))
|
| 1031 |
} |
|
| 1032 | ||
| 1033 | ! |
lav_tables_pairwise_sample_pi_cor( |
| 1034 | ! |
COR = COR, TH = TH, |
| 1035 | ! |
TH.IDX = TH.IDX |
| 1036 |
) |
|
| 1037 |
} |
|
| 1038 | ||
| 1039 |
# low-level function to compute expected proportions per cell |
|
| 1040 |
lav_tables_pairwise_sample_pi_cor <- function(COR = NULL, TH = NULL, |
|
| 1041 |
TH.IDX = NULL) {
|
|
| 1042 | ! |
ngroups <- length(COR) |
| 1043 | ||
| 1044 | ! |
PI <- vector("list", length = ngroups)
|
| 1045 | ! |
for (g in 1:ngroups) {
|
| 1046 | ! |
Sigmahat <- COR[[g]] |
| 1047 | ! |
cors <- Sigmahat[lower.tri(Sigmahat)] |
| 1048 | ! |
if (any(abs(cors) > 1)) {
|
| 1049 | ! |
lav_msg_warn(gettext( |
| 1050 | ! |
"some model-implied correlations are larger than 1.0")) |
| 1051 |
} |
|
| 1052 | ! |
nvar <- nrow(Sigmahat) |
| 1053 | ! |
th.idx <- TH.IDX[[g]] |
| 1054 | ||
| 1055 |
# reconstruct ov.types |
|
| 1056 | ! |
ov.types <- rep("numeric", nvar)
|
| 1057 | ! |
ord.idx <- unique(th.idx[th.idx > 0]) |
| 1058 | ! |
ov.types[ord.idx] <- "ordered" |
| 1059 | ||
| 1060 | ! |
PI.group <- integer(0) |
| 1061 |
# order! first i, then j, lav_matrix_vec(table)! |
|
| 1062 | ! |
for (i in seq_len(nvar - 1L)) {
|
| 1063 | ! |
for (j in (i + 1L):nvar) {
|
| 1064 | ! |
if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
|
| 1065 | ! |
PI.table <- lav_bvord_noexo_pi( |
| 1066 | ! |
rho = Sigmahat[i, j], |
| 1067 | ! |
th.y1 = TH[[g]][th.idx == i], |
| 1068 | ! |
th.y2 = TH[[g]][th.idx == j] |
| 1069 |
) |
|
| 1070 | ! |
PI.group <- c(PI.group, lav_matrix_vec(PI.table)) |
| 1071 |
} |
|
| 1072 |
} |
|
| 1073 |
} |
|
| 1074 | ! |
PI[[g]] <- PI.group |
| 1075 |
} # g |
|
| 1076 | ||
| 1077 |
# add COR/TH/TH.IDX |
|
| 1078 | ! |
attr(PI, "COR") <- COR |
| 1079 | ! |
attr(PI, "TH") <- TH |
| 1080 | ! |
attr(PI, "TH.IDX") <- TH.IDX |
| 1081 | ||
| 1082 | ! |
PI |
| 1083 |
} |
|
| 1084 | ||
| 1085 |
# low-level function to compute expected proportions per PATTERN |
|
| 1086 |
# using sample-based correlations + thresholds |
|
| 1087 |
# |
|
| 1088 |
# object can be either lavData or lavaan class |
|
| 1089 |
# |
|
| 1090 |
# only valid if estimator = FML, POM or NOR |
|
| 1091 |
# |
|
| 1092 |
lav_tables_resp_pi <- function(lavobject = NULL, lavdata = NULL, |
|
| 1093 |
est = "h0") {
|
|
| 1094 |
# shortcuts |
|
| 1095 | ! |
if (!is.null(lavobject)) {
|
| 1096 | ! |
lavmodel <- lavobject@Model |
| 1097 | ! |
implied <- lavobject@implied |
| 1098 |
} |
|
| 1099 | ! |
ngroups <- lavdata@ngroups |
| 1100 | ||
| 1101 |
# h0 or unrestricted? |
|
| 1102 | ! |
if (est == "h0") {
|
| 1103 | ! |
Sigma.hat <- if (lavmodel@conditional.x) implied$res.cov else implied$cov |
| 1104 | ! |
TH <- if (lavmodel@conditional.x) implied$res.th else implied$th |
| 1105 | ! |
TH.IDX <- lavobject@SampleStats@th.idx |
| 1106 |
} else {
|
|
| 1107 | ! |
if (is.null(lavobject)) {
|
| 1108 | ! |
fit.un <- lav_object_cor(object = lavdata, se = "none", output = "fit") |
| 1109 | ! |
Sigma.hat <- if (fit.un@Model@conditional.x) fit.un@implied$res.cov else fit.un@implied$cov |
| 1110 | ! |
TH <- if (fit.un@Model@conditional.x) fit.un@implied$res.th else fit.un@implied$th |
| 1111 | ! |
TH.IDX <- fit.un@SampleStats@th.idx |
| 1112 |
} else {
|
|
| 1113 | ! |
if (lavobject@Model@conditional.x) {
|
| 1114 | ! |
Sigma.hat <- lavobject@SampleStats@res.cov |
| 1115 | ! |
TH <- lavobject@SampleStats@res.th |
| 1116 |
} else {
|
|
| 1117 | ! |
Sigma.hat <- lavobject@SampleStats@cov |
| 1118 | ! |
TH <- lavobject@SampleStats@th |
| 1119 |
} |
|
| 1120 | ! |
TH.IDX <- lavobject@SampleStats@th.idx |
| 1121 |
} |
|
| 1122 |
} |
|
| 1123 | ||
| 1124 | ! |
PI <- vector("list", length = ngroups)
|
| 1125 | ! |
for (g in 1:ngroups) {
|
| 1126 | ! |
Sigmahat <- Sigma.hat[[g]] |
| 1127 | ! |
cors <- Sigmahat[lower.tri(Sigmahat)] |
| 1128 | ! |
if (any(abs(cors) > 1)) {
|
| 1129 | ! |
lav_msg_warn(gettext( |
| 1130 | ! |
"some model-implied correlations are larger than 1.0")) |
| 1131 |
} |
|
| 1132 | ! |
nvar <- nrow(Sigmahat) |
| 1133 | ! |
th.idx <- TH.IDX[[g]] |
| 1134 | ! |
MEAN <- rep(0, nvar) |
| 1135 | ||
| 1136 |
# reconstruct ov.types |
|
| 1137 | ! |
ov.types <- rep("numeric", nvar)
|
| 1138 | ! |
ord.idx <- unique(th.idx[th.idx > 0]) |
| 1139 | ! |
ov.types[ord.idx] <- "ordered" |
| 1140 | ||
| 1141 | ! |
if (all(ov.types == "ordered")) {
|
| 1142 |
# get patterns ## FIXME GET it |
|
| 1143 | ! |
if (!is.null(lavdata@Rp[[g]]$pat)) {
|
| 1144 | ! |
PAT <- lavdata@Rp[[g]]$pat |
| 1145 |
} else {
|
|
| 1146 | ! |
PAT <- lav_data_resp_patterns(lavdata@X[[g]])$pat |
| 1147 |
} |
|
| 1148 | ! |
npatterns <- nrow(PAT) |
| 1149 | ! |
freq <- as.numeric(rownames(PAT)) |
| 1150 | ! |
PI.group <- numeric(npatterns) |
| 1151 | ! |
TH.VAR <- lapply( |
| 1152 | ! |
1:nvar, |
| 1153 | ! |
function(x) c(-Inf, TH[[g]][th.idx == x], +Inf) |
| 1154 |
) |
|
| 1155 |
# FIXME!!! ok to set diagonal to 1.0? |
|
| 1156 | ! |
diag(Sigmahat) <- 1.0 |
| 1157 | ! |
for (r in 1:npatterns) {
|
| 1158 |
# compute probability for each pattern |
|
| 1159 | ! |
lower <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x]]) |
| 1160 | ! |
upper <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x] + 1L]) |
| 1161 |
# handle missing values |
|
| 1162 | ! |
na.idx <- which(is.na(PAT[r, ])) |
| 1163 | ! |
if (length(na.idx) > 0L) {
|
| 1164 | ! |
lower <- lower[-na.idx] |
| 1165 | ! |
upper <- upper[-na.idx] |
| 1166 | ! |
MEAN.r <- MEAN[-na.idx] |
| 1167 | ! |
Sigmahat.r <- Sigmahat[-na.idx, -na.idx, drop = FALSE] |
| 1168 |
} else {
|
|
| 1169 | ! |
MEAN.r <- MEAN |
| 1170 | ! |
Sigmahat.r <- Sigmahat |
| 1171 |
} |
|
| 1172 | ! |
PI.group[r] <- sadmvn(lower, upper, |
| 1173 | ! |
mean = MEAN.r, |
| 1174 | ! |
varcov = Sigmahat.r |
| 1175 |
) |
|
| 1176 |
} |
|
| 1177 |
} else { # case-wise
|
|
| 1178 | ! |
PI.group <- rep(as.numeric(NA), lavdata@nobs[[g]]) |
| 1179 | ! |
lav_msg_warn(gettext("casewise PI not implemented"))
|
| 1180 |
} |
|
| 1181 | ||
| 1182 | ! |
PI[[g]] <- PI.group |
| 1183 |
} # g |
|
| 1184 | ||
| 1185 | ! |
PI |
| 1186 |
} |
|
| 1187 | ||
| 1188 |
lav_tables_table_format <- function(out, lavdata = lavdata, |
|
| 1189 |
lavobject = lavobject) {
|
|
| 1190 |
# determine column we need |
|
| 1191 | ! |
NAMES <- names(out) |
| 1192 | ! |
stat.idx <- which(NAMES %in% c( |
| 1193 | ! |
"cor", "cor.un", |
| 1194 | ! |
"G2", "G2.un", |
| 1195 | ! |
"X2", "X2.un", |
| 1196 | ! |
"RMSEA", "RMSEA.un", |
| 1197 | ! |
"G2.average", "G2.plarge", "G2.nlarge", |
| 1198 | ! |
"X2.average", "X2.plarge", "X2.nlarge" |
| 1199 |
)) |
|
| 1200 | ! |
if (length(stat.idx) == 0) {
|
| 1201 | ! |
if (!is.null(out$obs.freq)) {
|
| 1202 | ! |
stat.idx <- which(NAMES == "obs.freq") |
| 1203 | ! |
} else if (!is.null(out$nobs)) {
|
| 1204 | ! |
stat.idx <- which(NAMES == "nobs") |
| 1205 |
} |
|
| 1206 | ! |
UNI <- NULL |
| 1207 | ! |
} else if (length(stat.idx) > 1) {
|
| 1208 | ! |
lav_msg_stop(gettext( |
| 1209 | ! |
"more than one statistic for table output:"), |
| 1210 | ! |
paste(NAMES[stat.idx], collapse = " ") |
| 1211 |
) |
|
| 1212 |
} else {
|
|
| 1213 |
# univariate version of same statistic |
|
| 1214 | ! |
if (NAMES[stat.idx] == "G2.average") {
|
| 1215 | ! |
UNI <- lavTables(lavobject, dimension = 1L, statistic = "G2") |
| 1216 | ! |
} else if (NAMES[stat.idx] == "X2.average") {
|
| 1217 | ! |
UNI <- lavTables(lavobject, dimension = 1L, statistic = "X2") |
| 1218 |
} else {
|
|
| 1219 | ! |
UNI <- NULL |
| 1220 |
} |
|
| 1221 |
} |
|
| 1222 | ||
| 1223 | ! |
OUT <- vector("list", length = lavdata@ngroups)
|
| 1224 | ! |
for (g in 1:lavdata@ngroups) {
|
| 1225 | ! |
if (lavdata@ngroups == 1L) { # no group column
|
| 1226 | ! |
STAT <- out[[stat.idx]] |
| 1227 |
} else {
|
|
| 1228 | ! |
STAT <- out[[stat.idx]][out$group == g] |
| 1229 |
} |
|
| 1230 | ! |
RN <- lavdata@ov.names[[g]] |
| 1231 | ! |
OUT[[g]] <- lav_getcov(STAT, diagonal = FALSE, lower = FALSE, names = RN) |
| 1232 |
# change diagonal elements: replace by univariate stat |
|
| 1233 |
# if possible |
|
| 1234 | ! |
diag(OUT[[g]]) <- as.numeric(NA) |
| 1235 | ! |
if (!is.null(UNI)) {
|
| 1236 | ! |
if (!is.null(UNI$group)) {
|
| 1237 | ! |
idx <- which(UNI$group == g) |
| 1238 |
} else {
|
|
| 1239 | ! |
idx <- 1:length(UNI$lhs) |
| 1240 |
} |
|
| 1241 | ! |
if (NAMES[stat.idx] == "G2.average") {
|
| 1242 | ! |
diag(OUT[[g]]) <- tapply(UNI$G2[idx], |
| 1243 | ! |
INDEX = UNI$id[idx], |
| 1244 | ! |
FUN = mean |
| 1245 |
) |
|
| 1246 | ! |
} else if (NAMES[stat.idx] == "X2.average") {
|
| 1247 | ! |
diag(OUT[[g]]) <- tapply(UNI$X2[idx], |
| 1248 | ! |
INDEX = UNI$id[idx], |
| 1249 | ! |
FUN = mean |
| 1250 |
) |
|
| 1251 |
} |
|
| 1252 | ! |
} else if (NAMES[stat.idx] %in% c("cor", "cor.un")) {
|
| 1253 | ! |
diag(OUT[[g]]) <- 1 |
| 1254 |
} |
|
| 1255 | ! |
class(OUT[[g]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 1256 |
} |
|
| 1257 | ! |
if (lavdata@ngroups > 1L) {
|
| 1258 | ! |
names(OUT) <- lavdata@group.label |
| 1259 | ! |
out <- OUT |
| 1260 |
} else {
|
|
| 1261 | ! |
out <- OUT[[1]] |
| 1262 |
} |
|
| 1263 | ||
| 1264 | ! |
out |
| 1265 |
} |
|
| 1266 | ||
| 1267 |
lav_tables_cells_format <- function(out, lavdata = lavdata, |
|
| 1268 |
drop.list.single.group = FALSE) {
|
|
| 1269 | ! |
OUT <- vector("list", length = lavdata@ngroups)
|
| 1270 | ! |
if (is.null(out$group)) {
|
| 1271 | ! |
out$group <- rep(1L, length(out$lhs)) |
| 1272 |
} |
|
| 1273 |
# do we have a statistic? |
|
| 1274 |
# determine column we need |
|
| 1275 | ! |
NAMES <- names(out) |
| 1276 | ! |
stat.idx <- which(NAMES %in% c( |
| 1277 | ! |
"cor", "cor.un", |
| 1278 | ! |
"G2", "G2.un", |
| 1279 | ! |
"X2", "X2.un", |
| 1280 | ! |
"RMSEA", "RMSEA.un", |
| 1281 | ! |
"G2.average", "G2.plarge", "G2.nlarge", |
| 1282 | ! |
"X2.average", "X2.plarge", "X2.nlarge" |
| 1283 |
)) |
|
| 1284 | ! |
if (length(stat.idx) == 0) {
|
| 1285 | ! |
statistic <- "obs.freq" |
| 1286 | ! |
} else if (length(stat.idx) > 1) {
|
| 1287 | ! |
lav_msg_stop(gettext( |
| 1288 | ! |
"more than one statistic for table output:"), |
| 1289 | ! |
paste(NAMES[stat.idx], collapse = " ") |
| 1290 |
) |
|
| 1291 |
} else {
|
|
| 1292 | ! |
statistic <- NAMES[stat.idx] |
| 1293 |
} |
|
| 1294 | ||
| 1295 | ! |
for (g in 1:lavdata@ngroups) {
|
| 1296 | ! |
case.idx <- which(out$group == g) |
| 1297 | ! |
ID.group <- unique(out$id[out$group == g]) |
| 1298 | ! |
TMP <- lapply(ID.group, function(x) {
|
| 1299 | ! |
Tx <- out[out$id == x, ] |
| 1300 | ! |
M <- matrix( |
| 1301 | ! |
Tx[, statistic], |
| 1302 | ! |
max(Tx$row), max(Tx$col) |
| 1303 |
) |
|
| 1304 | ! |
rownames(M) <- unique(Tx$row) |
| 1305 | ! |
colnames(M) <- unique(Tx$col) |
| 1306 | ! |
class(M) <- c("lavaan.matrix", "matrix")
|
| 1307 | ! |
M |
| 1308 |
}) |
|
| 1309 | ! |
names(TMP) <- unique(paste(out$lhs[case.idx], out$rhs[case.idx], |
| 1310 | ! |
sep = "_" |
| 1311 |
)) |
|
| 1312 | ! |
OUT[[g]] <- TMP |
| 1313 |
} |
|
| 1314 | ||
| 1315 | ! |
if (lavdata@ngroups == 1L && drop.list.single.group) {
|
| 1316 | ! |
OUT <- OUT[[1]] |
| 1317 |
} else {
|
|
| 1318 | ! |
if (length(lavdata@group.label) > 0L) {
|
| 1319 | ! |
names(OUT) <- unlist(lavdata@group.label) |
| 1320 |
} |
|
| 1321 |
} |
|
| 1322 | ||
| 1323 | ! |
OUT |
| 1324 |
} |
|
| 1325 | ||
| 1326 | ||
| 1327 | ||
| 1328 |
# The function lav_tables_univariate_freq_cell computes the univariate (one-way) frequency tables. |
|
| 1329 |
# The function closely folows the "logic" of the lavaan function |
|
| 1330 |
# lav_tables_pairwise_freq_cell. |
|
| 1331 |
# The output is either a list or a data.frame depending on the value the logical |
|
| 1332 |
# input argument as.data.frame. Either way, the same information is contained which is: |
|
| 1333 |
# a) the observed (univariate) frequencies f_ia, i=1,...,p (variables), |
|
| 1334 |
# a=1,...,ci (response categories), with a index running faster than i index. |
|
| 1335 |
# b) an index vector with the name varb which indicates which variable each frequency refers to. |
|
| 1336 |
# c) an index vector with the name group which indicates which group each frequency |
|
| 1337 |
# refers to when multi-group analysis. |
|
| 1338 |
# d) an index vector with the name level which indicates which level within |
|
| 1339 |
# each ordinal variable each frequency refers to. |
|
| 1340 |
# e) a vector nobs which gives how many cases where considered to compute the |
|
| 1341 |
# corresponding frequency. Since we use the available data for each variable |
|
| 1342 |
# when missing=="available_cases" we expect these numbers to differ when |
|
| 1343 |
# missing values are present. |
|
| 1344 |
# f) an index vector with the name id indexing each univariate table, |
|
| 1345 |
# 1 goes to first variable in the first group, 2 to 2nd variable in the second |
|
| 1346 |
# group and so on. The last table has the index equal to (no of groups)*(no of variables). |
|
| 1347 | ||
| 1348 |
lav_tables_univariate_freq_cell <- function(lavdata = NULL, |
|
| 1349 |
as.data.frame. = TRUE) {
|
|
| 1350 |
# shortcuts |
|
| 1351 | ! |
vartable <- as.data.frame(lavdata@ov, stringsAsFactors = FALSE) |
| 1352 | ! |
X <- lavdata@X |
| 1353 | ! |
ov.names <- lavdata@ov.names |
| 1354 | ! |
ngroups <- lavdata@ngroups |
| 1355 | ||
| 1356 |
# identify 'categorical' variables |
|
| 1357 | ! |
cat.idx <- which(vartable$type %in% c("ordered", "factor"))
|
| 1358 | ||
| 1359 |
# do we have any categorical variables? |
|
| 1360 | ! |
if (length(cat.idx) == 0L) {
|
| 1361 | ! |
lav_msg_stop(gettext("no categorical variables are found"))
|
| 1362 |
} |
|
| 1363 | ||
| 1364 |
# univariate tables |
|
| 1365 | ! |
univariate.tables <- vartable$name[cat.idx] |
| 1366 | ! |
univariate.tables <- rbind(univariate.tables, |
| 1367 | ! |
seq_len(length(univariate.tables)), |
| 1368 | ! |
deparse.level = 0 |
| 1369 |
) |
|
| 1370 | ! |
ntables <- ncol(univariate.tables) |
| 1371 | ||
| 1372 |
# for each group, for each pairwise table, collect information |
|
| 1373 | ! |
UNI_TABLES <- vector("list", length = ngroups)
|
| 1374 | ! |
for (g in 1:ngroups) {
|
| 1375 | ! |
UNI_TABLES[[g]] <- apply(univariate.tables, |
| 1376 | ! |
MARGIN = 2, |
| 1377 | ! |
FUN = function(x) {
|
| 1378 | ! |
idx1 <- which(vartable$name == x[1]) |
| 1379 | ! |
id <- (g - 1) * ntables + as.numeric(x[2]) |
| 1380 | ! |
ncell <- vartable$nlev[idx1] |
| 1381 | ||
| 1382 |
# compute one-way observed frequencies |
|
| 1383 | ! |
Y1 <- X[[g]][, idx1] |
| 1384 | ! |
UNI_FREQ <- tabulate(Y1, nbins = max(Y1, na.rm = TRUE)) |
| 1385 | ||
| 1386 | ! |
list( |
| 1387 | ! |
id = rep.int(id, ncell), |
| 1388 | ! |
varb = rep.int(x[1], ncell), |
| 1389 | ! |
group = rep.int(g, ncell), |
| 1390 | ! |
nobs = rep.int(sum(UNI_FREQ), ncell), |
| 1391 | ! |
level = seq_len(ncell), |
| 1392 | ! |
obs.freq = UNI_FREQ |
| 1393 |
) |
|
| 1394 |
} |
|
| 1395 |
) |
|
| 1396 |
} |
|
| 1397 | ||
| 1398 | ! |
if (as.data.frame.) {
|
| 1399 | ! |
for (g in 1:ngroups) {
|
| 1400 | ! |
UNI_TABLE <- UNI_TABLES[[g]] |
| 1401 | ! |
UNI_TABLE <- lapply(UNI_TABLE, as.data.frame, |
| 1402 | ! |
stringsAsFactors = FALSE |
| 1403 |
) |
|
| 1404 | ! |
if (g == 1) {
|
| 1405 | ! |
out <- do.call(rbind, UNI_TABLE) |
| 1406 |
} else {
|
|
| 1407 | ! |
out <- rbind(out, do.call(rbind, UNI_TABLE)) |
| 1408 |
} |
|
| 1409 |
} |
|
| 1410 | ! |
if (g == 1) {
|
| 1411 |
# remove group column |
|
| 1412 | ! |
out$group <- NULL |
| 1413 |
} |
|
| 1414 |
} else {
|
|
| 1415 | ! |
if (ngroups == 1L) {
|
| 1416 | ! |
out <- UNI_TABLES[[1]] |
| 1417 |
} else {
|
|
| 1418 | ! |
out <- UNI_TABLES |
| 1419 |
} |
|
| 1420 |
} |
|
| 1421 | ||
| 1422 | ! |
out |
| 1423 |
} |
| 1 |
# utility functions for pairwise maximum likelihood |
|
| 2 | ||
| 3 |
# stub for lav_pml_fml_dploglik_dimplied |
|
| 4 |
lav_pml_fml_dploglik_dimplied <- function(Sigma.hat = NULL, # model-based var/cov/cor |
|
| 5 |
TH = NULL, # model-based thresholds + means |
|
| 6 |
th.idx = NULL, # threshold idx per variable |
|
| 7 |
num.idx = NULL, # which variables are numeric |
|
| 8 |
X = NULL, # data |
|
| 9 |
eXo = NULL, # external covariates |
|
| 10 |
lavcache = NULL, # housekeeping stuff |
|
| 11 |
scores = FALSE, # return case-wise scores |
|
| 12 |
negative = TRUE) {
|
|
| 13 | ! |
lav_msg_stop(gettext("not implemented"))
|
| 14 |
} |
|
| 15 | ||
| 16 |
# the first derivative of the pairwise logLik function with respect to the |
|
| 17 |
# thresholds/slopes/var/correlations; together with DELTA, we can use the |
|
| 18 |
# chain rule to get the gradient |
|
| 19 |
# this is adapted from code written by Myrsini Katsikatsou |
|
| 20 |
# first attempt - YR 5 okt 2012 |
|
| 21 |
# HJ 18/10/23: Modification for complex design and completely observed data (no |
|
| 22 |
# missing) with only ordinal indicators to get the right gradient for the |
|
| 23 |
# optimisation and Hessian computation. |
|
| 24 |
lav_pml_dploglik_dimplied <- function(Sigma.hat = NULL, # model-based var/cov/cor |
|
| 25 |
Mu.hat = NULL, # model-based means |
|
| 26 |
TH = NULL, # model-based thresholds + means |
|
| 27 |
th.idx = NULL, # threshold idx per variable |
|
| 28 |
num.idx = NULL, # which variables are numeric |
|
| 29 |
X = NULL, # data |
|
| 30 |
eXo = NULL, # external covariates |
|
| 31 |
wt = NULL, # case weights (not used yet) |
|
| 32 |
lavcache = NULL, # housekeeping stuff |
|
| 33 |
PI = NULL, # slopes |
|
| 34 |
missing = "listwise", # how to deal with missings |
|
| 35 |
scores = FALSE, # return case-wise scores |
|
| 36 |
negative = TRUE) { # multiply by -1
|
|
| 37 | ||
| 38 |
# diagonal of Sigma.hat is not necessarily 1, even for categorical vars |
|
| 39 | ! |
Sigma.hat2 <- Sigma.hat |
| 40 | ! |
if (length(num.idx) > 0L) {
|
| 41 | ! |
diag(Sigma.hat2)[-num.idx] <- 1 |
| 42 |
} else {
|
|
| 43 | ! |
diag(Sigma.hat2) <- 1 |
| 44 |
} |
|
| 45 | ! |
Cor.hat <- cov2cor(Sigma.hat2) # to get correlations (rho!) |
| 46 | ! |
cors <- lav_matrix_vech(Cor.hat, diagonal = FALSE) |
| 47 | ||
| 48 | ! |
if (any(abs(cors) > 1)) {
|
| 49 |
# what should we do now... force cov2cor? |
|
| 50 |
# cat("FFFFOOOORRRRRCEEE PD!\n")
|
|
| 51 |
# Sigma.hat <- Matrix::nearPD(Sigma.hat) |
|
| 52 |
# Sigma.hat <- as.matrix(Sigma.hat$mat) |
|
| 53 |
# Sigma.hat <- cov2cor(Sigma.hat) |
|
| 54 |
# cors <- Sigma.hat[lower.tri(Sigma.hat)] |
|
| 55 | ! |
idx <- which(abs(cors) > 0.99) |
| 56 | ! |
cors[idx] <- 0.99 # clip |
| 57 |
# cat("CLIPPING!\n")
|
|
| 58 |
} |
|
| 59 | ||
| 60 | ! |
nvar <- nrow(Sigma.hat) |
| 61 | ! |
pstar <- nvar * (nvar - 1) / 2 |
| 62 | ! |
ov.types <- rep("ordered", nvar)
|
| 63 | ! |
if (length(num.idx) > 0L) ov.types[num.idx] <- "numeric" |
| 64 | ! |
if (!is.null(eXo)) {
|
| 65 | ! |
nexo <- ncol(eXo) |
| 66 |
} else {
|
|
| 67 | ! |
nexo <- 0 |
| 68 |
} |
|
| 69 | ||
| 70 | ||
| 71 | ! |
if (all(ov.types == "numeric")) {
|
| 72 | ! |
N.TH <- nvar |
| 73 |
} else {
|
|
| 74 | ! |
N.TH <- length(th.idx) |
| 75 |
} |
|
| 76 | ! |
N.SL <- nvar * nexo |
| 77 | ! |
N.VAR <- length(num.idx) |
| 78 | ! |
N.COR <- pstar |
| 79 | ||
| 80 |
# add num.idx to th.idx |
|
| 81 | ! |
if (length(num.idx) > 0L) {
|
| 82 | ! |
th.idx[th.idx == 0] <- num.idx |
| 83 |
} |
|
| 84 | ||
| 85 |
# print(Sigma.hat); print(TH); print(th.idx); print(num.idx); print(str(X)) |
|
| 86 | ||
| 87 |
# shortcut for ordinal-only/no-exo case |
|
| 88 | ! |
if (!scores && all(ov.types == "ordered") && nexo == 0L) {
|
| 89 |
# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 90 | ||
| 91 | ! |
if (is.null(wt)) {
|
| 92 | ! |
n.xixj.vec <- lavcache$bifreq |
| 93 |
} else {
|
|
| 94 | ! |
n.xixj.vec <- lavcache$sum_obs_weights_xixj_ab_vec |
| 95 |
} |
|
| 96 | ! |
gradient <- lav_pml_grad_tau_rho( |
| 97 | ! |
no.x = nvar, |
| 98 | ! |
all.thres = TH, |
| 99 | ! |
index.var.of.thres = th.idx, |
| 100 | ! |
rho.xixj = cors, |
| 101 | ! |
n.xixj.vec = n.xixj.vec, |
| 102 | ! |
out.lav_pml_longvec_ind = lavcache$long |
| 103 |
) |
|
| 104 | ||
| 105 |
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 106 | ||
| 107 | ! |
if (missing == "available.cases") {
|
| 108 | ! |
uniPI <- lav_pml_th_uni_prob(TH = TH, th.idx = th.idx) |
| 109 | ! |
tmp <- lavcache$uniweights / uniPI |
| 110 | ||
| 111 | ! |
var.idx <- split(th.idx, th.idx) |
| 112 | ! |
var.idx <- unlist(lapply(var.idx, function(x) {
|
| 113 | ! |
c(x, x[1]) |
| 114 |
})) |
|
| 115 | ||
| 116 | ! |
tmp.varwise <- split(tmp, var.idx) |
| 117 | ! |
tmp1 <- unlist(lapply( |
| 118 | ! |
tmp.varwise, |
| 119 | ! |
function(x) {
|
| 120 | ! |
c(x[-length(x)]) |
| 121 |
} |
|
| 122 |
)) |
|
| 123 | ! |
tmp2 <- unlist(lapply(tmp.varwise, function(x) {
|
| 124 | ! |
c(x[-1]) |
| 125 |
})) |
|
| 126 | ||
| 127 | ! |
uni.der.tau <- dnorm(TH) * (tmp1 - tmp2) |
| 128 | ! |
nTH <- length(TH) |
| 129 | ! |
gradient[1:nTH] <- gradient[1:nTH] + uni.der.tau |
| 130 |
} |
|
| 131 | ||
| 132 | ! |
if (negative) {
|
| 133 | ! |
gradient <- -1 * gradient |
| 134 |
} |
|
| 135 | ! |
return(gradient) |
| 136 |
} |
|
| 137 | ||
| 138 |
# in this order: TH/MEANS + SLOPES + VAR + COR |
|
| 139 | ! |
GRAD.size <- N.TH + N.SL + N.VAR + N.COR |
| 140 | ||
| 141 |
# scores or gradient? |
|
| 142 | ! |
if (scores) {
|
| 143 | ! |
SCORES <- matrix(0, nrow(X), GRAD.size) # we will sum up over all pairs |
| 144 |
} else {
|
|
| 145 | ! |
GRAD <- matrix(0, pstar, GRAD.size) # each pair is a row |
| 146 |
} |
|
| 147 | ! |
PSTAR <- matrix(0, nvar, nvar) # utility matrix, to get indices |
| 148 | ! |
PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar |
| 149 | ! |
N <- length(X[, 1]) |
| 150 | ||
| 151 | ! |
for (j in seq_len(nvar - 1L)) {
|
| 152 | ! |
for (i in (j + 1L):nvar) {
|
| 153 |
# cat(" i = ", i, " j = ", j, "\n") # debug only
|
|
| 154 | ! |
pstar.idx <- PSTAR[i, j] |
| 155 | ! |
cor.idx <- N.TH + N.SL + N.VAR + PSTAR[i, j] |
| 156 | ! |
th.idx_i <- which(th.idx == i) |
| 157 | ! |
th.idx_j <- which(th.idx == j) |
| 158 | ! |
if (nexo > 0L) {
|
| 159 | ! |
sl.idx_i <- N.TH + seq(i, by = nvar, length.out = nexo) |
| 160 | ! |
sl.idx_j <- N.TH + seq(j, by = nvar, length.out = nexo) |
| 161 | ||
| 162 | ! |
if (length(num.idx) > 0L) {
|
| 163 | ! |
var.idx_i <- N.TH + N.SL + match(i, num.idx) |
| 164 | ! |
var.idx_j <- N.TH + N.SL + match(j, num.idx) |
| 165 |
} |
|
| 166 |
} else {
|
|
| 167 | ! |
if (length(num.idx) > 0L) {
|
| 168 | ! |
var.idx_i <- N.TH + match(i, num.idx) |
| 169 | ! |
var.idx_j <- N.TH + match(j, num.idx) |
| 170 |
} |
|
| 171 |
} |
|
| 172 | ! |
if (ov.types[i] == "numeric" && ov.types[j] == "numeric") {
|
| 173 | ! |
if (nexo > 1L) {
|
| 174 | ! |
lav_msg_stop(gettext( |
| 175 | ! |
"mixed + exo in PML not implemented; |
| 176 | ! |
try optim.gradient = \"numerical\"")) |
| 177 |
} |
|
| 178 | ||
| 179 | ! |
SC <- lav_mvnorm_scores_mu_vech_sigma( |
| 180 | ! |
Y = X[, c(i, j)], |
| 181 | ! |
Mu = Mu.hat[c(i, j)], Sigma = Sigma.hat[c(i, j), c(i, j)] |
| 182 |
) |
|
| 183 | ||
| 184 | ! |
if (scores) {
|
| 185 | ! |
if (all(ov.types == "numeric") && nexo == 0L) {
|
| 186 |
# MU1 + MU2 |
|
| 187 | ! |
SCORES[, c(i, j)] <- SCORES[, c(i, j)] + SC[, c(1, 2)] |
| 188 |
# VAR1 + COV_12 + VAR2 |
|
| 189 | ! |
var.idx <- (nvar + |
| 190 | ! |
lav_matrix_vech_match_idx(nvar, idx = c(i, j))) |
| 191 | ! |
SCORES[, var.idx] <- SCORES[, var.idx] + SC[, c(3, 4, 5)] |
| 192 |
} else { # mixed ordered/continuous
|
|
| 193 |
# MU |
|
| 194 | ! |
mu.idx <- c(th.idx_i, th.idx_j) |
| 195 | ! |
SCORES[, mu.idx] <- SCORES[, mu.idx] + (-1) * SC[, c(1, 2)] |
| 196 |
# VAR+COV |
|
| 197 | ! |
var.idx <- c(var.idx_i, cor.idx, var.idx_j) |
| 198 | ! |
SCORES[, var.idx] <- SCORES[, var.idx] + SC[, c(3, 4, 5)] |
| 199 |
} |
|
| 200 |
} else {
|
|
| 201 | ! |
if (all(ov.types == "numeric") && nexo == 0L) {
|
| 202 | ! |
mu.idx <- c(i, j) |
| 203 | ! |
sigma.idx <- (nvar + |
| 204 | ! |
lav_matrix_vech_match_idx(nvar, idx = c(i, j))) |
| 205 |
# MU1 + MU2 |
|
| 206 | ! |
GRAD[pstar.idx, mu.idx] <- |
| 207 | ! |
colSums(SC[, c(1, 2)], na.rm = TRUE) |
| 208 |
} else {
|
|
| 209 | ! |
mu.idx <- c(th.idx_i, th.idx_j) |
| 210 | ! |
sigma.idx <- c(var.idx_i, cor.idx, var.idx_j) |
| 211 |
# MU (reverse sign!) |
|
| 212 | ! |
GRAD[pstar.idx, mu.idx] <- |
| 213 | ! |
-1 * colSums(SC[, c(1, 2)], na.rm = TRUE) |
| 214 |
} |
|
| 215 |
# SIGMA |
|
| 216 | ! |
GRAD[pstar.idx, sigma.idx] <- |
| 217 | ! |
colSums(SC[, c(3, 4, 5)], na.rm = TRUE) |
| 218 |
} # gradient only |
|
| 219 | ! |
} else if (ov.types[i] == "numeric" && ov.types[j] == "ordered") {
|
| 220 |
# polyserial correlation |
|
| 221 | ! |
if (nexo > 1L) {
|
| 222 | ! |
lav_msg_stop(gettext( |
| 223 | ! |
"mixed + exo in PML not implemented; |
| 224 | ! |
try optim.gradient = \"numerical\"")) |
| 225 |
} |
|
| 226 | ||
| 227 | ! |
SC.COR.UNI <- lav_bvmix_cor_scores( |
| 228 | ! |
Y1 = X[, i], Y2 = X[, j], |
| 229 | ! |
eXo = NULL, wt = wt, |
| 230 | ! |
evar.y1 = Sigma.hat[i, i], |
| 231 | ! |
beta.y1 = Mu.hat[i], |
| 232 | ! |
th.y2 = TH[th.idx == j], |
| 233 | ! |
sl.y2 = NULL, |
| 234 | ! |
rho = Cor.hat[i, j], |
| 235 | ! |
sigma.correction = TRUE |
| 236 |
) |
|
| 237 | ||
| 238 | ! |
if (scores) {
|
| 239 |
# MU |
|
| 240 | ! |
SCORES[, th.idx_i] <- (SCORES[, th.idx_i] + |
| 241 | ! |
-1 * SC.COR.UNI$dx.mu.y1) |
| 242 |
# TH |
|
| 243 | ! |
SCORES[, th.idx_j] <- (SCORES[, th.idx_j] + |
| 244 | ! |
SC.COR.UNI$dx.th.y2) |
| 245 |
# VAR |
|
| 246 | ! |
SCORES[, var.idx_i] <- (SCORES[, var.idx_i] + |
| 247 | ! |
SC.COR.UNI$dx.var.y1) |
| 248 |
# COR |
|
| 249 | ! |
SCORES[, cor.idx] <- (SCORES[, cor.idx] + |
| 250 | ! |
SC.COR.UNI$dx.rho) |
| 251 |
} else {
|
|
| 252 |
# MU |
|
| 253 | ! |
GRAD[pstar.idx, th.idx_i] <- |
| 254 | ! |
-1 * sum(SC.COR.UNI$dx.mu.y1, na.rm = TRUE) |
| 255 |
# TH |
|
| 256 | ! |
GRAD[pstar.idx, th.idx_j] <- |
| 257 | ! |
colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE) |
| 258 |
# VAR |
|
| 259 | ! |
GRAD[pstar.idx, var.idx_i] <- |
| 260 | ! |
sum(SC.COR.UNI$dx.var.y1, na.rm = TRUE) |
| 261 |
# COR |
|
| 262 | ! |
GRAD[pstar.idx, cor.idx] <- |
| 263 | ! |
sum(SC.COR.UNI$dx.rho, na.rm = TRUE) |
| 264 |
} # grad only |
|
| 265 | ! |
} else if (ov.types[j] == "numeric" && ov.types[i] == "ordered") {
|
| 266 |
# polyserial correlation |
|
| 267 | ! |
if (nexo > 1L) {
|
| 268 | ! |
lav_msg_stop(gettext( |
| 269 | ! |
"mixed + exo in PML not implemented; |
| 270 | ! |
try optim.gradient = \"numerical\"")) |
| 271 |
} |
|
| 272 | ||
| 273 | ! |
SC.COR.UNI <- lav_bvmix_cor_scores( |
| 274 | ! |
Y1 = X[, j], Y2 = X[, i], |
| 275 | ! |
eXo = NULL, wt = wt, |
| 276 | ! |
evar.y1 = Sigma.hat[j, j], |
| 277 | ! |
beta.y1 = Mu.hat[j], |
| 278 | ! |
th.y2 = TH[th.idx == i], |
| 279 | ! |
rho = Cor.hat[i, j], |
| 280 | ! |
sigma.correction = TRUE |
| 281 |
) |
|
| 282 | ||
| 283 | ! |
if (scores) {
|
| 284 |
# MU |
|
| 285 | ! |
SCORES[, th.idx_j] <- (SCORES[, th.idx_j] + |
| 286 | ! |
-1 * SC.COR.UNI$dx.mu.y1) |
| 287 |
# TH |
|
| 288 | ! |
SCORES[, th.idx_i] <- (SCORES[, th.idx_i] + |
| 289 | ! |
SC.COR.UNI$dx.th.y2) |
| 290 |
# VAR |
|
| 291 | ! |
SCORES[, var.idx_j] <- (SCORES[, var.idx_j] + |
| 292 | ! |
SC.COR.UNI$dx.var.y1) |
| 293 |
# COR |
|
| 294 | ! |
SCORES[, cor.idx] <- (SCORES[, cor.idx] + |
| 295 | ! |
SC.COR.UNI$dx.rho) |
| 296 |
} else {
|
|
| 297 |
# MU |
|
| 298 | ! |
GRAD[pstar.idx, th.idx_j] <- |
| 299 | ! |
-1 * sum(SC.COR.UNI$dx.mu.y1, na.rm = TRUE) |
| 300 |
# TH |
|
| 301 | ! |
GRAD[pstar.idx, th.idx_i] <- |
| 302 | ! |
colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE) |
| 303 |
# VAR |
|
| 304 | ! |
GRAD[pstar.idx, var.idx_j] <- |
| 305 | ! |
sum(SC.COR.UNI$dx.var.y1, na.rm = TRUE) |
| 306 |
# COR |
|
| 307 | ! |
GRAD[pstar.idx, cor.idx] <- |
| 308 | ! |
sum(SC.COR.UNI$dx.rho, na.rm = TRUE) |
| 309 |
} # grad only |
|
| 310 | ! |
} else if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
|
| 311 |
# polychoric correlation |
|
| 312 | ! |
if (nexo == 0L) {
|
| 313 | ! |
SC.COR.UNI <- |
| 314 | ! |
lav_bvord_cor_scores( |
| 315 | ! |
Y1 = X[, i], Y2 = X[, j], |
| 316 | ! |
eXo = NULL, wt = wt, |
| 317 | ! |
rho = Sigma.hat[i, j], |
| 318 | ! |
fit.y1 = NULL, # fixme |
| 319 | ! |
fit.y2 = NULL, # fixme |
| 320 | ! |
th.y1 = TH[th.idx == i], |
| 321 | ! |
th.y2 = TH[th.idx == j], |
| 322 | ! |
sl.y1 = NULL, |
| 323 | ! |
sl.y2 = NULL, |
| 324 | ! |
na.zero = TRUE |
| 325 |
) |
|
| 326 |
} else {
|
|
| 327 | ! |
SC.COR.UNI <- |
| 328 | ! |
lav_pml_dbilogl_dpar_x( |
| 329 | ! |
Y1 = X[, i], |
| 330 | ! |
Y2 = X[, j], |
| 331 | ! |
eXo = eXo, |
| 332 | ! |
Rho = Sigma.hat[i, j], |
| 333 | ! |
th.y1 = TH[th.idx == i], |
| 334 | ! |
th.y2 = TH[th.idx == j], |
| 335 | ! |
sl.y1 = PI[i, ], |
| 336 | ! |
sl.y2 = PI[j, ], |
| 337 | ! |
missing.ind = missing |
| 338 |
) |
|
| 339 |
} |
|
| 340 | ||
| 341 | ! |
if (scores) {
|
| 342 |
# TH |
|
| 343 | ! |
SCORES[, th.idx_i] <- SCORES[, th.idx_i] + SC.COR.UNI$dx.th.y1 |
| 344 | ! |
SCORES[, th.idx_j] <- SCORES[, th.idx_j] + SC.COR.UNI$dx.th.y2 |
| 345 | ||
| 346 |
# SL |
|
| 347 | ! |
if (nexo > 0L) {
|
| 348 | ! |
SCORES[, sl.idx_i] <- SCORES[, sl.idx_i] + SC.COR.UNI$dx.sl.y1 |
| 349 | ! |
SCORES[, sl.idx_j] <- SCORES[, sl.idx_j] + SC.COR.UNI$dx.sl.y2 |
| 350 |
} |
|
| 351 |
# NO VAR |
|
| 352 |
# RHO |
|
| 353 | ! |
SCORES[, cor.idx] <- SCORES[, cor.idx] + SC.COR.UNI$dx.rho |
| 354 |
} else {
|
|
| 355 |
# TH |
|
| 356 | ! |
if (length(th.idx_i) > 1L) {
|
| 357 | ! |
GRAD[pstar.idx, th.idx_i] <- |
| 358 | ! |
colSums(SC.COR.UNI$dx.th.y1, na.rm = TRUE) |
| 359 |
} else {
|
|
| 360 | ! |
GRAD[pstar.idx, th.idx_i] <- |
| 361 | ! |
sum(SC.COR.UNI$dx.th.y1, na.rm = TRUE) |
| 362 |
} |
|
| 363 | ! |
if (length(th.idx_j) > 1L) {
|
| 364 | ! |
GRAD[pstar.idx, th.idx_j] <- |
| 365 | ! |
colSums(SC.COR.UNI$dx.th.y2, na.rm = TRUE) |
| 366 |
} else {
|
|
| 367 | ! |
GRAD[pstar.idx, th.idx_j] <- |
| 368 | ! |
sum(SC.COR.UNI$dx.th.y2, na.rm = TRUE) |
| 369 |
} |
|
| 370 | ||
| 371 |
# SL |
|
| 372 | ! |
if (nexo > 0L) {
|
| 373 | ! |
if (length(sl.idx_i) > 1L) {
|
| 374 | ! |
GRAD[pstar.idx, sl.idx_i] <- |
| 375 | ! |
colSums(SC.COR.UNI$dx.sl.y1, na.rm = TRUE) |
| 376 |
} else {
|
|
| 377 | ! |
GRAD[pstar.idx, sl.idx_i] <- |
| 378 | ! |
sum(SC.COR.UNI$dx.sl.y1, na.rm = TRUE) |
| 379 |
} |
|
| 380 | ! |
if (length(sl.idx_j) > 1L) {
|
| 381 | ! |
GRAD[pstar.idx, sl.idx_j] <- |
| 382 | ! |
colSums(SC.COR.UNI$dx.sl.y2, na.rm = TRUE) |
| 383 |
} else {
|
|
| 384 | ! |
GRAD[pstar.idx, sl.idx_j] <- |
| 385 | ! |
sum(SC.COR.UNI$dx.sl.y2, na.rm = TRUE) |
| 386 |
} |
|
| 387 |
} |
|
| 388 |
# NO VAR |
|
| 389 | ||
| 390 |
# RHO |
|
| 391 | ! |
GRAD[pstar.idx, cor.idx] <- |
| 392 | ! |
sum(SC.COR.UNI$dx.rho, na.rm = TRUE) |
| 393 |
} |
|
| 394 | ||
| 395 |
# GRAD2 <- numDeriv::grad(func = pc_logl_x, |
|
| 396 |
# x = c(Sigma.hat[i,j], |
|
| 397 |
# TH[ th.idx == i ], |
|
| 398 |
# TH[ th.idx == j]), |
|
| 399 |
# Y1 = X[,i], |
|
| 400 |
# Y2 = X[,j], |
|
| 401 |
# eXo = eXo, |
|
| 402 |
# nth.y1 = sum( th.idx == i ), |
|
| 403 |
# nth.y2 = sum( th.idx == j )) |
|
| 404 |
} |
|
| 405 |
} |
|
| 406 |
} |
|
| 407 | ||
| 408 | ! |
if (missing == "available.cases" && all(ov.types == "ordered")) {
|
| 409 | ! |
if (nexo == 0L) {
|
| 410 | ! |
UNI_SCORES <- matrix(0, nrow(X), N.TH) |
| 411 | ! |
for (i in seq_len(nvar)) {
|
| 412 | ! |
th.idx_i <- which(th.idx == i) |
| 413 | ! |
derY1 <- lav_pml_uni_scores( |
| 414 | ! |
Y1 = X[, i], th.y1 = TH[th.idx == i], |
| 415 | ! |
eXo = NULL, sl.y1 = NULL, |
| 416 | ! |
weights.casewise = lavcache$uniweights.casewise |
| 417 |
) |
|
| 418 | ! |
UNI_SCORES[, th.idx_i] <- derY1$dx.th.y1 |
| 419 |
} |
|
| 420 |
} else {
|
|
| 421 | ! |
UNI_SCORES <- matrix(0, nrow(X), ncol = (N.TH + N.SL)) |
| 422 | ! |
for (i in seq_len(nvar)) {
|
| 423 | ! |
th.idx_i <- which(th.idx == i) |
| 424 | ! |
sl.idx_i <- N.TH + seq(i, by = nvar, length.out = nexo) |
| 425 | ! |
derY1 <- lav_pml_uni_scores( |
| 426 | ! |
Y1 = X[, i], th.y1 = TH[th.idx == i], |
| 427 | ! |
eXo = eXo, sl.y1 = PI[i, ], |
| 428 | ! |
weights.casewise = lavcache$uniweights.casewise |
| 429 |
) |
|
| 430 | ! |
UNI_SCORES[, th.idx_i] <- derY1$dx.th.y1 |
| 431 | ! |
UNI_SCORES[, sl.idx_i] <- derY1$dx.sl.y1 |
| 432 |
} |
|
| 433 | ! |
if (scores) {
|
| 434 | ! |
SCORES <- SCORES[, 1:(N.TH + N.SL)] + UNI_SCORES |
| 435 |
} else {
|
|
| 436 | ! |
uni_gradient <- colSums(UNI_SCORES) |
| 437 |
} |
|
| 438 |
} |
|
| 439 |
} |
|
| 440 | ||
| 441 |
# do we need scores? |
|
| 442 | ! |
if (scores) {
|
| 443 | ! |
return(SCORES) |
| 444 |
} |
|
| 445 | ||
| 446 |
# DEBUG |
|
| 447 |
# :print(GRAD) |
|
| 448 |
########### |
|
| 449 | ||
| 450 | ||
| 451 | ||
| 452 |
# gradient is sum over all pairs |
|
| 453 | ! |
gradient <- colSums(GRAD, na.rm = TRUE) |
| 454 | ||
| 455 | ! |
if (missing == "available.cases" && all(ov.types == "ordered")) {
|
| 456 | ! |
if (nexo == 0L) {
|
| 457 | ! |
gradient[1:N.TH] <- gradient + uni_gradient |
| 458 |
} else {
|
|
| 459 | ! |
gradient[1:(N.TH + N.SL)] <- gradient + uni_gradient |
| 460 |
} |
|
| 461 |
} |
|
| 462 | ||
| 463 |
# we multiply by -1 because we minimize |
|
| 464 | ! |
if (negative) {
|
| 465 | ! |
gradient <- -1 * gradient |
| 466 |
} |
|
| 467 | ||
| 468 | ! |
gradient |
| 469 |
} |
|
| 470 | ||
| 471 | ||
| 472 |
### all code below written by Myrsini Katsikatsou |
|
| 473 | ||
| 474 | ||
| 475 |
# The function lav_pml_grad_tau_rho |
|
| 476 |
# input: |
|
| 477 |
# no.x - is scalar, the number of ordinal variables |
|
| 478 |
# all.thres - is vector containing the thresholds of all variables in the |
|
| 479 |
# following order: thres_var1, thres_var2,..., thres_var_p |
|
| 480 |
# within each variable the thresholds are in ascending order |
|
| 481 |
# Note that all.thres do NOT contain tau_0=-Inf and tau_last=Inf |
|
| 482 |
# for all variables. |
|
| 483 |
# index.var.of.thres - a vector keeping track to which variable the thresholds |
|
| 484 |
# in all.thres belongs to, it is of the form |
|
| 485 |
# (1,1,1..., 2,2,2,..., p,p,p,...) |
|
| 486 |
# rho.xixj - is the vector of all correlations where j runs faster than i |
|
| 487 |
# i.e. the order is rho_12, rho_13, ..., rho_1p, rho_23, ..., rho_2p, |
|
| 488 |
# etc. |
|
| 489 |
# n.xixj.vec - a vector with the observed frequency for every combination |
|
| 490 |
# of categories and every pair. The frequencies are given in |
|
| 491 |
# the same order as the expected probabilities in the output of |
|
| 492 |
# lav_pml_expprob_vec output |
|
| 493 |
# out.lav_pml_longvec_ind - it is the output of function lav_pml_longvec_ind |
|
| 494 |
# the output: it gives the elements of der.L.to.tau and der.L.to.rho in this |
|
| 495 |
# order. The elements of der.L.to.tau where the elements are |
|
| 496 |
# ordered as follows: the thresholds of each variable with respect |
|
| 497 |
# to ascending order of the variable index (i.e. thres_var1, |
|
| 498 |
# thres_var2, etc.) and within each variable the thresholds in |
|
| 499 |
# ascending order. |
|
| 500 |
# The elements of vector der.L.to.rho are der.Lxixj.to.rho.xixj |
|
| 501 |
# where j runs faster than i. |
|
| 502 | ||
| 503 |
# The function depends on four other functions: lav_pml_longvec_th_rho, |
|
| 504 |
# lav_pml_expprob_vec, lav_pml_dl_drho, and lav_pml_dl_dtau, all given below. |
|
| 505 | ||
| 506 |
# if n.xixj.ab is either an array or a list the following should be done |
|
| 507 |
# n.xixj.vec <- if(is.array(n.xixj.ab)) {
|
|
| 508 |
# c(n.xixj.ab) |
|
| 509 |
# } else if(is.list(n.xixj.ab)){
|
|
| 510 |
# unlist(n.xixj.ab) |
|
| 511 |
# } |
|
| 512 | ||
| 513 | ||
| 514 |
lav_pml_grad_tau_rho <- function(no.x, all.thres, index.var.of.thres, rho.xixj, |
|
| 515 |
n.xixj.vec, out.lav_pml_longvec_ind) {
|
|
| 516 | ! |
out.lav_pml_longvec_th_rho <- lav_pml_longvec_th_rho( |
| 517 | ! |
no.x = no.x, all.thres = all.thres, |
| 518 | ! |
index.var.of.thres = index.var.of.thres, |
| 519 | ! |
rho.xixj = rho.xixj |
| 520 |
) |
|
| 521 | ! |
pi.xixj <- lav_pml_expprob_vec( |
| 522 | ! |
ind.vec = out.lav_pml_longvec_ind, |
| 523 | ! |
th.rho.vec = out.lav_pml_longvec_th_rho |
| 524 |
) |
|
| 525 | ||
| 526 | ! |
out.lav_pml_dl_drho <- lav_pml_dl_drho( |
| 527 | ! |
ind.vec = out.lav_pml_longvec_ind, |
| 528 | ! |
th.rho.vec = out.lav_pml_longvec_th_rho, |
| 529 | ! |
n.xixj = n.xixj.vec, pi.xixj = pi.xixj, no.x = no.x |
| 530 |
) |
|
| 531 | ||
| 532 | ! |
out.lav_pml_dl_dtau <- lav_pml_dl_dtau( |
| 533 | ! |
ind.vec = out.lav_pml_longvec_ind, |
| 534 | ! |
th.rho.vec = out.lav_pml_longvec_th_rho, |
| 535 | ! |
n.xixj = n.xixj.vec, pi.xixj = pi.xixj, |
| 536 | ! |
no.x = no.x |
| 537 |
) |
|
| 538 | ||
| 539 | ! |
grad <- c(out.lav_pml_dl_dtau, out.lav_pml_dl_drho) |
| 540 | ! |
attr(grad, "pi.xixj") <- pi.xixj |
| 541 | ||
| 542 | ! |
grad |
| 543 |
} |
|
| 544 |
################################################################################ |
|
| 545 | ||
| 546 | ||
| 547 | ||
| 548 | ||
| 549 |
# The input of the function lav_pml_longvec_ind: |
|
| 550 | ||
| 551 |
# no.x is scalar, the number of ordinal variables |
|
| 552 | ||
| 553 |
# all.thres is vector containing the thresholds of all variables in the |
|
| 554 |
# following order: thres_var1, thres_var2,..., thres_var_p |
|
| 555 |
# within each variable the thresholds are in ascending order |
|
| 556 |
# Note that all.thres does NOT contain the first and the last threshold of the |
|
| 557 |
# variables, i.e. tau_0=-Inf and tau_last=Inf |
|
| 558 | ||
| 559 |
# index.var.of.thres is a vector keeping track to which variable the thresholds |
|
| 560 |
# in all.thres belongs to, it is of the form (1,1,1..., 2,2,2,..., p,p,p,...) |
|
| 561 | ||
| 562 |
# The output of the function: |
|
| 563 |
# it is a list of vectors keeping track of the indices |
|
| 564 |
# of thresholds, of variables, and of pairs, and two T/F vectors indicating |
|
| 565 |
# if the threshold index corresponds to the last threshold of a variable; all |
|
| 566 |
# these for all pairs of variables. All are needed for the |
|
| 567 |
# computation of expected probabilities, der.L.to.rho, and der.L.to.tau |
|
| 568 | ||
| 569 |
# all duplications of indices are done as follows: within each pair of variables, |
|
| 570 |
# xi-xj, if for example we want to duplicate the indices of the thresholds, |
|
| 571 |
# tau^xi_a and tau^xj_b, then index a runs faster than b, i.e. for each b we |
|
| 572 |
# take all different tau^xi's, and then we proceed to the next b and do the |
|
| 573 |
# same. In other words if it was tabulated we fill the table columnwise. |
|
| 574 | ||
| 575 |
# All pairs xi-xj are taken with index j running faster than i. |
|
| 576 | ||
| 577 |
# Note that each variable may have a different number of categories, that's why |
|
| 578 |
# for example we take lists below. |
|
| 579 | ||
| 580 |
lav_pml_longvec_ind <- function(no.x, all.thres, index.var.of.thres) {
|
|
| 581 | ! |
no.thres.of.each.var <- tapply(all.thres, index.var.of.thres, length) |
| 582 | ! |
index.pairs <- utils::combn(no.x, 2) |
| 583 | ! |
no.pairs <- ncol(index.pairs) |
| 584 | ||
| 585 |
# index.thres.var1.of.pair and index.thres.var2.of.pair contain the indices of |
|
| 586 |
# of all thresholds (from tau_0 which is -Inf to tau_last which is Inf) |
|
| 587 |
# for any pair of variables appropriately duplicated so that the two vectors |
|
| 588 |
# together give all possible combinations of thresholds indices |
|
| 589 |
# Since here the threshold indices 0 and "last" are included, the vectors are |
|
| 590 |
# longer than the vectors thres.var1.of.pair and thres.var2.of.pair above. |
|
| 591 | ! |
index.thres.var1.of.pair <- vector("list", no.pairs)
|
| 592 | ! |
index.thres.var2.of.pair <- vector("list", no.pairs)
|
| 593 | ||
| 594 |
# index.var1.of.pair and index.var2.of.pair keep track the index of the |
|
| 595 |
# variable that the thresholds in index.thres.var1.of.pair and |
|
| 596 |
# index.thres.var2.of.pair belong to, respectively. So, these two variables |
|
| 597 |
# are of same length as that of index.thres.var1.of.pair and |
|
| 598 |
# index.thres.var2.of.pair |
|
| 599 | ! |
index.var1.of.pair <- vector("list", no.pairs)
|
| 600 | ! |
index.var2.of.pair <- vector("list", no.pairs)
|
| 601 | ||
| 602 |
# index.pairs.extended gives the index of the pair for each pair of variables |
|
| 603 |
# e.g. pair of variables 1-2 has index 1, variables 1-3 has index 2, etc. |
|
| 604 |
# The vector is of the same length as index.thres.var1.of.pair, |
|
| 605 |
# index.thres.var2.of.pair, index.var1.of.pair, and index.var2.of.pair |
|
| 606 | ! |
index.pairs.extended <- vector("list", no.pairs)
|
| 607 | ||
| 608 | ! |
for (i in 1:no.pairs) {
|
| 609 | ! |
no.thres.var1.of.pair <- no.thres.of.each.var[index.pairs[1, i]] |
| 610 | ! |
no.thres.var2.of.pair <- no.thres.of.each.var[index.pairs[2, i]] |
| 611 | ||
| 612 | ! |
index.thres.var1.of.pair[[i]] <- rep(0:(no.thres.var1.of.pair + 1), |
| 613 | ! |
times = (no.thres.var2.of.pair + 2) |
| 614 |
) |
|
| 615 | ! |
index.thres.var2.of.pair[[i]] <- rep(0:(no.thres.var2.of.pair + 1), |
| 616 | ! |
each = (no.thres.var1.of.pair + 2) |
| 617 |
) |
|
| 618 | ! |
length.vec <- length(index.thres.var1.of.pair[[i]]) |
| 619 | ! |
index.var1.of.pair[[i]] <- rep(index.pairs[1, i], length.vec) |
| 620 | ! |
index.var2.of.pair[[i]] <- rep(index.pairs[2, i], length.vec) |
| 621 | ! |
index.pairs.extended[[i]] <- rep(i, length.vec) |
| 622 |
} |
|
| 623 | ||
| 624 | ! |
index.thres.var1.of.pair <- unlist(index.thres.var1.of.pair) |
| 625 | ! |
index.thres.var2.of.pair <- unlist(index.thres.var2.of.pair) |
| 626 | ! |
index.var1.of.pair <- unlist(index.var1.of.pair) |
| 627 | ! |
index.var2.of.pair <- unlist(index.var2.of.pair) |
| 628 | ! |
index.pairs.extended <- unlist(index.pairs.extended) |
| 629 | ||
| 630 |
# indicator vector (T/F) showing which elements of index.thres.var1.of.pair |
|
| 631 |
# correspond to the last thresholds of variables. The length is the same as |
|
| 632 |
# that of index.thres.var1.of.pair. |
|
| 633 | ! |
last.thres.var1.of.pair <- index.var1.of.pair == 1 & |
| 634 | ! |
index.thres.var1.of.pair == (no.thres.of.each.var[1] + 1) |
| 635 |
# we consider up to variable (no.x-1) because in pairs xi-xj where j runs |
|
| 636 |
# faster than i, the last variable is not included in the column of xi's |
|
| 637 | ! |
for (i in 2:(no.x - 1)) {
|
| 638 | ! |
new.condition <- index.var1.of.pair == i & |
| 639 | ! |
index.thres.var1.of.pair == (no.thres.of.each.var[i] + 1) |
| 640 | ! |
last.thres.var1.of.pair <- last.thres.var1.of.pair | new.condition |
| 641 |
} |
|
| 642 | ||
| 643 |
# indicator vector (T/F) showing which elements of index.thres.var2.of.pair |
|
| 644 |
# correspond to the last thresholds of variables. Notet that in pairs xi-xj |
|
| 645 |
# where j runs faster than i, the first variable is not included in the column |
|
| 646 |
# of xj's. That's why we start with variable 2. The length is the same as |
|
| 647 |
# that of index.thres.var1.of.pair. |
|
| 648 | ! |
last.thres.var2.of.pair <- index.var2.of.pair == 2 & |
| 649 | ! |
index.thres.var2.of.pair == (no.thres.of.each.var[2] + 1) |
| 650 | ! |
for (i in 3:no.x) {
|
| 651 | ! |
new.condition <- index.var2.of.pair == i & |
| 652 | ! |
index.thres.var2.of.pair == (no.thres.of.each.var[i] + 1) |
| 653 | ! |
last.thres.var2.of.pair <- last.thres.var2.of.pair | new.condition |
| 654 |
} |
|
| 655 | ||
| 656 | ! |
list( |
| 657 | ! |
index.thres.var1.of.pair = index.thres.var1.of.pair, |
| 658 | ! |
index.thres.var2.of.pair = index.thres.var2.of.pair, |
| 659 | ! |
index.var1.of.pair = index.var1.of.pair, |
| 660 | ! |
index.var2.of.pair = index.var2.of.pair, |
| 661 | ! |
index.pairs.extended = index.pairs.extended, |
| 662 | ! |
last.thres.var1.of.pair = last.thres.var1.of.pair, |
| 663 | ! |
last.thres.var2.of.pair = last.thres.var2.of.pair |
| 664 |
) |
|
| 665 |
} |
|
| 666 |
################################################################################ |
|
| 667 | ||
| 668 | ||
| 669 |
# The input of the function lav_pml_longvec_th_rho: |
|
| 670 | ||
| 671 |
# no.x is scalar, the number of ordinal variables |
|
| 672 | ||
| 673 |
# all.thres is vector containing the thresholds of all variables in the |
|
| 674 |
# following order: thres_var1, thres_var2,..., thres_var_p |
|
| 675 |
# within each variable the thresholds are in ascending order |
|
| 676 |
# Note that all.thres does NOT contain the first and the last threshold of the |
|
| 677 |
# variables, i.e. tau_0=-Inf and tau_last=Inf |
|
| 678 | ||
| 679 |
# index.var.of.thres is a vector keeping track to which variable the thresholds |
|
| 680 |
# in all.thres belongs to, it is of the form (1,1,1..., 2,2,2,..., p,p,p,...) |
|
| 681 | ||
| 682 |
# rho.xixj is the vector of all corrlations where j runs faster than i |
|
| 683 |
# i.e. the order is rho_12, rho_13, ..., rho_1p, rho_23, ..., rho_2p, etc. |
|
| 684 | ||
| 685 |
# The output of the function: |
|
| 686 |
# it is a list of vectors with thresholds and rho's duplicated appropriately, |
|
| 687 |
# all needed for the computation of expected probabilities, |
|
| 688 |
# der.L.to.rho, and der.L.to.tau |
|
| 689 | ||
| 690 |
# all duplications below are done as follows: within each pair of variables, |
|
| 691 |
# xi-xj, if for example we want to duplicate their thresholds, tau^xi_a and |
|
| 692 |
# tau^xj_b, then index a runs faster than b, i.e. for each b we take all |
|
| 693 |
# different tau^xi's, and then we proceed to the next b and do the same. |
|
| 694 |
# In other words if it was tabulated we fill the table columnwise. |
|
| 695 | ||
| 696 |
# All pairs xi-xj are taken with index j running faster than i. |
|
| 697 | ||
| 698 |
# Note that each variable may have a different number of categories, that's why |
|
| 699 |
# for example we take lists below. |
|
| 700 | ||
| 701 |
lav_pml_longvec_th_rho <- function(no.x, all.thres, index.var.of.thres, rho.xixj) {
|
|
| 702 | ! |
no.thres.of.each.var <- tapply(all.thres, index.var.of.thres, length) |
| 703 | ! |
index.pairs <- utils::combn(no.x, 2) |
| 704 | ! |
no.pairs <- ncol(index.pairs) |
| 705 | ||
| 706 |
# create the long vectors needed for the computation of expected probabilities |
|
| 707 |
# for each cell and each pair of variables. The vectors thres.var1.of.pair and |
|
| 708 |
# thres.var2.of.pair together give all the possible combinations of the |
|
| 709 |
# thresholds of any two variables. Note the combinations (-Inf, -Inf), |
|
| 710 |
# (-Inf, Inf), (Inf, -Inf), (Inf, Inf) are NOT included. Only the combinations |
|
| 711 |
# of the middle thresholds (tau_1 to tau_(last-1)). |
|
| 712 |
# thres.var1.of.pair and thres.var2.of.pair give the first and the second |
|
| 713 |
# argument, respectively, in functions pbivnorm and lav_dbinorm |
|
| 714 | ! |
thres.var1.of.pair <- vector("list", no.pairs)
|
| 715 | ! |
thres.var2.of.pair <- vector("list", no.pairs)
|
| 716 | ||
| 717 |
# Extending the rho.vector accordingly so that it will be the the third |
|
| 718 |
# argument in pbivnorm and lav_dbinorm functions. It is of same length as |
|
| 719 |
# thres.var1.of.pair and thres.var2.of.pair. |
|
| 720 | ! |
rho.vector <- vector("list", no.pairs)
|
| 721 | ||
| 722 |
# thres.var1.for.dnorm.in.der.pi.to.tau.xi and |
|
| 723 |
# thres.var2.for.dnorm.in.der.pi.to.tau.xj give the thresholds of almost |
|
| 724 |
# all variables appropriately duplicated so that the vectors can be used |
|
| 725 |
# as input in dnorm() to compute der.pi.xixj.to.tau.xi and |
|
| 726 |
# der.pi.xixj.to.tau.xj. |
|
| 727 |
# thres.var1.for.dnorm.in.der.pi.to.tau.xi does not contain the thresholds of |
|
| 728 |
# the last variable and thres.var2.for.dnorm.in.der.pi.to.tau.xj those of |
|
| 729 |
# the first variable |
|
| 730 | ! |
thres.var1.for.dnorm.in.der.pi.to.tau.xi <- vector("list", no.pairs)
|
| 731 | ! |
thres.var2.for.dnorm.in.der.pi.to.tau.xj <- vector("list", no.pairs)
|
| 732 | ||
| 733 | ! |
for (i in 1:no.pairs) {
|
| 734 | ! |
single.thres.var1.of.pair <- all.thres[index.var.of.thres == index.pairs[1, i]] |
| 735 | ! |
single.thres.var2.of.pair <- all.thres[index.var.of.thres == index.pairs[2, i]] |
| 736 |
# remember that the first (-Inf) and last (Inf) thresholds are not included |
|
| 737 |
# so no.thres.var1.of.pair is equal to number of categories of var1 minus 1 |
|
| 738 |
# similarly for no.thres.var2.of.pair |
|
| 739 | ! |
no.thres.var1.of.pair <- no.thres.of.each.var[index.pairs[1, i]] |
| 740 | ! |
no.thres.var2.of.pair <- no.thres.of.each.var[index.pairs[2, i]] |
| 741 | ||
| 742 | ! |
thres.var1.of.pair[[i]] <- rep(single.thres.var1.of.pair, |
| 743 | ! |
times = no.thres.var2.of.pair |
| 744 |
) |
|
| 745 | ! |
thres.var2.of.pair[[i]] <- rep(single.thres.var2.of.pair, |
| 746 | ! |
each = no.thres.var1.of.pair |
| 747 |
) |
|
| 748 | ! |
rho.vector[[i]] <- rep(rho.xixj[i], length(thres.var1.of.pair[[i]])) |
| 749 | ||
| 750 | ! |
thres.var1.for.dnorm.in.der.pi.to.tau.xi[[i]] <- |
| 751 | ! |
rep(single.thres.var1.of.pair, times = (no.thres.var2.of.pair + 1)) |
| 752 | ! |
thres.var2.for.dnorm.in.der.pi.to.tau.xj[[i]] <- |
| 753 | ! |
rep(single.thres.var2.of.pair, each = (no.thres.var1.of.pair + 1)) |
| 754 |
} |
|
| 755 | ||
| 756 | ! |
thres.var1.of.pair <- unlist(thres.var1.of.pair) |
| 757 | ! |
thres.var2.of.pair <- unlist(thres.var2.of.pair) |
| 758 | ! |
rho.vector <- unlist(rho.vector) |
| 759 | ! |
thres.var1.for.dnorm.in.der.pi.to.tau.xi <- |
| 760 | ! |
unlist(thres.var1.for.dnorm.in.der.pi.to.tau.xi) |
| 761 | ! |
thres.var2.for.dnorm.in.der.pi.to.tau.xj <- |
| 762 | ! |
unlist(thres.var2.for.dnorm.in.der.pi.to.tau.xj) |
| 763 | ||
| 764 |
# thres.var2.for.last.cat.var1 and thres.var1.for.last.cat.var2 are needed |
|
| 765 |
# for the computation of expected probabilities. In the computation of |
|
| 766 |
# \Phi_2(tau1, tau2; rho) when either tau1 or tau2 are Inf then it is enought |
|
| 767 |
# to compute pnorm() with the non-infinite tau as an argument |
|
| 768 |
# In particular when the first variable of the pair has tau_last= Inf |
|
| 769 |
# and the second a non-infite threshold we compute |
|
| 770 |
# pnorm(thres.var2.for.last.cat.var1). Similarly, when the second variable of |
|
| 771 |
# the pair has tau_last=Inf and the first a non-infite threshold we compute |
|
| 772 |
# pnorm(thres.var1.for.last.cat.var2). |
|
| 773 | ! |
thres.var2.for.last.cat.var1 <- vector("list", (no.x - 1))
|
| 774 | ! |
thres.var1.for.last.cat.var2 <- vector("list", (no.x - 1))
|
| 775 | ! |
for (i in 1:(no.x - 1)) {
|
| 776 | ! |
thres.var2.for.last.cat.var1[[i]] <- |
| 777 | ! |
c(all.thres[index.var.of.thres %in% (i + 1):no.x]) |
| 778 | ! |
thres.var1.for.last.cat.var2[[i]] <- rep(all.thres[index.var.of.thres == i], |
| 779 | ! |
times = (no.x - i) |
| 780 |
) |
|
| 781 |
} |
|
| 782 | ! |
thres.var2.for.last.cat.var1 <- unlist(thres.var2.for.last.cat.var1) |
| 783 | ! |
thres.var1.for.last.cat.var2 <- unlist(thres.var1.for.last.cat.var2) |
| 784 | ||
| 785 | ||
| 786 | ! |
list( |
| 787 | ! |
thres.var1.of.pair = thres.var1.of.pair, # these 3 of same length |
| 788 | ! |
thres.var2.of.pair = thres.var2.of.pair, |
| 789 | ! |
rho.vector = rho.vector, |
| 790 | ||
| 791 |
# the following of length dependning on the number of categories |
|
| 792 | ! |
thres.var1.for.dnorm.in.der.pi.to.tau.xi = |
| 793 | ! |
thres.var1.for.dnorm.in.der.pi.to.tau.xi, |
| 794 | ! |
thres.var2.for.dnorm.in.der.pi.to.tau.xj = |
| 795 | ! |
thres.var2.for.dnorm.in.der.pi.to.tau.xj, |
| 796 | ! |
thres.var2.for.last.cat.var1 = thres.var2.for.last.cat.var1, |
| 797 | ! |
thres.var1.for.last.cat.var2 = thres.var1.for.last.cat.var2 |
| 798 |
) |
|
| 799 |
} |
|
| 800 |
######################################################### |
|
| 801 | ||
| 802 | ||
| 803 | ||
| 804 |
######################################################### |
|
| 805 | ||
| 806 |
# The function lav_pml_expprob_vec |
|
| 807 |
# input: ind.vec - the output of function lav_pml_longvec_ind |
|
| 808 |
# th.rho.vec - the output of function lav_pml_longvec_th_rho |
|
| 809 |
# output: it gives the elements of pairwiseTablesExpected()$pi.tables |
|
| 810 |
# table-wise and column-wise within each table. In other words if |
|
| 811 |
# pi^xixj_ab is the expected probability for the pair of variables xi-xj |
|
| 812 |
# and categories a and b, then index a runs the fastest of all, followed by b, |
|
| 813 |
# then by j, and lastly by i. |
|
| 814 | ||
| 815 |
lav_pml_expprob_vec <- function(ind.vec, th.rho.vec) {
|
|
| 816 | ! |
prob.vec <- rep(NA, length(ind.vec$index.thres.var1.of.pair)) |
| 817 | ||
| 818 | ! |
prob.vec[ind.vec$index.thres.var1.of.pair == 0 | |
| 819 | ! |
ind.vec$index.thres.var2.of.pair == 0] <- 0 |
| 820 | ||
| 821 | ! |
prob.vec[ind.vec$last.thres.var1.of.pair & |
| 822 | ! |
ind.vec$last.thres.var2.of.pair] <- 1 |
| 823 | ||
| 824 | ! |
prob.vec[ind.vec$last.thres.var1.of.pair & |
| 825 | ! |
ind.vec$index.thres.var2.of.pair != 0 & |
| 826 | ! |
!ind.vec$last.thres.var2.of.pair] <- |
| 827 | ! |
pnorm(th.rho.vec$thres.var2.for.last.cat.var1) |
| 828 | ||
| 829 | ! |
prob.vec[ind.vec$last.thres.var2.of.pair & |
| 830 | ! |
ind.vec$index.thres.var1.of.pair != 0 & |
| 831 | ! |
!ind.vec$last.thres.var1.of.pair] <- |
| 832 | ! |
pnorm(th.rho.vec$thres.var1.for.last.cat.var2) |
| 833 | ||
| 834 | ! |
prob.vec[is.na(prob.vec)] <- pbivnorm( |
| 835 | ! |
th.rho.vec$thres.var1.of.pair, |
| 836 | ! |
th.rho.vec$thres.var2.of.pair, |
| 837 | ! |
th.rho.vec$rho.vector |
| 838 |
) |
|
| 839 | ||
| 840 | ! |
cum.term1 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 & |
| 841 | ! |
ind.vec$index.thres.var2.of.pair != 0] |
| 842 | ||
| 843 | ! |
cum.term2 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 & |
| 844 | ! |
!ind.vec$last.thres.var2.of.pair] |
| 845 | ||
| 846 | ! |
cum.term3 <- prob.vec[ind.vec$index.thres.var2.of.pair != 0 & |
| 847 | ! |
!ind.vec$last.thres.var1.of.pair] |
| 848 | ||
| 849 | ! |
cum.term4 <- prob.vec[!ind.vec$last.thres.var1.of.pair & |
| 850 | ! |
!ind.vec$last.thres.var2.of.pair] |
| 851 | ||
| 852 | ! |
PI <- cum.term1 - cum.term2 - cum.term3 + cum.term4 |
| 853 | ||
| 854 |
# added by YR 11 nov 2012 to avoid Nan/-Inf |
|
| 855 |
# log(.Machine$double.eps) = -36.04365 |
|
| 856 |
# all elements should be strictly positive |
|
| 857 | ! |
PI[PI < .Machine$double.eps] <- .Machine$double.eps |
| 858 | ||
| 859 | ! |
PI |
| 860 |
} |
|
| 861 | ||
| 862 | ||
| 863 |
# lav_pml_dl_drho |
|
| 864 |
# input: ind.vec - the output of function lav_pml_longvec_ind |
|
| 865 |
# th.rho.vec - the output of function lav_pml_longvec_th_rho |
|
| 866 |
# n.xixj - a vector with the observed frequency for every combination |
|
| 867 |
# of categories and every pair. The frequencies are given in |
|
| 868 |
# the same order as the expected probabilities in the output of |
|
| 869 |
# lav_pml_expprob_vec output |
|
| 870 |
# pi.xixj - the output of lav_pml_expprob_vec function |
|
| 871 |
# no.x - the number of ordinal variables |
|
| 872 |
# output: the vector of der.L.to.rho, each element corresponds to |
|
| 873 |
# der.Lxixj.to.rho.xixj where j runs faster than i |
|
| 874 | ||
| 875 |
lav_pml_dl_drho <- function(ind.vec, th.rho.vec, n.xixj, pi.xixj, no.x) {
|
|
| 876 | ! |
prob.vec <- rep(NA, length(ind.vec$index.thres.var1.of.pair)) |
| 877 | ||
| 878 | ! |
prob.vec[ind.vec$index.thres.var1.of.pair == 0 | |
| 879 | ! |
ind.vec$index.thres.var2.of.pair == 0 | |
| 880 | ! |
ind.vec$last.thres.var1.of.pair | |
| 881 | ! |
ind.vec$last.thres.var2.of.pair] <- 0 |
| 882 | ||
| 883 | ! |
prob.vec[is.na(prob.vec)] <- lav_dbinorm(th.rho.vec$thres.var1.of.pair, |
| 884 | ! |
th.rho.vec$thres.var2.of.pair, |
| 885 | ! |
rho = th.rho.vec$rho.vector |
| 886 |
) |
|
| 887 | ||
| 888 | ! |
den.term1 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 & |
| 889 | ! |
ind.vec$index.thres.var2.of.pair != 0] |
| 890 | ||
| 891 | ! |
den.term2 <- prob.vec[ind.vec$index.thres.var1.of.pair != 0 & |
| 892 | ! |
!ind.vec$last.thres.var2.of.pair] |
| 893 | ||
| 894 | ! |
den.term3 <- prob.vec[ind.vec$index.thres.var2.of.pair != 0 & |
| 895 | ! |
!ind.vec$last.thres.var1.of.pair] |
| 896 | ||
| 897 | ! |
den.term4 <- prob.vec[!ind.vec$last.thres.var1.of.pair & |
| 898 | ! |
!ind.vec$last.thres.var2.of.pair] |
| 899 | ||
| 900 | ! |
der.pi.xixj.to.rho.xixj <- den.term1 - den.term2 - den.term3 + den.term4 |
| 901 | ! |
prod.terms <- (n.xixj / pi.xixj) * der.pi.xixj.to.rho.xixj |
| 902 | ||
| 903 |
# to get der.Lxixj.to.rho.xixj we should all the elements of |
|
| 904 |
# der.pi.xixj.to.rho.xixj which correspond to the pair xi-xj, to do so: |
|
| 905 | ! |
xnew <- lapply( |
| 906 | ! |
ind.vec[c("index.pairs.extended")],
|
| 907 | ! |
function(y) {
|
| 908 | ! |
y[ind.vec$index.thres.var1.of.pair != 0 & |
| 909 | ! |
ind.vec$index.thres.var2.of.pair != 0] |
| 910 |
} |
|
| 911 |
) |
|
| 912 |
# der.L.to.rho is: |
|
| 913 | ! |
tapply(prod.terms, xnew$index.pairs.extended, sum) |
| 914 |
} |
|
| 915 |
########################################################################### |
|
| 916 | ||
| 917 | ||
| 918 |
# lav_pml_dl_dtau |
|
| 919 |
# input: ind.vec - the output of function lav_pml_longvec_ind |
|
| 920 |
# th.rho.vec - the output of function lav_pml_longvec_th_rho |
|
| 921 |
# n.xixj - a vector with the observed frequency for every combination |
|
| 922 |
# of categories and every pair. The frequencies are given in |
|
| 923 |
# the same order as the expected probabilities in the output of |
|
| 924 |
# lav_pml_expprob_vec output |
|
| 925 |
# pi.xixj - the output of lav_pml_expprob_vec function |
|
| 926 |
# output: the vector of der.L.to.tau where the elements are ordered as follows: |
|
| 927 |
# the thresholds of each variable with respect to ascending order of |
|
| 928 |
# the variable index (i.e. thres_var1, thres_var2, etc.) and within |
|
| 929 |
# each variable the thresholds in ascending order. |
|
| 930 | ||
| 931 | ||
| 932 |
lav_pml_dl_dtau <- function(ind.vec, th.rho.vec, n.xixj, pi.xixj, no.x = 0L) {
|
|
| 933 |
# to compute der.pi.xixj.to.tau.xi |
|
| 934 | ! |
xi <- lapply( |
| 935 | ! |
ind.vec[c( |
| 936 | ! |
"index.thres.var2.of.pair", |
| 937 | ! |
"last.thres.var2.of.pair" |
| 938 |
)], |
|
| 939 | ! |
function(y) {
|
| 940 | ! |
y[!(ind.vec$index.thres.var1.of.pair == 0 | |
| 941 | ! |
ind.vec$last.thres.var1.of.pair)] |
| 942 |
} |
|
| 943 |
) |
|
| 944 | ||
| 945 | ! |
cum.prob.vec <- rep(NA, length(xi$index.thres.var2.of.pair)) |
| 946 | ! |
cum.prob.vec[xi$index.thres.var2.of.pair == 0] <- 0 |
| 947 | ! |
cum.prob.vec[xi$last.thres.var2.of.pair] <- 1 |
| 948 | ! |
denom <- sqrt(1 - (th.rho.vec$rho.vector * th.rho.vec$rho.vector)) |
| 949 | ! |
cum.prob.vec[is.na(cum.prob.vec)] <- |
| 950 | ! |
pnorm((th.rho.vec$thres.var2.of.pair - |
| 951 | ! |
th.rho.vec$rho.vector * th.rho.vec$thres.var1.of.pair) / |
| 952 | ! |
denom) |
| 953 | ! |
den.prob.vec <- dnorm(th.rho.vec$thres.var1.for.dnorm.in.der.pi.to.tau.xi) |
| 954 | ! |
der.pi.xixj.to.tau.xi <- den.prob.vec * |
| 955 | ! |
(cum.prob.vec[xi$index.thres.var2.of.pair != 0] - |
| 956 | ! |
cum.prob.vec[!xi$last.thres.var2.of.pair]) |
| 957 | ||
| 958 |
# to compute der.pi.xixj.to.tau.xj |
|
| 959 | ! |
xj <- lapply( |
| 960 | ! |
ind.vec[c( |
| 961 | ! |
"index.thres.var1.of.pair", |
| 962 | ! |
"last.thres.var1.of.pair" |
| 963 |
)], |
|
| 964 | ! |
function(y) {
|
| 965 | ! |
y[!(ind.vec$index.thres.var2.of.pair == 0 | |
| 966 | ! |
ind.vec$last.thres.var2.of.pair)] |
| 967 |
} |
|
| 968 |
) |
|
| 969 | ||
| 970 | ! |
cum.prob.vec <- rep(NA, length(xj$index.thres.var1.of.pair)) |
| 971 | ! |
cum.prob.vec[xj$index.thres.var1.of.pair == 0] <- 0 |
| 972 | ! |
cum.prob.vec[xj$last.thres.var1.of.pair] <- 1 |
| 973 | ! |
denom <- sqrt(1 - (th.rho.vec$rho.vector * th.rho.vec$rho.vector)) |
| 974 | ! |
cum.prob.vec[is.na(cum.prob.vec)] <- |
| 975 | ! |
pnorm((th.rho.vec$thres.var1.of.pair - |
| 976 | ! |
th.rho.vec$rho.vector * th.rho.vec$thres.var2.of.pair) / |
| 977 | ! |
denom) |
| 978 | ! |
den.prob.vec <- dnorm(th.rho.vec$thres.var2.for.dnorm.in.der.pi.to.tau.xj) |
| 979 | ! |
der.pi.xixj.to.tau.xj <- den.prob.vec * |
| 980 | ! |
(cum.prob.vec[xj$index.thres.var1.of.pair != 0] - |
| 981 | ! |
cum.prob.vec[!xj$last.thres.var1.of.pair]) |
| 982 | ||
| 983 |
# to compute der.Lxixj.tau.xi and der.Lxixj.tau.xi |
|
| 984 | ! |
n.over.pi <- n.xixj / pi.xixj |
| 985 |
# get the appropriate differences of n.over.pi for der.Lxixj.to.tau.xi and |
|
| 986 |
# der.Lxixj.to.tau.xj |
|
| 987 | ! |
x3a <- lapply(ind.vec, function(y) {
|
| 988 | ! |
y[!(ind.vec$index.thres.var1.of.pair == 0 | |
| 989 | ! |
ind.vec$index.thres.var2.of.pair == 0)] |
| 990 |
}) |
|
| 991 | ! |
diff.n.over.pi.to.xi <- n.over.pi[!x3a$last.thres.var1.of.pair] - |
| 992 | ! |
n.over.pi[x3a$index.thres.var1.of.pair != 1] |
| 993 | ! |
diff.n.over.pi.to.xj <- n.over.pi[!x3a$last.thres.var2.of.pair] - |
| 994 | ! |
n.over.pi[x3a$index.thres.var2.of.pair != 1] |
| 995 |
# terms.der.Lxixj.to.tau.xi and terms.der.Lxixj.to.tau.xj |
|
| 996 | ! |
terms.der.Lxixj.to.tau.xi <- diff.n.over.pi.to.xi * der.pi.xixj.to.tau.xi |
| 997 | ! |
terms.der.Lxixj.to.tau.xj <- diff.n.over.pi.to.xj * der.pi.xixj.to.tau.xj |
| 998 |
# to add appropriately elements of terms.der.Lxixj.to.tau.xi |
|
| 999 | ! |
x3b <- lapply( |
| 1000 | ! |
ind.vec[c( |
| 1001 | ! |
"index.pairs.extended", |
| 1002 | ! |
"index.thres.var1.of.pair" |
| 1003 |
)], |
|
| 1004 | ! |
function(y) {
|
| 1005 | ! |
y[!(ind.vec$index.thres.var1.of.pair == 0 | |
| 1006 | ! |
ind.vec$last.thres.var1.of.pair | |
| 1007 | ! |
ind.vec$index.thres.var2.of.pair == 0)] |
| 1008 |
} |
|
| 1009 |
) |
|
| 1010 |
# to add appropriately elements of terms.der.Lxixj.to.tau.xj |
|
| 1011 | ! |
x4b <- lapply( |
| 1012 | ! |
ind.vec[c( |
| 1013 | ! |
"index.pairs.extended", |
| 1014 | ! |
"index.thres.var2.of.pair" |
| 1015 |
)], |
|
| 1016 | ! |
function(y) {
|
| 1017 | ! |
y[!(ind.vec$index.thres.var2.of.pair == 0 | |
| 1018 | ! |
ind.vec$last.thres.var2.of.pair | |
| 1019 | ! |
ind.vec$index.thres.var1.of.pair == 0)] |
| 1020 |
} |
|
| 1021 |
) |
|
| 1022 | ! |
ind.pairs <- utils::combn(no.x, 2) |
| 1023 |
# der.Lxixj.to.tau.xi is a matrix, nrow=no.pairs, ncol=max(no.of.free.thres) |
|
| 1024 |
# thus, there are NA's, similarly for der.Lxixj.to.tau.xj |
|
| 1025 | ! |
der.Lxixj.to.tau.xi <- tapply( |
| 1026 | ! |
terms.der.Lxixj.to.tau.xi, |
| 1027 | ! |
list( |
| 1028 | ! |
x3b$index.pairs.extended, |
| 1029 | ! |
x3b$index.thres.var1.of.pair |
| 1030 |
), |
|
| 1031 | ! |
sum |
| 1032 |
) |
|
| 1033 | ! |
der.Lxixj.to.tau.xj <- tapply( |
| 1034 | ! |
terms.der.Lxixj.to.tau.xj, |
| 1035 | ! |
list( |
| 1036 | ! |
x4b$index.pairs.extended, |
| 1037 | ! |
x4b$index.thres.var2.of.pair |
| 1038 |
), |
|
| 1039 | ! |
sum |
| 1040 |
) |
|
| 1041 | ||
| 1042 |
# to add appropriately the terms of der.Lxixj.to.tau.xi and |
|
| 1043 |
# der.Lxixj.to.tau.xj |
|
| 1044 | ! |
split.der.Lxixj.to.tau.xi <- split( |
| 1045 | ! |
as.data.frame(der.Lxixj.to.tau.xi), |
| 1046 | ! |
ind.pairs[1, ] |
| 1047 |
) |
|
| 1048 | ! |
sums.der.Lxixj.to.tau.xi <- lapply( |
| 1049 | ! |
split.der.Lxixj.to.tau.xi, |
| 1050 | ! |
function(x) {
|
| 1051 | ! |
y <- apply(x, 2, sum) |
| 1052 | ! |
y[!is.na(y)] |
| 1053 |
} |
|
| 1054 |
) |
|
| 1055 |
# Note: NA exist in the case where the ordinal variables have different |
|
| 1056 |
# number of response categories |
|
| 1057 | ! |
split.der.Lxixj.to.tau.xj <- split( |
| 1058 | ! |
as.data.frame(der.Lxixj.to.tau.xj), |
| 1059 | ! |
ind.pairs[2, ] |
| 1060 |
) |
|
| 1061 | ! |
sums.der.Lxixj.to.tau.xj <- lapply( |
| 1062 | ! |
split.der.Lxixj.to.tau.xj, |
| 1063 | ! |
function(x) {
|
| 1064 | ! |
y <- apply(x, 2, sum) |
| 1065 | ! |
y[!is.na(y)] |
| 1066 |
} |
|
| 1067 |
) |
|
| 1068 |
# to get der.L.to.tau |
|
| 1069 | ! |
c( |
| 1070 | ! |
sums.der.Lxixj.to.tau.xi[[1]], |
| 1071 | ! |
c(unlist(sums.der.Lxixj.to.tau.xi[2:(no.x - 1)]) + |
| 1072 | ! |
unlist(sums.der.Lxixj.to.tau.xj[1:(no.x - 2)])), |
| 1073 | ! |
sums.der.Lxixj.to.tau.xj[[no.x - 1]] |
| 1074 |
) |
|
| 1075 |
} |
| 1 |
# - 0.6-13: fix multiple-group UG^2 bug (reported by Gronneberg, Foldnes and |
|
| 2 |
# Moss) when Satterthwaite = TRUE, ngroups > 1, and eq constraints. |
|
| 3 |
# Use ug2.old.approach = TRUE to get the old result |
|
| 4 | ||
| 5 |
lav_test_satorra_bentler <- function(lavobject = NULL, |
|
| 6 |
lavsamplestats = NULL, |
|
| 7 |
lavmodel = NULL, |
|
| 8 |
lavimplied = NULL, |
|
| 9 |
lavoptions = NULL, |
|
| 10 |
lavdata = NULL, |
|
| 11 |
TEST.unscaled = NULL, |
|
| 12 |
E.inv = NULL, |
|
| 13 |
Delta = NULL, |
|
| 14 |
WLS.V = NULL, |
|
| 15 |
Gamma = NULL, |
|
| 16 |
test = "satorra.bentler", |
|
| 17 |
method = "original", |
|
| 18 |
ug2.old.approach = FALSE, |
|
| 19 |
return.u = FALSE, |
|
| 20 |
return.ugamma = FALSE) {
|
|
| 21 | 4x |
TEST <- list() |
| 22 | ||
| 23 | 4x |
if (!is.null(lavobject)) {
|
| 24 | ! |
lavsamplestats <- lavobject@SampleStats |
| 25 | ! |
lavmodel <- lavobject@Model |
| 26 | ! |
lavoptions <- lavobject@Options |
| 27 | ! |
lavimplied <- lavobject@implied |
| 28 | ! |
lavdata <- lavobject@Data |
| 29 | ! |
TEST$standard <- lavobject@test[[1]] |
| 30 |
} else {
|
|
| 31 | 4x |
TEST$standard <- TEST.unscaled |
| 32 |
} |
|
| 33 | 4x |
npar <- lavmodel@nx.free |
| 34 | ||
| 35 |
# ug2.old.approach |
|
| 36 | 4x |
if (missing(ug2.old.approach)) {
|
| 37 | 4x |
if (!is.null(lavoptions$ug2.old.approach)) {
|
| 38 | 4x |
ug2.old.approach <- lavoptions$ug2.old.approach |
| 39 |
} else {
|
|
| 40 | ! |
ug2.old.approach <- FALSE |
| 41 |
} |
|
| 42 |
} |
|
| 43 | ||
| 44 |
# E.inv ok? |
|
| 45 | 4x |
if (length(lavoptions$information) == 1L && |
| 46 | 4x |
length(lavoptions$h1.information) == 1L && |
| 47 | 4x |
length(lavoptions$observed.information) == 1L) {
|
| 48 | ! |
E.inv.recompute <- FALSE |
| 49 |
} else if ( |
|
| 50 | 4x |
(lavoptions$information[1] == lavoptions$information[2]) && |
| 51 | 4x |
(lavoptions$h1.information[1] == lavoptions$h1.information[2]) && |
| 52 | 4x |
(lavoptions$information[2] == "expected" || |
| 53 | 4x |
(lavoptions$observed.information[1] == |
| 54 | 4x |
lavoptions$observed.information[2]))) {
|
| 55 | 4x |
E.inv.recompute <- FALSE |
| 56 |
} else {
|
|
| 57 | ! |
E.inv.recompute <- TRUE |
| 58 |
# change information options |
|
| 59 | ! |
lavoptions$information[1] <- lavoptions$information[2] |
| 60 | ! |
lavoptions$h1.information[1] <- lavoptions$h1.information[2] |
| 61 | ! |
lavoptions$observed.information[1] <- lavoptions$observed.information[2] |
| 62 |
} |
|
| 63 | 4x |
if (!is.null(E.inv) && !is.null(WLS.V) && !is.null(Delta)) {
|
| 64 | 4x |
E.inv.recompute <- FALSE # user-provided |
| 65 |
} |
|
| 66 | ||
| 67 |
# check test |
|
| 68 | 4x |
if (!all(test %in% c( |
| 69 | 4x |
"satorra.bentler", |
| 70 | 4x |
"scaled.shifted", |
| 71 | 4x |
"mean.var.adjusted" |
| 72 |
))) {
|
|
| 73 | ! |
lav_msg_warn(gettext( |
| 74 | ! |
"test must be one of `satorra.bentler', `scaled.shifted' or |
| 75 | ! |
`mean.var.adjusted'; will use `satorra.bentler' only")) |
| 76 | ! |
test <- "satorra.bentler" |
| 77 |
} |
|
| 78 | ||
| 79 | 4x |
if (return.u) {
|
| 80 | ! |
method <- "original" |
| 81 |
} |
|
| 82 | ||
| 83 |
# check method |
|
| 84 | 4x |
if (!all(method %in% c("original", "orthogonal.complement", "ABA"))) {
|
| 85 | ! |
lav_msg_warn(gettext("method must be one of `original', `ABA',
|
| 86 | ! |
`orthogonal.complement'; will use `ABA'")) |
| 87 | ! |
method <- "original" |
| 88 |
} |
|
| 89 | ||
| 90 |
# do we have E.inv, Delta, WLS.V? |
|
| 91 | 4x |
if (npar > 0L && |
| 92 | 4x |
(is.null(E.inv) || is.null(Delta) || is.null(WLS.V) || E.inv.recompute)) {
|
| 93 | ! |
if (lavoptions$information.expected.mplus && lavoptions$estimator == "ML") {
|
| 94 | ! |
E <- lav_model_information_expected_MLM( |
| 95 | ! |
lavmodel = lavmodel, |
| 96 | ! |
augmented = FALSE, inverted = FALSE, |
| 97 | ! |
lavsamplestats = lavsamplestats, extra = TRUE |
| 98 |
) |
|
| 99 |
} else {
|
|
| 100 | ! |
E <- lav_model_information( |
| 101 | ! |
lavmodel = lavmodel, |
| 102 | ! |
lavimplied = lavimplied, |
| 103 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 104 | ! |
lavoptions = lavoptions, extra = TRUE |
| 105 |
) |
|
| 106 |
} |
|
| 107 | ! |
E.inv <- try(lav_model_information_augment_invert(lavmodel, |
| 108 | ! |
information = E, inverted = TRUE |
| 109 | ! |
), silent = TRUE) |
| 110 | ! |
if (inherits(E.inv, "try-error")) {
|
| 111 | ! |
if (return.ugamma) {
|
| 112 | ! |
lav_msg_warn(gettext( |
| 113 | ! |
"could not invert information matrix needed for UGamma")) |
| 114 | ! |
return(NULL) |
| 115 | ! |
} else if (return.u) {
|
| 116 | ! |
lav_msg_warn(gettext( |
| 117 | ! |
"could not invert information matrix needed for UfromUGamma")) |
| 118 | ! |
return(NULL) |
| 119 |
} else {
|
|
| 120 | ! |
TEST$standard$stat <- as.numeric(NA) |
| 121 | ! |
TEST$standard$stat.group <- rep(as.numeric(NA), lavdata@ngroups) |
| 122 | ! |
TEST$standard$pvalue <- as.numeric(NA) |
| 123 | ! |
TEST[[test[1]]] <- c(TEST$standard, |
| 124 | ! |
scaling.factor = as.numeric(NA), |
| 125 | ! |
shift.parameter = as.numeric(NA), |
| 126 | ! |
label = character(0) |
| 127 |
) |
|
| 128 | ! |
lav_msg_warn(gettext("could not invert information matrix needed for
|
| 129 | ! |
robust test statistic")) |
| 130 | ! |
TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models |
| 131 | ! |
return(TEST) |
| 132 |
} |
|
| 133 |
} |
|
| 134 | ! |
Delta <- attr(E, "Delta") |
| 135 | ! |
WLS.V <- attr(E, "WLS.V") |
| 136 |
} |
|
| 137 | ||
| 138 |
# catch df == 0 |
|
| 139 | 4x |
if ((TEST$standard$df == 0L || TEST$standard$df < 0) && |
| 140 | 4x |
!return.u && !return.ugamma) {
|
| 141 | ! |
TEST[[test[1]]] <- c(TEST$standard, |
| 142 | ! |
scaling.factor = as.numeric(NA), |
| 143 | ! |
label = character(0) |
| 144 |
) |
|
| 145 | ! |
TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models |
| 146 | ! |
return(TEST) |
| 147 |
} |
|
| 148 | ||
| 149 |
# Gamma |
|
| 150 | 4x |
if (is.null(Gamma)) {
|
| 151 | 4x |
Gamma <- lavsamplestats@NACOV |
| 152 |
# still NULL? (perhaps estimator = ML) |
|
| 153 | 4x |
if (is.null(Gamma[[1]])) {
|
| 154 | ! |
if (!is.null(lavobject)) {
|
| 155 | ! |
Gamma <- lav_object_gamma(lavobject, model.based = FALSE) |
| 156 |
} else {
|
|
| 157 | ! |
Gamma <- lav_object_gamma( |
| 158 | ! |
lavobject = NULL, |
| 159 | ! |
lavdata = lavdata, |
| 160 | ! |
lavoptions = lavoptions, |
| 161 | ! |
lavsamplestats = lavsamplestats, |
| 162 | ! |
lavh1 = NULL, |
| 163 | ! |
lavimplied = NULL, |
| 164 | ! |
ADF = TRUE, |
| 165 | ! |
model.based = FALSE |
| 166 |
) |
|
| 167 |
} |
|
| 168 |
} |
|
| 169 |
} |
|
| 170 | ||
| 171 | 4x |
if (lavoptions$information.expected.mplus && lavmodel@categorical) {
|
| 172 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 173 | ! |
Ng <- lavsamplestats@nobs[[g]] |
| 174 | ! |
Gamma[[g]] <- Gamma[[g]] / Ng * (Ng - 1L) |
| 175 |
} |
|
| 176 |
} |
|
| 177 | ||
| 178 |
# ngroups |
|
| 179 | 4x |
ngroups <- lavsamplestats@ngroups |
| 180 | ||
| 181 |
# mean and variance adjusted? |
|
| 182 | 4x |
Satterthwaite <- FALSE |
| 183 | 4x |
if (any(test %in% c("mean.var.adjusted", "scaled.shifted"))) {
|
| 184 | 4x |
Satterthwaite <- TRUE |
| 185 |
} |
|
| 186 | ||
| 187 | 4x |
if (npar == 0) {
|
| 188 |
# catch npar == 0 (eg baseline model if correlation structure) |
|
| 189 | ! |
trace.UGamma <- trace.UGamma2 <- U.all <- UG <- as.numeric(NA) |
| 190 | ! |
fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal |
| 191 | ! |
Gamma.f <- Gamma |
| 192 | ! |
for (g in 1:ngroups) {
|
| 193 | ! |
Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]] |
| 194 |
} |
|
| 195 | ! |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 196 | ! |
UG <- Gamma.all |
| 197 | ! |
trace.UGamma <- sum(diag(Gamma.all)) |
| 198 | ! |
trace.UGamma2 <- sum(UG * t(UG)) |
| 199 | ! |
out <- list( |
| 200 | ! |
trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2, |
| 201 | ! |
UGamma = UG, UfromUGamma = U.all |
| 202 |
) |
|
| 203 | 4x |
} else if (method == "original") {
|
| 204 | 4x |
out <- lav_test_satorra_bentler_trace_original( |
| 205 | 4x |
Gamma = Gamma, |
| 206 | 4x |
Delta = Delta, WLS.V = WLS.V, E.inv = E.inv, |
| 207 | 4x |
ngroups = ngroups, nobs = lavsamplestats@nobs, |
| 208 | 4x |
ntotal = lavsamplestats@ntotal, return.u = return.u, |
| 209 | 4x |
return.ugamma = return.ugamma, |
| 210 | 4x |
ug2.old.approach = ug2.old.approach, |
| 211 | 4x |
Satterthwaite = Satterthwaite |
| 212 |
) |
|
| 213 | ! |
} else if (method == "orthogonal.complement") {
|
| 214 | ! |
out <- lav_test_satorra_bentler_trace_complement( |
| 215 | ! |
Gamma = Gamma, |
| 216 | ! |
Delta = Delta, WLS.V = WLS.V, lavmodel = lavmodel, |
| 217 | ! |
ngroups = ngroups, nobs = lavsamplestats@nobs, |
| 218 | ! |
ntotal = lavsamplestats@ntotal, |
| 219 | ! |
return.ugamma = return.ugamma, |
| 220 | ! |
ug2.old.approach = ug2.old.approach, |
| 221 | ! |
Satterthwaite = Satterthwaite |
| 222 |
) |
|
| 223 | ! |
} else if (method == "ABA") {
|
| 224 | ! |
out <- lav_test_satorra_bentler_trace_ABA( |
| 225 | ! |
Gamma = Gamma, |
| 226 | ! |
Delta = Delta, WLS.V = WLS.V, E.inv = E.inv, |
| 227 | ! |
ngroups = ngroups, nobs = lavsamplestats@nobs, |
| 228 | ! |
ntotal = lavsamplestats@ntotal, |
| 229 | ! |
return.ugamma = return.ugamma, |
| 230 | ! |
ug2.old.approach = ug2.old.approach, |
| 231 | ! |
Satterthwaite = Satterthwaite |
| 232 |
) |
|
| 233 |
} else {
|
|
| 234 | ! |
lav_msg_stop(gettextf("method `%s' not supported", method))
|
| 235 |
} |
|
| 236 | 4x |
trace.UGamma <- out$trace.UGamma |
| 237 | 4x |
trace.UGamma2 <- out$trace.UGamma2 |
| 238 | ||
| 239 | 4x |
if ("satorra.bentler" %in% test) {
|
| 240 |
# same df |
|
| 241 | ! |
df.scaled <- TEST$standard$df |
| 242 | ||
| 243 |
# scaling factor |
|
| 244 | ! |
scaling.factor <- trace.UGamma / df.scaled |
| 245 | ! |
if (scaling.factor < 0) scaling.factor <- as.numeric(NA) |
| 246 | ||
| 247 |
# scaled test statistic per group |
|
| 248 | ! |
stat.group <- TEST$standard$stat.group / scaling.factor |
| 249 | ||
| 250 |
# scaled test statistic global |
|
| 251 | ! |
stat <- sum(stat.group) |
| 252 | ||
| 253 |
# label |
|
| 254 | ! |
if (lavoptions$information.expected.mplus) {
|
| 255 | ! |
if (lavoptions$estimator == "ML") {
|
| 256 | ! |
label <- |
| 257 | ! |
"Satorra-Bentler correction (Mplus variant)" |
| 258 | ! |
} else if (lavoptions$estimator == "DWLS") {
|
| 259 | ! |
label <- |
| 260 | ! |
"Satorra-Bentler correction (WLSM)" |
| 261 | ! |
} else if (lavoptions$estimator == "ULS") {
|
| 262 | ! |
label <- |
| 263 | ! |
"Satorra-Bentler correction (ULSM)" |
| 264 |
} |
|
| 265 |
} else {
|
|
| 266 | ! |
label <- "Satorra-Bentler correction" |
| 267 |
} |
|
| 268 | ||
| 269 | ! |
TEST$satorra.bentler <- |
| 270 | ! |
list( |
| 271 | ! |
test = "satorra.bentler", |
| 272 | ! |
stat = stat, |
| 273 | ! |
stat.group = stat.group, |
| 274 | ! |
df = df.scaled, |
| 275 | ! |
pvalue = 1 - pchisq(stat, df.scaled), |
| 276 | ! |
trace.UGamma = trace.UGamma, |
| 277 | ! |
scaling.factor = scaling.factor, |
| 278 | ! |
scaled.test.stat = TEST$standard$stat, |
| 279 | ! |
scaled.test = TEST$standard$test, |
| 280 | ! |
label = label |
| 281 |
) |
|
| 282 |
} |
|
| 283 | ||
| 284 | 4x |
if ("mean.var.adjusted" %in% test) {
|
| 285 | ! |
if (lavoptions$information.expected.mplus) {
|
| 286 | ! |
df.scaled <- floor(trace.UGamma^2 / trace.UGamma2 + 0.5) |
| 287 |
} else {
|
|
| 288 |
# more precise, fractional df |
|
| 289 | ! |
df.scaled <- trace.UGamma^2 / trace.UGamma2 |
| 290 |
} |
|
| 291 | ||
| 292 |
# scaling factor |
|
| 293 | ! |
scaling.factor <- trace.UGamma / df.scaled |
| 294 | ! |
if (scaling.factor < 0) scaling.factor <- as.numeric(NA) |
| 295 | ||
| 296 | ! |
if (ug2.old.approach) {
|
| 297 |
# scaled test statistic per group |
|
| 298 | ! |
stat.group <- TEST$standard$stat.group / scaling.factor |
| 299 | ||
| 300 |
# scaled test statistic global |
|
| 301 | ! |
stat <- sum(stat.group) |
| 302 |
} else {
|
|
| 303 |
# scaled test statistic per group |
|
| 304 | ! |
stat.group <- TEST$standard$stat.group / scaling.factor |
| 305 | ||
| 306 |
# scaled test statistic global |
|
| 307 | ! |
stat <- TEST$standard$stat / scaling.factor |
| 308 |
} |
|
| 309 | ||
| 310 |
# label |
|
| 311 | ! |
if (lavoptions$information.expected.mplus) {
|
| 312 | ! |
if (lavoptions$estimator == "ML") {
|
| 313 | ! |
label <- |
| 314 | ! |
"mean and variance adjusted correction (MLMV)" |
| 315 | ! |
} else if (lavoptions$estimator == "DWLS") {
|
| 316 | ! |
label <- |
| 317 | ! |
"mean and variance adjusted correction (WLSMV)" |
| 318 | ! |
} else if (lavoptions$estimator == "ULS") {
|
| 319 | ! |
label <- |
| 320 | ! |
"mean and variance adjusted correction (ULSMV)" |
| 321 |
} |
|
| 322 |
} else {
|
|
| 323 | ! |
label <- "mean and variance adjusted correction" |
| 324 |
} |
|
| 325 | ||
| 326 | ! |
TEST$mean.var.adjusted <- |
| 327 | ! |
list( |
| 328 | ! |
test = "mean.var.adjusted", |
| 329 | ! |
stat = stat, |
| 330 | ! |
stat.group = stat.group, |
| 331 | ! |
df = df.scaled, |
| 332 | ! |
pvalue = 1 - pchisq(stat, df.scaled), |
| 333 | ! |
trace.UGamma = trace.UGamma, |
| 334 | ! |
trace.UGamma2 = trace.UGamma2, |
| 335 | ! |
scaling.factor = scaling.factor, |
| 336 | ! |
scaled.test.stat = TEST$standard$stat, |
| 337 | ! |
scaled.test = TEST$standard$test, |
| 338 | ! |
label = label |
| 339 |
) |
|
| 340 |
} |
|
| 341 | ||
| 342 | 4x |
if ("scaled.shifted" %in% test) {
|
| 343 |
# this is the T3 statistic as used by Mplus 6 and higher |
|
| 344 |
# see 'Simple Second Order Chi-Square Correction' 2010 |
|
| 345 |
# www.statmodel.com |
|
| 346 | ||
| 347 |
# same df |
|
| 348 | 4x |
df.scaled <- TEST$standard$df |
| 349 | ||
| 350 |
# scaling factor |
|
| 351 | 4x |
fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal |
| 352 | 4x |
a <- sqrt(df.scaled / trace.UGamma2) |
| 353 | ! |
if (isTRUE(a < 0) || is.nan(a)) a <- as.numeric(NA) |
| 354 | 4x |
scaling.factor <- 1 / a |
| 355 | ! |
if (isTRUE(scaling.factor < 0)) scaling.factor <- as.numeric(NA) |
| 356 | ||
| 357 | 4x |
if (ug2.old.approach) {
|
| 358 |
# scaling factor |
|
| 359 | ! |
shift.parameter <- fg * (df.scaled - a * trace.UGamma) |
| 360 |
# scaled test statistic per group |
|
| 361 | ! |
stat.group <- (TEST$standard$stat.group * a + shift.parameter) |
| 362 |
# scaled test statistic global |
|
| 363 | ! |
stat <- sum(stat.group) |
| 364 |
} else {
|
|
| 365 | 4x |
shift.parameter <- df.scaled - a * trace.UGamma |
| 366 | 4x |
stat <- TEST$standard$stat * a + shift.parameter |
| 367 | 4x |
stat.group <- TEST$standard$stat.group * a + fg * shift.parameter |
| 368 |
} |
|
| 369 | ||
| 370 |
# label |
|
| 371 | 4x |
if (lavoptions$information.expected.mplus) {
|
| 372 | ! |
if (lavoptions$estimator == "ML") {
|
| 373 | ! |
label <- |
| 374 | ! |
"simple second-order correction (MLMV)" |
| 375 | ! |
} else if (lavoptions$estimator == "DWLS") {
|
| 376 | ! |
label <- |
| 377 | ! |
"simple second-order correction (WLSMV)" |
| 378 | ! |
} else if (lavoptions$estimator == "ULS") {
|
| 379 | ! |
label <- |
| 380 | ! |
"simple second-order correction (ULSMV)" |
| 381 |
} |
|
| 382 |
} else {
|
|
| 383 | 4x |
label <- "simple second-order correction" |
| 384 |
} |
|
| 385 | ||
| 386 | 4x |
TEST$scaled.shifted <- |
| 387 | 4x |
list( |
| 388 | 4x |
test = "scaled.shifted", |
| 389 | 4x |
stat = stat, |
| 390 | 4x |
stat.group = stat.group, |
| 391 | 4x |
df = df.scaled, |
| 392 | 4x |
pvalue = 1 - pchisq(stat, df.scaled), |
| 393 | 4x |
trace.UGamma = trace.UGamma, |
| 394 | 4x |
trace.UGamma2 = trace.UGamma2, |
| 395 | 4x |
scaling.factor = scaling.factor, |
| 396 | 4x |
shift.parameter = shift.parameter, |
| 397 | 4x |
scaled.test.stat = TEST$standard$stat, |
| 398 | 4x |
scaled.test = TEST$standard$test, |
| 399 | 4x |
label = label |
| 400 |
) |
|
| 401 |
} |
|
| 402 | ||
| 403 | 4x |
if (return.ugamma) {
|
| 404 | ! |
TEST$UGamma <- out$UGamma |
| 405 |
} |
|
| 406 | ||
| 407 | 4x |
if (return.u) {
|
| 408 | ! |
TEST$UfromUGamma <- out$UfromUGamma |
| 409 |
} |
|
| 410 | ||
| 411 | 4x |
TEST |
| 412 |
} |
|
| 413 | ||
| 414 |
# using the `classical' formula |
|
| 415 |
# UG = Gamma * [V - V Delta E.inv Delta' V'] |
|
| 416 |
lav_test_satorra_bentler_trace_original <- function(Gamma = NULL, |
|
| 417 |
Delta = NULL, |
|
| 418 |
WLS.V = NULL, |
|
| 419 |
E.inv = NULL, |
|
| 420 |
ngroups = NULL, |
|
| 421 |
nobs = NULL, |
|
| 422 |
ntotal = NULL, |
|
| 423 |
return.u = FALSE, |
|
| 424 |
return.ugamma = FALSE, |
|
| 425 |
ug2.old.approach = FALSE, |
|
| 426 |
Satterthwaite = FALSE) {
|
|
| 427 |
# this is what we did <0.6-13: everything per group |
|
| 428 | 4x |
if (ug2.old.approach) {
|
| 429 | ! |
UfromUGamma <- UG <- vector("list", ngroups)
|
| 430 | ! |
trace.UGamma <- trace.UGamma2 <- rep(as.numeric(NA), ngroups) |
| 431 | ! |
for (g in 1:ngroups) {
|
| 432 | ! |
fg <- nobs[[g]] / ntotal |
| 433 | ! |
Gamma.g <- Gamma[[g]] / fg ## ?? check this |
| 434 | ! |
Delta.g <- Delta[[g]] |
| 435 | ! |
if (is.matrix(WLS.V[[g]])) {
|
| 436 | ! |
WLS.Vg <- WLS.V[[g]] * fg |
| 437 |
} else {
|
|
| 438 | ! |
WLS.Vg <- diag(WLS.V[[g]]) * fg |
| 439 |
} |
|
| 440 | ||
| 441 | ! |
U <- (WLS.Vg - WLS.Vg %*% Delta[[g]] %*% E.inv %*% |
| 442 | ! |
t(Delta[[g]]) %*% WLS.Vg) |
| 443 | ! |
trace.UGamma[g] <- sum(U * Gamma.g) |
| 444 | ||
| 445 | ! |
if (return.u) {
|
| 446 | ! |
UfromUGamma[[g]] <- U |
| 447 |
} |
|
| 448 | ||
| 449 | ! |
UG <- NULL |
| 450 | ! |
if (Satterthwaite || return.ugamma) {
|
| 451 | ! |
UG.group <- U %*% Gamma.g |
| 452 | ! |
trace.UGamma2[g] <- sum(UG.group * t(UG.group)) |
| 453 | ! |
UG[[g]] <- UG.group |
| 454 |
} |
|
| 455 |
} # g |
|
| 456 |
# sum over groups |
|
| 457 | ! |
trace.UGamma <- sum(trace.UGamma) |
| 458 | ! |
trace.UGamma2 <- sum(trace.UGamma2) |
| 459 | ! |
U.all <- UfromUGamma # group-specific |
| 460 |
} else {
|
|
| 461 | 4x |
trace.UGamma <- trace.UGamma2 <- U.all <- UG <- as.numeric(NA) |
| 462 | 4x |
fg <- unlist(nobs) / ntotal |
| 463 | 4x |
if (Satterthwaite || return.ugamma || return.u) {
|
| 464 |
# for trace.UGamma2, we can no longer compute the trace per group |
|
| 465 | 4x |
V.g <- WLS.V |
| 466 | 4x |
for (g in 1:ngroups) {
|
| 467 | 4x |
if (is.matrix(WLS.V[[g]])) {
|
| 468 | ! |
V.g[[g]] <- fg[g] * WLS.V[[g]] |
| 469 |
} else {
|
|
| 470 | 4x |
V.g[[g]] <- fg[g] * diag(WLS.V[[g]]) |
| 471 |
} |
|
| 472 |
} |
|
| 473 | 4x |
V.all <- lav_matrix_bdiag(V.g) |
| 474 | 4x |
Gamma.f <- Gamma |
| 475 | 4x |
for (g in 1:ngroups) {
|
| 476 | 4x |
Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]] |
| 477 |
} |
|
| 478 | 4x |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 479 | 4x |
Delta.all <- do.call("rbind", Delta)
|
| 480 | 4x |
U.all <- V.all - V.all %*% Delta.all %*% E.inv %*% t(Delta.all) %*% V.all |
| 481 | 4x |
UG <- U.all %*% Gamma.all |
| 482 | ||
| 483 | 4x |
trace.UGamma <- sum(U.all * Gamma.all) |
| 484 | 4x |
trace.UGamma2 <- sum(UG * t(UG)) |
| 485 |
} else {
|
|
| 486 |
# we only need trace.UGamma - this can be done group-specific |
|
| 487 | ! |
trace.UGamma.group <- numeric(ngroups) |
| 488 | ! |
for (g in 1:ngroups) {
|
| 489 | ! |
Gamma.g <- Gamma[[g]] / fg[g] |
| 490 | ! |
Delta.g <- Delta[[g]] |
| 491 | ! |
if (is.matrix(WLS.V[[g]])) {
|
| 492 | ! |
WLS.Vg <- WLS.V[[g]] * fg[g] |
| 493 |
} else {
|
|
| 494 | ! |
WLS.Vg <- diag(WLS.V[[g]]) * fg[g] |
| 495 |
} |
|
| 496 | ||
| 497 | ! |
U <- (WLS.Vg - WLS.Vg %*% Delta[[g]] %*% E.inv %*% |
| 498 | ! |
t(Delta[[g]]) %*% WLS.Vg) |
| 499 | ! |
trace.UGamma.group[g] <- sum(U * Gamma.g) |
| 500 |
} |
|
| 501 | ! |
trace.UGamma <- sum(trace.UGamma.group) |
| 502 |
} |
|
| 503 |
} |
|
| 504 | ||
| 505 | 4x |
list( |
| 506 | 4x |
trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2, |
| 507 | 4x |
UGamma = UG, UfromUGamma = U.all |
| 508 |
) |
|
| 509 |
} |
|
| 510 | ||
| 511 |
# using the orthogonal complement of Delta: Delta.c |
|
| 512 |
# UG = [ (Delta.c' W Delta.c)^{-1} (Delta.c' Gamma Delta.c)
|
|
| 513 |
lav_test_satorra_bentler_trace_complement <- function(Gamma = NULL, |
|
| 514 |
Delta = NULL, |
|
| 515 |
WLS.V = NULL, |
|
| 516 |
lavmodel = NULL, |
|
| 517 |
ngroups = NULL, |
|
| 518 |
nobs = NULL, |
|
| 519 |
ntotal = NULL, |
|
| 520 |
return.ugamma = FALSE, |
|
| 521 |
ug2.old.approach = FALSE, |
|
| 522 |
Satterthwaite = FALSE) {
|
|
| 523 |
# this is what we did <0.6-13: everything per group |
|
| 524 |
# does not work when ngroups > 1 + equality constraints |
|
| 525 | ! |
if (ug2.old.approach) {
|
| 526 | ! |
UG <- vector("list", ngroups)
|
| 527 | ! |
trace.UGamma <- trace.UGamma2 <- rep(as.numeric(NA), ngroups) |
| 528 | ! |
for (g in 1:ngroups) {
|
| 529 | ! |
fg <- nobs[[g]] / ntotal |
| 530 | ! |
Gamma.g <- Gamma[[g]] / fg ## ?? check this |
| 531 | ! |
Delta.g <- Delta[[g]] |
| 532 | ! |
if (is.matrix(WLS.V[[g]])) {
|
| 533 | ! |
WLS.Vg <- WLS.V[[g]] * fg |
| 534 |
} else {
|
|
| 535 | ! |
WLS.Vg <- diag(WLS.V[[g]]) * fg |
| 536 |
} |
|
| 537 | ||
| 538 |
# handle equality constraints |
|
| 539 |
# FIXME: inequality constraints are ignored! |
|
| 540 | ! |
if (lavmodel@eq.constraints) {
|
| 541 | ! |
Delta.g <- Delta.g %*% lavmodel@eq.constraints.K |
| 542 | ! |
} else if (lavmodel@ceq.simple.only) {
|
| 543 | ! |
Delta.g <- Delta.g %*% lavmodel@ceq.simple.K |
| 544 |
} |
|
| 545 | ||
| 546 |
# orthogonal complement of Delta.g |
|
| 547 | ! |
Delta.c <- lav_matrix_orthogonal_complement(Delta.g) |
| 548 | ||
| 549 |
### FIXME: compute WLS.W directly, instead of using solve(WLS.V) |
|
| 550 | ||
| 551 | ! |
tmp1 <- solve(t(Delta.c) %*% solve(WLS.Vg) %*% Delta.c) |
| 552 | ! |
tmp2 <- t(Delta.c) %*% Gamma.g %*% Delta.c |
| 553 | ||
| 554 | ! |
trace.UGamma[g] <- sum(tmp1 * tmp2) |
| 555 | ! |
UG <- NULL |
| 556 | ! |
if (Satterthwaite || return.ugamma) {
|
| 557 | ! |
UG.group <- tmp1 %*% tmp2 |
| 558 | ! |
trace.UGamma2[g] <- sum(UG.group * t(UG.group)) |
| 559 | ! |
UG[[g]] <- UG.group |
| 560 |
} |
|
| 561 |
} |
|
| 562 |
# sum over groups |
|
| 563 | ! |
trace.UGamma <- sum(trace.UGamma) |
| 564 | ! |
trace.UGamma2 <- sum(trace.UGamma2) |
| 565 |
} else {
|
|
| 566 | ! |
trace.UGamma <- trace.UGamma2 <- UG <- as.numeric(NA) |
| 567 | ! |
fg <- unlist(nobs) / ntotal |
| 568 | ||
| 569 | ! |
V.g <- WLS.V |
| 570 | ! |
for (g in 1:ngroups) {
|
| 571 | ! |
if (is.matrix(WLS.V[[g]])) {
|
| 572 | ! |
V.g[[g]] <- fg[g] * WLS.V[[g]] |
| 573 |
} else {
|
|
| 574 | ! |
V.g[[g]] <- fg[g] * diag(WLS.V[[g]]) |
| 575 |
} |
|
| 576 |
} |
|
| 577 | ! |
V.all <- lav_matrix_bdiag(V.g) |
| 578 | ! |
Gamma.f <- Gamma |
| 579 | ! |
for (g in 1:ngroups) {
|
| 580 | ! |
Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]] |
| 581 |
} |
|
| 582 | ! |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 583 | ! |
Delta.all <- do.call("rbind", Delta)
|
| 584 | ||
| 585 |
# handle equality constraints |
|
| 586 |
# FIXME: inequality constraints are ignored! |
|
| 587 | ! |
if (lavmodel@eq.constraints) {
|
| 588 | ! |
Delta.all <- Delta.all %*% lavmodel@eq.constraints.K |
| 589 | ! |
} else if (lavmodel@ceq.simple.only) {
|
| 590 | ! |
Delta.all <- Delta.all %*% lavmodel@ceq.simple.K |
| 591 |
} |
|
| 592 | ||
| 593 |
# orthogonal complement of Delta.g |
|
| 594 | ! |
Delta.c <- lav_matrix_orthogonal_complement(Delta.all) |
| 595 | ||
| 596 | ! |
tmp1 <- solve(t(Delta.c) %*% solve(V.all) %*% Delta.c) |
| 597 | ! |
tmp2 <- t(Delta.c) %*% Gamma.all %*% Delta.c |
| 598 | ||
| 599 | ! |
UG <- tmp1 %*% tmp2 |
| 600 | ||
| 601 | ! |
trace.UGamma <- sum(tmp1 * tmp2) |
| 602 | ! |
trace.UGamma2 <- sum(UG * t(UG)) |
| 603 |
} |
|
| 604 | ||
| 605 | ! |
list( |
| 606 | ! |
trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2, |
| 607 | ! |
UGamma = UG |
| 608 |
) |
|
| 609 |
} |
|
| 610 | ||
| 611 |
# using the ABA form |
|
| 612 |
# UG = Gamma %*% [V - V %*% Delta %*% E.inv %*% tDelta %*% V] |
|
| 613 |
# = Gamma %*% V - Gamma %*% V %*% Delta %*% E.inv %*% tDelta %*% V |
|
| 614 |
# = Gamma %*% A1 - Gamma %*% A1 %*% Delta %*% E.inv %*% tDelta %*% A1 |
|
| 615 |
# (define AGA1 := A1 %*% Gamma %*% A1) |
|
| 616 |
# Note this is not identical to 'B1', (model-based) first-order information |
|
| 617 |
# |
|
| 618 |
# = A1.inv %*% A1 %*% Gamma %*% A1 - |
|
| 619 |
# A1.inv %*% A1 %*% Gamma %*% A1 %*% Delta %*% E.inv %*% tDelta %*% A1 |
|
| 620 |
# |
|
| 621 |
# = A1.inv %*% AGA1 - |
|
| 622 |
# A1.inv %*% AGA1 %*% Delta %*% E.inv %*% tDelta %*% A1 |
|
| 623 |
# |
|
| 624 |
# if only the trace is needed, we can use reduce the rhs (after the minus) |
|
| 625 |
# to AGA1 %*% Delta %*% E.inv %*% tDelta (eliminating A1 and A1.inv) |
|
| 626 | ||
| 627 |
# we write it like this to highlight the connection with MLR |
|
| 628 |
# |
|
| 629 |
lav_test_satorra_bentler_trace_ABA <- function(Gamma = NULL, |
|
| 630 |
Delta = NULL, |
|
| 631 |
WLS.V = NULL, |
|
| 632 |
E.inv = NULL, |
|
| 633 |
ngroups = NULL, |
|
| 634 |
nobs = NULL, |
|
| 635 |
ntotal = NULL, |
|
| 636 |
return.ugamma = FALSE, |
|
| 637 |
ug2.old.approach = FALSE, |
|
| 638 |
Satterthwaite = FALSE) {
|
|
| 639 |
# this is what we did <0.6-13: everything per group |
|
| 640 | ! |
if (ug2.old.approach) {
|
| 641 | ! |
UfromUGamma <- UG <- vector("list", ngroups)
|
| 642 | ! |
trace.UGamma <- trace.UGamma2 <- rep(as.numeric(NA), ngroups) |
| 643 | ||
| 644 | ! |
for (g in 1:ngroups) {
|
| 645 | ! |
fg <- nobs[[g]] / ntotal |
| 646 | ! |
Gamma.g <- Gamma[[g]] / fg ## ?? check this |
| 647 | ! |
Delta.g <- Delta[[g]] |
| 648 | ||
| 649 |
# diagonal WLS.V? we check for this since 0.5-17 |
|
| 650 | ! |
diagonal <- FALSE |
| 651 | ! |
if (is.matrix(WLS.V[[g]])) {
|
| 652 | ! |
A1 <- WLS.V[[g]] * fg |
| 653 | ! |
AGA1 <- A1 %*% Gamma.g %*% A1 |
| 654 |
} else {
|
|
| 655 | ! |
diagonal <- TRUE |
| 656 | ! |
a1 <- WLS.V[[g]] * fg # numeric vector! |
| 657 | ! |
AGA1 <- Gamma.g * tcrossprod(a1) |
| 658 |
} |
|
| 659 | ||
| 660 |
# note: we have AGA1 at the end, to avoid ending up with |
|
| 661 |
# a transposed matrix (both parts are non-symmetric) |
|
| 662 | ! |
if (diagonal) {
|
| 663 | ! |
UG <- t(Gamma.g * a1) - |
| 664 | ! |
(Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1) |
| 665 |
} else {
|
|
| 666 | ! |
UG <- (Gamma.g %*% A1) - |
| 667 | ! |
(Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1) |
| 668 |
} |
|
| 669 | ||
| 670 | ! |
trace.UGamma[g] <- sum(diag(UG)) |
| 671 | ! |
if (Satterthwaite) {
|
| 672 | ! |
trace.UGamma2[g] <- sum(UG * t(UG)) |
| 673 |
} |
|
| 674 |
} |
|
| 675 |
# sum over groups |
|
| 676 | ! |
trace.UGamma <- sum(trace.UGamma) |
| 677 | ! |
trace.UGamma2 <- sum(trace.UGamma2) |
| 678 |
} else {
|
|
| 679 | ! |
trace.UGamma <- trace.UGamma2 <- UG <- as.numeric(NA) |
| 680 | ! |
fg <- unlist(nobs) / ntotal |
| 681 | ! |
if (Satterthwaite || return.ugamma) {
|
| 682 |
# for trace.UGamma2, we can no longer compute the trace per group |
|
| 683 | ! |
V.g <- WLS.V |
| 684 | ! |
for (g in 1:ngroups) {
|
| 685 | ! |
if (is.matrix(WLS.V[[g]])) {
|
| 686 | ! |
V.g[[g]] <- fg[g] * WLS.V[[g]] |
| 687 |
} else {
|
|
| 688 | ! |
V.g[[g]] <- fg[g] * diag(WLS.V[[g]]) |
| 689 |
} |
|
| 690 |
} |
|
| 691 | ! |
V.all <- lav_matrix_bdiag(V.g) |
| 692 | ! |
Gamma.f <- Gamma |
| 693 | ! |
for (g in 1:ngroups) {
|
| 694 | ! |
Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]] |
| 695 |
} |
|
| 696 | ! |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 697 | ! |
Delta.all <- do.call("rbind", Delta)
|
| 698 | ||
| 699 | ! |
AGA1 <- V.all %*% Gamma.all %*% V.all |
| 700 | ||
| 701 | ! |
UG <- (Gamma.all %*% V.all) - |
| 702 | ! |
(Delta.all %*% tcrossprod(E.inv, Delta.all) %*% AGA1) |
| 703 | ||
| 704 | ! |
trace.UGamma <- sum(diag(UG)) |
| 705 | ! |
trace.UGamma2 <- sum(UG * t(UG)) |
| 706 |
} else {
|
|
| 707 | ! |
trace.UGamma.group <- numeric(ngroups) |
| 708 | ! |
for (g in 1:ngroups) {
|
| 709 | ! |
fg <- nobs[[g]] / ntotal |
| 710 | ! |
Gamma.g <- Gamma[[g]] / fg ## ?? check this |
| 711 | ! |
Delta.g <- Delta[[g]] |
| 712 | ||
| 713 |
# diagonal WLS.V? we check for this since 0.5-17 |
|
| 714 | ! |
diagonal <- FALSE |
| 715 | ! |
if (is.matrix(WLS.V[[g]])) {
|
| 716 | ! |
A1 <- WLS.V[[g]] * fg |
| 717 | ! |
AGA1 <- A1 %*% Gamma.g %*% A1 |
| 718 |
} else {
|
|
| 719 | ! |
diagonal <- TRUE |
| 720 | ! |
a1 <- WLS.V[[g]] * fg # numeric vector! |
| 721 | ! |
AGA1 <- Gamma.g * tcrossprod(a1) |
| 722 |
} |
|
| 723 | ||
| 724 |
# note: we have AGA1 at the end, to avoid ending up with |
|
| 725 |
# a transposed matrix (both parts are non-symmetric) |
|
| 726 | ! |
if (diagonal) {
|
| 727 | ! |
UG <- t(Gamma.g * a1) - |
| 728 | ! |
(Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1) |
| 729 |
} else {
|
|
| 730 | ! |
UG <- (Gamma.g %*% A1) - |
| 731 | ! |
(Delta.g %*% tcrossprod(E.inv, Delta.g) %*% AGA1) |
| 732 |
} |
|
| 733 | ||
| 734 | ! |
trace.UGamma.group[g] <- sum(diag(UG)) |
| 735 |
} # g |
|
| 736 | ! |
trace.UGamma <- sum(trace.UGamma.group) |
| 737 |
} |
|
| 738 |
} |
|
| 739 | ||
| 740 | ! |
if (!return.ugamma) {
|
| 741 | ! |
UG <- NULL |
| 742 |
} |
|
| 743 | ||
| 744 | ! |
list( |
| 745 | ! |
trace.UGamma = trace.UGamma, trace.UGamma2 = trace.UGamma2, |
| 746 | ! |
UGamma = UG |
| 747 |
) |
|
| 748 |
} |
| 1 |
# utility functions for the sam() function |
|
| 2 |
# YR 4 April 2023 |
|
| 3 | ||
| 4 |
# construct 'mapping matrix' M using either "ML", "GLS" or "ULS" method |
|
| 5 |
# optionally return MTM (for ML) |
|
| 6 |
# |
|
| 7 |
# by construction, M %*% LAMBDA = I (the identity matrix) |
|
| 8 |
lav_sam_mapping_matrix <- function(LAMBDA = NULL, THETA = NULL, |
|
| 9 |
S = NULL, S.inv = NULL, |
|
| 10 |
method = "ML") {
|
|
| 11 | ||
| 12 | ! |
method <- toupper(method) |
| 13 | ||
| 14 |
# catch empty columns in LAMBDA (eg higher order!) |
|
| 15 | ! |
LAMBDA.orig <- LAMBDA |
| 16 | ! |
empty.idx <- which(apply(LAMBDA, 2L, function(x) all(x == 0))) |
| 17 | ! |
if (length(empty.idx) > 0L) {
|
| 18 | ! |
LAMBDA <- LAMBDA.orig[, -empty.idx, drop = FALSE] |
| 19 |
} |
|
| 20 | ||
| 21 |
# ULS |
|
| 22 |
# M == solve( t(LAMBDA) %*% LAMBDA ) %*% t(LAMBDA) |
|
| 23 |
# == MASS:::ginv(LAMBDA) |
|
| 24 | ! |
if (method == "ULS") {
|
| 25 |
# M == solve( t(LAMBDA) %*% LAMBDA ) %*% t(LAMBDA) |
|
| 26 |
# == MASS:::ginv(LAMBDA) |
|
| 27 | ! |
M <- try(tcrossprod(solve(crossprod(LAMBDA)), LAMBDA), |
| 28 | ! |
silent = TRUE |
| 29 |
) |
|
| 30 | ! |
if (inherits(M, "try-error")) {
|
| 31 | ! |
lav_msg_warn(gettext( |
| 32 | ! |
"cannot invert crossprod(LAMBDA); using generalized inverse")) |
| 33 | ! |
M <- MASS::ginv(LAMBDA) |
| 34 |
} |
|
| 35 | ||
| 36 | ||
| 37 |
# GLS |
|
| 38 |
# M == solve( t(LAMBDA) %*% S.inv %*% LAMBDA ) %*% t(LAMBDA) %*% S.inv |
|
| 39 | ! |
} else if (method == "GLS") {
|
| 40 | ! |
if (is.null(S.inv)) {
|
| 41 | ! |
S.inv <- try(solve(S), silent = TRUE) |
| 42 |
} |
|
| 43 | ! |
if (inherits(S.inv, "try-error")) {
|
| 44 | ! |
lav_msg_warn(gettext("S is not invertible; switching to ULS method"))
|
| 45 | ! |
M <- lav_sam_mapping_matrix(LAMBDA = LAMBDA, method = "ULS") |
| 46 |
} else {
|
|
| 47 | ! |
tLSinv <- t(LAMBDA) %*% S.inv |
| 48 | ! |
tLSinvL <- tLSinv %*% LAMBDA |
| 49 | ! |
M <- try(solve(tLSinvL, tLSinv), silent = TRUE) |
| 50 | ! |
if (inherits(M, "try-error")) {
|
| 51 | ! |
lav_msg_warn(gettext("problem contructing mapping matrix;
|
| 52 | ! |
switching to generalized inverse")) |
| 53 | ! |
M <- MASS::ginv(tLSinvL) %*% tLSinv |
| 54 |
} |
|
| 55 |
} |
|
| 56 | ||
| 57 |
# ML |
|
| 58 |
# M == solve(t(LAMBDA) %*% THETA.inv %*% LAMBDA) %*% t(LAMBDA) %*% THETA.inv |
|
| 59 | ! |
} else if (method == "ML") {
|
| 60 |
# Problem: if THETA has zero elements on the diagonal, we cannot invert |
|
| 61 | ||
| 62 |
# As we do not have access to Sigma(.inv), we cannot |
|
| 63 |
# use the trick as in lavPredict() (where we replace THETA.inv by |
|
| 64 |
# Sigma.inv) |
|
| 65 | ||
| 66 |
# old method (<0.6-16): remove rows/cols with zero values |
|
| 67 |
# on the diagonal of THETA, invert the submatrix and |
|
| 68 |
# set the '0' diagonal elements to one. This resulted in (somewhat) |
|
| 69 |
# distorted results. |
|
| 70 | ||
| 71 |
# new in 0.6-16: we use the Wall & Amemiya (2000) method using |
|
| 72 |
# the so-called 'T' transformation |
|
| 73 | ||
| 74 |
# new in 0.6-18: if we cannot use the marker method (eg growth models), |
|
| 75 |
# use the 'old' method anyway: remove zero rows/cols and invert submatrix |
|
| 76 | ||
| 77 | ! |
zero.theta.idx <- which(abs(diag(THETA)) < 1e-4) # be conservative |
| 78 | ! |
if (length(zero.theta.idx) == 0L) {
|
| 79 |
# ok, no zero diagonal elements: try to invert THETA |
|
| 80 | ! |
if (lav_matrix_is_diagonal(THETA)) {
|
| 81 | ! |
THETA.inv <- diag(1 / diag(THETA), nrow = nrow(THETA)) |
| 82 |
} else {
|
|
| 83 | ! |
THETA.inv <- try(solve(THETA), silent = TRUE) |
| 84 | ! |
if (inherits(THETA, "try-error")) {
|
| 85 | ! |
THETA.inv <- NULL |
| 86 |
} |
|
| 87 |
} |
|
| 88 |
} else {
|
|
| 89 |
# see if we can use marker method |
|
| 90 | ! |
marker.idx <- lav_utils_get_marker(LAMBDA = LAMBDA, std.lv = TRUE) |
| 91 | ! |
if (any(is.na(marker.idx))) {
|
| 92 | ! |
THETA.inv <- try(lav_matrix_symmetric_inverse(THETA), silent = TRUE) |
| 93 | ! |
if (inherits(THETA.inv, "try-error")) {
|
| 94 | ! |
THETA.inv <- NULL |
| 95 |
} else {
|
|
| 96 | ! |
diag(THETA.inv)[zero.theta.idx] <- 1 |
| 97 |
} |
|
| 98 |
} else {
|
|
| 99 |
# try tmat method later on |
|
| 100 | ! |
THETA.inv <- NULL |
| 101 |
} |
|
| 102 |
} |
|
| 103 | ||
| 104 |
# could we invert THETA? |
|
| 105 | ! |
if (!is.null(THETA.inv)) {
|
| 106 |
# ha, all is good; compute M the usual way |
|
| 107 | ! |
tLTi <- t(LAMBDA) %*% THETA.inv |
| 108 | ! |
tLTiL <- tLTi %*% LAMBDA |
| 109 | ! |
M <- try(solve(tLTiL, tLTi), silent = TRUE) |
| 110 | ! |
if (inherits(M, "try-error")) {
|
| 111 | ! |
lav_msg_warn(gettext( |
| 112 | ! |
"problem contructing ML mapping matrix; switching to ULS")) |
| 113 | ! |
M <- lav_sam_mapping_matrix(LAMBDA = LAMBDA, method = "ULS") |
| 114 |
} |
|
| 115 |
} else {
|
|
| 116 |
# use W&A2000's method using the 'T' transformation |
|
| 117 | ! |
M <- try(lav_sam_mapping_matrix_tmat( |
| 118 | ! |
LAMBDA = LAMBDA, |
| 119 | ! |
THETA = THETA |
| 120 | ! |
), silent = TRUE) |
| 121 | ! |
if (inherits(M, "try-error")) {
|
| 122 | ! |
lav_msg_warn(gettext( |
| 123 | ! |
"problem contructing ML mapping matrix; switching to ULS")) |
| 124 | ! |
M <- lav_sam_mapping_matrix(LAMBDA = LAMBDA, method = "ULS") |
| 125 |
} |
|
| 126 |
} |
|
| 127 |
} # ML |
|
| 128 | ||
| 129 |
# empty.idx? |
|
| 130 | ! |
if (length(empty.idx) > 0L) {
|
| 131 | ! |
M.full <- M |
| 132 | ! |
M <- matrix(0, nrow = ncol(LAMBDA.orig), ncol = ncol(M.full)) |
| 133 | ! |
M[-empty.idx, ] <- M.full |
| 134 |
} |
|
| 135 | ||
| 136 | ! |
M |
| 137 |
} |
|
| 138 | ||
| 139 |
# use 'T' transformation to create the 'Bartlett/ML' mapping matrix |
|
| 140 |
# see Wall & Amemiya (2000) eq (7) |
|
| 141 |
# see also Fuller 1987 page 357 (where T is called H), and page 364 |
|
| 142 | ||
| 143 |
# although Fuller/W&A always assumed that THETA is diagonal, |
|
| 144 |
# their method seems to work equally well for non-diagonal THETA |
|
| 145 |
# |
|
| 146 |
# in our implementation: |
|
| 147 |
# - we do NOT reorder the rows of LAMBDA |
|
| 148 |
# - if std.lv = TRUE, we first rescale to 'create' marker indicators |
|
| 149 |
# and then rescale back at the end |
|
| 150 |
# |
|
| 151 |
lav_sam_mapping_matrix_tmat <- function(LAMBDA = NULL, |
|
| 152 |
THETA = NULL, |
|
| 153 |
marker.idx = NULL, |
|
| 154 |
std.lv = NULL) {
|
|
| 155 | ||
| 156 | ! |
LAMBDA <- as.matrix.default(LAMBDA) |
| 157 | ||
| 158 |
# catch empty columns in LAMBDA (eg higher order!) |
|
| 159 | ! |
LAMBDA.orig <- LAMBDA |
| 160 | ! |
empty.idx <- which(apply(LAMBDA, 2L, function(x) all(x == 0))) |
| 161 | ! |
if (length(empty.idx) > 0L) {
|
| 162 | ! |
LAMBDA <- LAMBDA.orig[, -empty.idx, drop = FALSE] |
| 163 |
} |
|
| 164 | ||
| 165 | ! |
nvar <- nrow(LAMBDA) |
| 166 | ! |
nfac <- ncol(LAMBDA) |
| 167 | ||
| 168 |
# do we have marker.idx? |
|
| 169 | ! |
if (is.null(marker.idx)) {
|
| 170 |
# 'marker' indicator has a single non-zero element in a row |
|
| 171 | ! |
marker.idx <- lav_utils_get_marker(LAMBDA = LAMBDA, std.lv = TRUE) |
| 172 | ! |
if (any(is.na(marker.idx))) {
|
| 173 | ! |
lav_msg_stop(gettext("no clear markers in LAMBDA matrix"))
|
| 174 |
} |
|
| 175 |
} |
|
| 176 | ||
| 177 |
# std.lv TRUE or FALSE? |
|
| 178 | ! |
if (is.null(std.lv)) {
|
| 179 | ! |
std.lv <- FALSE |
| 180 | ! |
if (any(diag(LAMBDA[marker.idx, , drop = FALSE]) != 1)) {
|
| 181 | ! |
std.lv <- TRUE |
| 182 |
} |
|
| 183 |
} |
|
| 184 | ||
| 185 |
# if std.lv = TRUE, rescale |
|
| 186 | ! |
if (std.lv) {
|
| 187 | ! |
MARKER <- LAMBDA[marker.idx, , drop = FALSE] |
| 188 | ! |
marker.inv <- 1 / diag(MARKER) |
| 189 | ! |
LAMBDA <- t(t(LAMBDA) * marker.inv) |
| 190 |
} |
|
| 191 | ||
| 192 |
# compute 'T' matrix |
|
| 193 | ! |
TMAT <- lav_sam_tmat( |
| 194 | ! |
LAMBDA = LAMBDA, THETA = THETA, |
| 195 | ! |
marker.idx = marker.idx |
| 196 |
) |
|
| 197 | ||
| 198 |
# ML mapping matrix |
|
| 199 | ! |
M <- TMAT[marker.idx, , drop = FALSE] |
| 200 | ||
| 201 | ! |
if (std.lv) {
|
| 202 | ! |
M <- M * marker.inv |
| 203 |
} |
|
| 204 | ||
| 205 |
# empty.idx? |
|
| 206 | ! |
if (length(empty.idx) > 0L) {
|
| 207 | ! |
M.full <- M |
| 208 | ! |
M <- matrix(0, nrow = ncol(LAMBDA.orig), ncol = ncol(M.full)) |
| 209 | ! |
M[-empty.idx, ] <- M.full |
| 210 |
} |
|
| 211 | ||
| 212 | ! |
M |
| 213 |
} |
|
| 214 | ||
| 215 |
# create 'T' matrix (tmat) for T-transformation |
|
| 216 |
# |
|
| 217 |
# Notes: - here we assume that LAMBDA has unity markers (no std.lv = TRUE) |
|
| 218 |
# - TMAT is NOT symmetric! |
|
| 219 |
# - Yc %*% t(TMAT) transforms the data in such a way that we get: |
|
| 220 |
# 1) Bartlett factor scores in the marker columns |
|
| 221 |
# 2) 'V' values in the non-marker columns, where: |
|
| 222 |
# V = Yc - Yc[,marker.idx] %*% t(LAMBDA) |
|
| 223 |
# |
|
| 224 |
lav_sam_tmat <- function(LAMBDA = NULL, |
|
| 225 |
THETA = NULL, |
|
| 226 |
marker.idx = NULL) {
|
|
| 227 | ! |
LAMBDA <- as.matrix.default(LAMBDA) |
| 228 | ! |
nvar <- nrow(LAMBDA) |
| 229 | ! |
nfac <- ncol(LAMBDA) |
| 230 | ||
| 231 |
# do we have marker.idx? |
|
| 232 | ! |
if (is.null(marker.idx)) {
|
| 233 |
# 'marker' indicator has a single 1 element in a row |
|
| 234 | ! |
marker.idx <- lav_utils_get_marker(LAMBDA = LAMBDA, std.lv = FALSE) |
| 235 | ! |
if (any(is.na(marker.idx))) {
|
| 236 | ! |
lav_msg_stop(gettext("no clear markers in LAMBDA matrix"))
|
| 237 |
} |
|
| 238 |
} |
|
| 239 | ||
| 240 |
# construct 'C' matrix |
|
| 241 | ! |
C2 <- diag(nvar) |
| 242 | ! |
C2[, marker.idx] <- -1 * LAMBDA |
| 243 | ! |
C <- C2[-marker.idx, , drop = FALSE] |
| 244 | ||
| 245 |
# compute Sigma.ve and Sigma.vv |
|
| 246 | ! |
Sigma.ve <- C %*% THETA |
| 247 |
# Sigma.vv <- C %*% THETA %*% t(C) |
|
| 248 | ! |
Sigma.vv <- Sigma.ve %*% t(C) |
| 249 | ||
| 250 |
# construct 'Gamma' (and Gamma2) matrix |
|
| 251 |
# Gamma <- (t(Sigma.ve) %*% solve(Sigma.vv))[marker.idx,, drop = FALSE] |
|
| 252 | ! |
Gamma <- try(t(solve(Sigma.vv, Sigma.ve)[, marker.idx, drop = FALSE]), |
| 253 | ! |
silent = TRUE |
| 254 |
) |
|
| 255 | ! |
if (inherits(Gamma, "try-error")) {
|
| 256 | ! |
tmp <- t(Sigma.ve) %*% MASS::ginv(Sigma.vv) |
| 257 | ! |
Gamma <- tmp[marker.idx, , drop = FALSE] |
| 258 |
} |
|
| 259 | ! |
Gamma2 <- matrix(0, nfac, nvar) |
| 260 | ! |
Gamma2[, -marker.idx] <- Gamma |
| 261 | ! |
Gamma2[, marker.idx] <- diag(nfac) |
| 262 | ||
| 263 |
# transformation matrix 'T' (we call it here 'Tmat') |
|
| 264 | ! |
Tmat <- matrix(0, nvar, nvar) |
| 265 | ! |
Tmat[-marker.idx, ] <- C |
| 266 | ! |
Tmat[marker.idx, ] <- -Gamma2 %*% C2 |
| 267 | ||
| 268 | ! |
Tmat |
| 269 |
} |
|
| 270 | ||
| 271 | ||
| 272 |
# compute VETA |
|
| 273 |
# - if alpha.correction == 0 -> same as local SAM (or MOC) |
|
| 274 |
# - if alpha.correction == (N-1) -> same as FSR+Bartlett |
|
| 275 |
lav_sam_veta <- function(M = NULL, S = NULL, THETA = NULL, |
|
| 276 |
alpha.correction = 0L, lambda.correction = TRUE, |
|
| 277 |
N = 20L, dummy.lv.idx = integer(0L), extra = FALSE) {
|
|
| 278 | ||
| 279 |
# catch empty rows in M (higher-order?) |
|
| 280 | ! |
M.orig <- M |
| 281 | ! |
empty.idx <- which(apply(M.orig, 1L, function(x) all(x == 0))) |
| 282 | ! |
if (length(empty.idx) > 0L) {
|
| 283 | ! |
M <- M.orig[-empty.idx,, drop = FALSE] |
| 284 |
} |
|
| 285 | ||
| 286 |
# MSM |
|
| 287 | ! |
MSM <- M %*% S %*% t(M) |
| 288 | ||
| 289 |
# MTM |
|
| 290 | ! |
MTM <- M %*% THETA %*% t(M) |
| 291 | ||
| 292 |
# empty theta elements? |
|
| 293 | ! |
empty.theta.idx <- which(diag(MTM) == 0) |
| 294 | ||
| 295 |
# new in 0.6-16: make sure MTM is pd |
|
| 296 |
# (otherwise lav_matrix_symmetric_diff_smallest_root will fail) |
|
| 297 | ! |
theta.rm.idx <- unique(c(dummy.lv.idx, empty.theta.idx)) |
| 298 | ! |
if (length(theta.rm.idx) == nrow(MTM)) {
|
| 299 |
# all zero? |
|
| 300 |
# do nothing, but certainly no need for alpha or lambda.correction |
|
| 301 | ! |
alpha.correction = 0L |
| 302 | ! |
lambda.correction = FALSE |
| 303 | ! |
} else if (length(theta.rm.idx) > 0L) {
|
| 304 | ! |
MTM.small <- MTM[-theta.rm.idx, -theta.rm.idx, drop = FALSE] |
| 305 | ! |
MTM.small <- zapsmall(lav_matrix_symmetric_force_pd( |
| 306 | ! |
MTM.small, |
| 307 | ! |
tol = 1e-04 |
| 308 |
)) |
|
| 309 | ! |
MTM[-theta.rm.idx, -theta.rm.idx] <- MTM.small |
| 310 |
} else {
|
|
| 311 | ! |
MTM <- zapsmall(lav_matrix_symmetric_force_pd(MTM, tol = 1e-04)) |
| 312 |
} |
|
| 313 | ||
| 314 |
# apply small sample correction (if requested) |
|
| 315 | ! |
if (alpha.correction > 0) {
|
| 316 | ! |
alpha.N1 <- alpha.correction / (N - 1) |
| 317 | ! |
if (alpha.N1 > 1.0) {
|
| 318 | ! |
alpha.N1 <- 1.0 |
| 319 | ! |
} else if (alpha.N1 < 0.0) {
|
| 320 | ! |
alpha.N1 <- 0.0 |
| 321 |
} |
|
| 322 | ! |
MTM <- (1 - alpha.N1) * MTM |
| 323 | ! |
alpha <- alpha.correction |
| 324 |
} else {
|
|
| 325 | ! |
alpha <- alpha.correction |
| 326 |
} |
|
| 327 | ||
| 328 | ! |
lambda <- lambda.star <- +Inf |
| 329 | ! |
if (lambda.correction) {
|
| 330 |
# use Fuller (1987) approach to ensure VETA is positive |
|
| 331 | ! |
lambda <- try(lav_matrix_symmetric_diff_smallest_root(MSM, MTM), |
| 332 | ! |
silent = TRUE |
| 333 |
) |
|
| 334 | ! |
if (inherits(lambda, "try-error")) {
|
| 335 | ! |
lav_msg_warn(gettext("failed to compute lambda"))
|
| 336 | ! |
VETA <- MSM - MTM # and hope for the best |
| 337 |
} else {
|
|
| 338 | ! |
cutoff <- 1 + 1 / (N - 1) |
| 339 | ! |
if (lambda < cutoff) {
|
| 340 | ! |
lambda.star <- lambda - 1 / (N - 1) |
| 341 | ! |
VETA <- MSM - lambda.star * MTM |
| 342 |
} else {
|
|
| 343 | ! |
VETA <- MSM - MTM |
| 344 |
} |
|
| 345 |
} |
|
| 346 |
} else {
|
|
| 347 | ! |
VETA <- MSM - MTM |
| 348 |
} |
|
| 349 | ||
| 350 |
# empty.idx? |
|
| 351 | ! |
if (length(empty.idx) > 0L) {
|
| 352 | ! |
MSM.full <- MSM |
| 353 | ! |
MTM.full <- MTM |
| 354 | ! |
VETA.full <- VETA |
| 355 | ! |
nfac.orig <- nrow(M.orig) |
| 356 | ||
| 357 | ! |
MSM <- MTM <- VETA <- matrix(0, nrow = nfac.orig, ncol = nfac.orig) |
| 358 | ! |
MSM[ -empty.idx, -empty.idx] <- MSM.full |
| 359 | ! |
MTM[ -empty.idx, -empty.idx] <- MTM.full |
| 360 | ! |
VETA[-empty.idx, -empty.idx] <- VETA.full |
| 361 |
} |
|
| 362 | ||
| 363 |
# extra attributes? |
|
| 364 | ! |
if (extra) {
|
| 365 | ! |
attr(VETA, "lambda") <- lambda |
| 366 | ! |
attr(VETA, "alpha") <- alpha |
| 367 | ! |
attr(VETA, "lambda.star") <- lambda.star |
| 368 | ! |
attr(VETA, "MSM") <- MSM |
| 369 | ! |
attr(VETA, "MTM") <- MTM |
| 370 |
} |
|
| 371 | ||
| 372 | ! |
VETA |
| 373 |
} |
|
| 374 | ||
| 375 |
# compute EETA = E(Eta) = M %*% [YBAR - NU] |
|
| 376 |
lav_sam_eeta <- function(M = NULL, YBAR = NULL, NU = NULL) {
|
|
| 377 | ! |
EETA <- M %*% (YBAR - NU) |
| 378 | ! |
EETA |
| 379 |
} |
|
| 380 | ||
| 381 |
# compute veta including quadratic/interaction terms |
|
| 382 |
lav_sam_veta2 <- function(FS = NULL, M = NULL, |
|
| 383 |
VETA = NULL, EETA = NULL, THETA = NULL, |
|
| 384 |
lv.names = NULL, |
|
| 385 |
lv.int.names = NULL, |
|
| 386 |
dummy.lv.names = character(0L), |
|
| 387 |
alpha.correction = 0L, |
|
| 388 |
lambda.correction = TRUE, |
|
| 389 |
fs.outlier.idx = integer(0L), |
|
| 390 |
return.FS = FALSE, |
|
| 391 |
return.cov.iveta2 = TRUE, |
|
| 392 |
extra = FALSE) {
|
|
| 393 | ||
| 394 |
# small utility function: var() divided by N |
|
| 395 | ! |
varn <- function(x, N) {
|
| 396 | ! |
var(x, use = "pairwise.complete.obs") * (N - 1) / N |
| 397 |
} |
|
| 398 | ||
| 399 | ! |
if (length(lv.int.names) == 0L) {
|
| 400 | ! |
lav_msg_stop(gettext("lv.int.names is empty: no lv quadratic/interaction
|
| 401 | ! |
terms are provided")) |
| 402 |
} |
|
| 403 | ||
| 404 | ! |
if (is.null(lv.names)) {
|
| 405 | ! |
lv.names <- paste("eta", seq_len(ncol(FS)), sep = "")
|
| 406 |
} |
|
| 407 | ||
| 408 |
# MTM |
|
| 409 | ! |
MTM <- M %*% THETA %*% t(M) |
| 410 | ||
| 411 |
# new in 0.6-16: make sure MTM is pd |
|
| 412 |
# (otherwise lav_matrix_symmetric_diff_smallest_root will fail) |
|
| 413 | ! |
dummy.lv.idx <- which(lv.names %in% dummy.lv.names) |
| 414 | ! |
if (length(dummy.lv.idx) > 0L) {
|
| 415 | ! |
MTM.nodummy <- MTM[-dummy.lv.idx, -dummy.lv.idx, drop = FALSE] |
| 416 | ! |
MTM.nodummy <- zapsmall(lav_matrix_symmetric_force_pd( |
| 417 | ! |
MTM.nodummy, |
| 418 | ! |
tol = 1e-04 |
| 419 |
)) |
|
| 420 | ! |
MTM[-dummy.lv.idx, -dummy.lv.idx] <- MTM.nodummy |
| 421 |
} else {
|
|
| 422 | ! |
MTM <- zapsmall(lav_matrix_symmetric_force_pd(MTM, tol = 1e-04)) |
| 423 |
} |
|
| 424 | ||
| 425 |
# augment to include intercept |
|
| 426 | ! |
FS <- cbind(1, FS) |
| 427 | ! |
N <- nrow(FS) |
| 428 | ! |
MTM <- lav_matrix_bdiag(0, MTM) |
| 429 | ! |
VETA <- lav_matrix_bdiag(0, VETA) |
| 430 | ! |
EETA <- c(1, EETA) |
| 431 | ! |
lv.names <- c("..int..", lv.names)
|
| 432 | ! |
nfac <- ncol(FS) |
| 433 | ||
| 434 | ! |
idx1 <- rep(seq_len(nfac), each = nfac) |
| 435 | ! |
idx2 <- rep(seq_len(nfac), times = nfac) |
| 436 | ||
| 437 | ! |
NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":") |
| 438 | ! |
NAMES[seq_len(nfac)] <- lv.names |
| 439 | ||
| 440 | ! |
FS2 <- FS[, idx1] * FS[, idx2] |
| 441 | ||
| 442 | ! |
K.nfac <- lav_matrix_commutation(nfac, nfac) |
| 443 | ! |
IK <- diag(nfac * nfac) + K.nfac |
| 444 | ||
| 445 | ! |
EETA <- as.matrix(drop(EETA)) |
| 446 | ! |
VETAkMTM <- VETA %x% MTM |
| 447 | ||
| 448 |
# normal version (for now): |
|
| 449 | ! |
Gamma.ME22 <- IK %*% (MTM %x% MTM) |
| 450 | ||
| 451 |
# ingredients (normal ME case) |
|
| 452 | ! |
Var.FS2 <- varn(FS2, N) |
| 453 | ! |
Var.ETAkME <- (tcrossprod(EETA) %x% MTM + VETAkMTM) |
| 454 | ! |
Var.MEkETA <- lav_matrix_commutation_pre_post(Var.ETAkME) |
| 455 | ! |
Var.ME2 <- Gamma.ME22 |
| 456 | ||
| 457 | ! |
cov.ETAkME.MEkETA <- lav_matrix_commutation_post(Var.ETAkME) |
| 458 | ! |
cov.MEkETA.ETAkME <- t(cov.ETAkME.MEkETA) |
| 459 | ||
| 460 | ! |
Var.ERROR <- (Var.ETAkME + Var.MEkETA + cov.ETAkME.MEkETA |
| 461 | ! |
+ cov.MEkETA.ETAkME + Var.ME2) |
| 462 | ||
| 463 |
# select only what we need |
|
| 464 | ! |
colnames(Var.FS2) <- rownames(Var.FS2) <- NAMES |
| 465 | ! |
colnames(Var.ERROR) <- rownames(Var.ERROR) <- NAMES |
| 466 | ! |
colnames(FS2) <- NAMES |
| 467 | ! |
lv.keep <- c(lv.names[-1], lv.int.names) |
| 468 | ! |
Var.FS2 <- Var.FS2[lv.keep, lv.keep] |
| 469 | ! |
Var.ERROR <- Var.ERROR[lv.keep, lv.keep] |
| 470 | ! |
FS.mean <- colMeans(FS2, na.rm = TRUE) |
| 471 | ! |
names(FS.mean) <- NAMES |
| 472 | ! |
FS2.mean <- FS.mean # all of them |
| 473 | ! |
FS.mean <- FS.mean[lv.keep] |
| 474 | ||
| 475 |
# compute Gamma for FS2[,lv.keep] |
|
| 476 |
#FS.gamma <- lav_samplestats_Gamma(FS2[,lv.keep, drop = FALSE], |
|
| 477 |
# meanstructure = TRUE) |
|
| 478 | ||
| 479 |
# apply small sample correction (if requested) |
|
| 480 | ! |
if (alpha.correction > 0) {
|
| 481 | ! |
alpha.N1 <- alpha.correction / (N - 1) |
| 482 | ! |
if (alpha.N1 > 1.0) {
|
| 483 | ! |
alpha.N1 <- 1.0 |
| 484 | ! |
} else if (alpha.N1 < 0.0) {
|
| 485 | ! |
alpha.N1 <- 0.0 |
| 486 |
} |
|
| 487 | ! |
Var.ERROR <- (1 - alpha.N1) * Var.ERROR |
| 488 | ! |
alpha <- alpha.correction |
| 489 |
} else {
|
|
| 490 | ! |
alpha <- alpha.correction |
| 491 |
} |
|
| 492 | ||
| 493 | ! |
lambda <- +Inf |
| 494 | ! |
lambda.star <- 1 |
| 495 | ! |
if (lambda.correction) {
|
| 496 |
# use Fuller (1987) approach to ensure VETA2 is positive |
|
| 497 | ! |
lambda <- try(lav_matrix_symmetric_diff_smallest_root( |
| 498 | ! |
Var.FS2, |
| 499 | ! |
Var.ERROR |
| 500 | ! |
), silent = TRUE) |
| 501 | ! |
if (inherits(lambda, "try-error")) {
|
| 502 | ! |
lav_msg_warn(gettext("failed to compute lambda"))
|
| 503 | ! |
VETA2 <- Var.FS2 - Var.ERROR # and hope for the best |
| 504 |
} else {
|
|
| 505 |
#cutoff <- 1 + 1 / (N - 1) |
|
| 506 | ! |
cutoff <- 1 + 2/N # be more conservative for VETA2 |
| 507 | ! |
if (lambda < cutoff) {
|
| 508 |
#lambda.star <- lambda - 1 / (N - 1) |
|
| 509 | ! |
lambda.star <- max(c(0, lambda - ncol(Var.FS2)/(N - 1))) |
| 510 | ! |
VETA2 <- Var.FS2 - lambda.star * Var.ERROR |
| 511 |
} else {
|
|
| 512 | ! |
VETA2 <- Var.FS2 - Var.ERROR |
| 513 |
} |
|
| 514 |
} |
|
| 515 |
} else {
|
|
| 516 | ! |
VETA2 <- Var.FS2 - Var.ERROR |
| 517 |
} |
|
| 518 | ||
| 519 |
# new in 0.6-20: to compute Gamma.eta |
|
| 520 | ! |
if (return.cov.iveta2) {
|
| 521 | ! |
IVETA2 <- matrix(0, N, ncol = length(lav_matrix_vech(VETA2)) + ncol(VETA2)) |
| 522 | ! |
EF <- colMeans(FS) |
| 523 | ! |
for(i in 1:N) {
|
| 524 | ! |
fi <- as.matrix(FS2[i,seq_len(nfac)]) |
| 525 | ! |
tmp <- ( ((tcrossprod(fi) - MTM) %x% MTM) + |
| 526 | ! |
(MTM %x% (tcrossprod(fi) - MTM)) + |
| 527 | ! |
lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM) + |
| 528 | ! |
lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM) + |
| 529 | ! |
(IK %*% (MTM %x% MTM)) ) |
| 530 | ! |
iveta2 <- tcrossprod(FS2[i,] - FS2.mean) - lambda.star * tmp |
| 531 | ! |
colnames(iveta2) <- rownames(iveta2) <- NAMES |
| 532 | ||
| 533 | ! |
ieeta2 <- ( lav_matrix_vec(tcrossprod(fi)) - |
| 534 | ! |
lav_matrix_vec(tcrossprod(EF)) + |
| 535 | ! |
(EF %x% EF) - |
| 536 | ! |
lambda.star * lav_matrix_vec(MTM) ) |
| 537 | ! |
names(ieeta2) <- NAMES |
| 538 | ||
| 539 | ! |
IVETA2[i,] <- c(ieeta2[lv.keep], |
| 540 | ! |
lav_matrix_vech(iveta2[lv.keep, lv.keep])) |
| 541 |
} # N |
|
| 542 |
# experimental: |
|
| 543 |
# remove outliers in FS? |
|
| 544 |
#if (length(fs.outlier.idx) > 0L) {
|
|
| 545 |
# IVETA2 <- IVETA2[-fs.outlier.idx, ,drop = FALSE] |
|
| 546 |
# N <- N - length(fs.outlier.idx) |
|
| 547 |
#} |
|
| 548 | ! |
cov.iveta2 <- cov(IVETA2) * (N-1)/N |
| 549 |
} |
|
| 550 | ||
| 551 |
# extra attributes? |
|
| 552 | ! |
if (extra) {
|
| 553 | ! |
attr(VETA2, "lambda") <- lambda |
| 554 | ! |
attr(VETA2, "alpha") <- alpha |
| 555 | ! |
attr(VETA2, "lambda.star") <- lambda.star |
| 556 | ! |
attr(VETA2, "MSM") <- Var.FS2 |
| 557 | ! |
attr(VETA2, "MTM") <- Var.ERROR |
| 558 | ! |
attr(VETA2, "FS.mean") <- FS.mean |
| 559 |
#attr(VETA2, "FS.gamma") <- FS.gamma |
|
| 560 |
} |
|
| 561 | ! |
if (return.FS) {
|
| 562 | ! |
attr(VETA2, "FS") <- FS2[, lv.keep, drop = FALSE] |
| 563 |
} |
|
| 564 | ! |
if (return.cov.iveta2) {
|
| 565 | ! |
attr(VETA2, "cov.iveta2") <- cov.iveta2 |
| 566 |
} |
|
| 567 | ||
| 568 | ! |
VETA2 |
| 569 |
} |
|
| 570 | ||
| 571 |
lav_sam_eeta2 <- function(EETA = NULL, VETA = NULL, lv.names = NULL, |
|
| 572 |
lv.int.names = NULL) {
|
|
| 573 | ! |
if (length(lv.int.names) == 0L) {
|
| 574 | ! |
lav_msg_stop(gettext("lv.int.names is empty: no lv quadratic/interaction
|
| 575 | ! |
terms are provided")) |
| 576 |
} |
|
| 577 | ||
| 578 | ! |
if (is.null(lv.names)) {
|
| 579 | ! |
lv.names <- paste("eta", seq_len(ncol(VETA)), sep = "")
|
| 580 |
} |
|
| 581 | ||
| 582 | ! |
nfac <- nrow(VETA) |
| 583 | ! |
idx1 <- rep(seq_len(nfac), each = nfac) |
| 584 | ! |
idx2 <- rep(seq_len(nfac), times = nfac) |
| 585 | ! |
NAMES <- c(lv.names, paste(lv.names[idx1], lv.names[idx2], sep = ":")) |
| 586 | ||
| 587 |
# E(\eta %x% \eta) |
|
| 588 | ! |
EETA2 <- lav_matrix_vec(VETA) + EETA %x% EETA |
| 589 | ||
| 590 |
# add 1st order |
|
| 591 | ! |
EETA2.aug <- c(EETA, EETA2) |
| 592 | ||
| 593 |
# select only what we need |
|
| 594 | ! |
names(EETA2.aug) <- NAMES |
| 595 | ! |
lv.keep <- c(lv.names, lv.int.names) |
| 596 | ! |
EETA2.aug <- EETA2.aug[lv.keep] |
| 597 | ||
| 598 | ! |
EETA2.aug |
| 599 |
} |
|
| 600 | ||
| 601 |
# compute var(fs2) including quadratic/interaction terms |
|
| 602 |
lav_sam_fs2 <- function(FS = NULL, lv.names = NULL, lv.int.names = NULL) {
|
|
| 603 | ! |
varn <- function(x, N) {
|
| 604 | ! |
var(x) * (N - 1) / N |
| 605 |
} |
|
| 606 | ||
| 607 | ! |
if (length(lv.int.names) == 0L) {
|
| 608 | ! |
lav_msg_stop(gettext("lv.int.names is empty: no lv quadratic/interaction
|
| 609 | ! |
terms are provided")) |
| 610 |
} |
|
| 611 | ||
| 612 | ! |
if (is.null(lv.names)) {
|
| 613 | ! |
lv.names <- paste("eta", seq_len(ncol(FS)), sep = "")
|
| 614 |
} |
|
| 615 | ||
| 616 |
# augment to include intercept |
|
| 617 | ! |
FS <- cbind(1, FS) |
| 618 | ! |
N <- nrow(FS) |
| 619 | ! |
lv.names <- c("..int..", lv.names)
|
| 620 | ! |
nfac <- ncol(FS) |
| 621 | ||
| 622 | ! |
idx1 <- rep(seq_len(nfac), each = nfac) |
| 623 | ! |
idx2 <- rep(seq_len(nfac), times = nfac) |
| 624 | ||
| 625 | ! |
NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":") |
| 626 | ||
| 627 | ! |
FS2 <- FS[, idx1] * FS[, idx2] |
| 628 | ! |
Var.FS2 <- varn(FS2, N) |
| 629 | ||
| 630 |
# select only what we need |
|
| 631 | ! |
colnames(Var.FS2) <- rownames(Var.FS2) <- NAMES |
| 632 | ! |
lv.main <- paste(lv.names[-1], "..int..", sep = ":") |
| 633 | ! |
lv.keep <- c(lv.main, lv.int.names) |
| 634 | ! |
Var.FS2 <- Var.FS2[lv.keep, lv.keep] |
| 635 | ||
| 636 | ! |
Var.FS2 |
| 637 |
} |
|
| 638 | ||
| 639 |
# create consistent lavaan object, based on (filled in) PT |
|
| 640 |
lav_sam_step3_joint <- function(FIT = NULL, PT = NULL, sam.method = "local") {
|
|
| 641 | ! |
lavoptions <- FIT@Options |
| 642 | ||
| 643 | ! |
lavoptions.joint <- lavoptions |
| 644 | ! |
lavoptions.joint$optim.method <- "none" |
| 645 | ! |
lavoptions.joint$optim.parscale <- "none" |
| 646 | ! |
lavoptions.joint$start <- "default" |
| 647 | ! |
lavoptions.joint$optim.force.converged <- TRUE |
| 648 | ! |
lavoptions.joint$check.gradient <- FALSE |
| 649 | ! |
lavoptions.joint$check.start <- FALSE |
| 650 | ! |
lavoptions.joint$check.post <- FALSE |
| 651 | ! |
lavoptions.joint$rotation <- "none" |
| 652 | ! |
lavoptions.joint$se <- "none" |
| 653 | ! |
lavoptions.joint$store.vcov <- FALSE # we do this manually |
| 654 | ||
| 655 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 656 | ! |
lavoptions.joint$baseline <- FALSE |
| 657 | ! |
lavoptions.joint$sample.icov <- FALSE |
| 658 |
#lavoptions.joint$h1 <- TRUE # we need this if we re-use the sam object |
|
| 659 | ! |
lavoptions.joint$test <- "none" |
| 660 | ! |
lavoptions.joint$estimator <- "none" |
| 661 |
} else {
|
|
| 662 | ! |
lavoptions.joint$test <- lavoptions$test |
| 663 | ! |
lavoptions.joint$estimator <- lavoptions$estimator |
| 664 |
} |
|
| 665 | ||
| 666 |
# set ustart values |
|
| 667 | ! |
PT$ustart <- PT$est # as this is used if optim.method == "none" |
| 668 | ||
| 669 | ! |
JOINT <- lavaan::lavaan(PT, |
| 670 | ! |
slotOptions = lavoptions.joint, |
| 671 | ! |
slotSampleStats = FIT@SampleStats, |
| 672 | ! |
slotData = FIT@Data, |
| 673 | ! |
verbose = FALSE |
| 674 |
) |
|
| 675 | ! |
JOINT |
| 676 |
} |
|
| 677 | ||
| 678 |
lav_sam_table <- function(JOINT = NULL, STEP1 = NULL, FIT.PA = NULL, |
|
| 679 |
cmd = NULL, lavoptions = NULL, |
|
| 680 |
mm.args = list(), struc.args = list(), |
|
| 681 |
sam.method = "local", |
|
| 682 |
local.options = list(), global.options = list()) {
|
|
| 683 | ! |
MM.FIT <- STEP1$MM.FIT |
| 684 | ||
| 685 | ! |
sam.mm.table <- data.frame( |
| 686 | ! |
Block = seq_len(length(STEP1$mm.list)), |
| 687 | ! |
Latent = sapply(MM.FIT, function(x) {
|
| 688 | ! |
paste(unique(unlist(x@pta$vnames$lv)), collapse = ",") |
| 689 |
}), |
|
| 690 | ! |
Nind = sapply(MM.FIT, function(x) {
|
| 691 | ! |
length(unique(unlist(x@pta$vnames$ov))) |
| 692 |
}), |
|
| 693 |
# Estimator = sapply(MM.FIT, function(x) { x@Model@estimator} ),
|
|
| 694 | ! |
Chisq = sapply(MM.FIT, function(x) {
|
| 695 | ! |
x@test[[1]]$stat |
| 696 |
}), |
|
| 697 | ! |
Df = sapply(MM.FIT, function(x) {
|
| 698 | ! |
x@test[[1]]$df |
| 699 |
}) |
|
| 700 |
) |
|
| 701 |
# pvalue = sapply(MM.FIT, function(x) {x@test[[1]]$pvalue}) )
|
|
| 702 | ! |
class(sam.mm.table) <- c("lavaan.data.frame", "data.frame")
|
| 703 | ||
| 704 | ||
| 705 |
# extra info for @internal slot |
|
| 706 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 707 | ! |
sam.struc.fit <- try( |
| 708 | ! |
fitMeasures( |
| 709 | ! |
FIT.PA, |
| 710 | ! |
c( |
| 711 | ! |
"chisq", "df", # "pvalue", |
| 712 | ! |
"cfi", "rmsea", "srmr" |
| 713 |
) |
|
| 714 |
), |
|
| 715 | ! |
silent = TRUE |
| 716 |
) |
|
| 717 | ! |
if (inherits(sam.struc.fit, "try-error")) {
|
| 718 | ! |
sam.struc.fit <- "(unable to obtain fit measures)" |
| 719 | ! |
names(sam.struc.fit) <- "warning" |
| 720 |
} |
|
| 721 | ! |
sam.mm.rel <- STEP1$REL |
| 722 |
} else {
|
|
| 723 | ! |
sam.struc.fit <- "no local fit measures available for structural part if sam.method is global" |
| 724 | ! |
names(sam.struc.fit) <- "warning" |
| 725 | ! |
sam.mm.rel <- numeric(0L) |
| 726 |
} |
|
| 727 | ||
| 728 | ||
| 729 | ! |
SAM <- list( |
| 730 | ! |
sam.cmd = cmd, |
| 731 | ! |
sam.method = sam.method, |
| 732 | ! |
sam.local.options = local.options, |
| 733 | ! |
sam.global.options = global.options, |
| 734 | ! |
sam.mm.list = STEP1$mm.list, |
| 735 | ! |
sam.mm.estimator = MM.FIT[[1]]@Model@estimator, |
| 736 | ! |
sam.mm.args = mm.args, |
| 737 | ! |
sam.mm.ov.names = lapply(MM.FIT, function(x) {
|
| 738 | ! |
x@pta$vnames$ov |
| 739 |
}), |
|
| 740 | ! |
sam.mm.table = sam.mm.table, |
| 741 | ! |
sam.mm.rel = sam.mm.rel, |
| 742 | ! |
sam.struc.estimator = FIT.PA@Model@estimator, |
| 743 | ! |
sam.struc.args = struc.args, |
| 744 | ! |
sam.struc.fit = sam.struc.fit, |
| 745 | ! |
sam.lavoptions = lavoptions |
| 746 |
) |
|
| 747 | ! |
SAM |
| 748 |
} |
|
| 749 | ||
| 750 |
lav_sam_get_cov_ybar <- function(FIT = NULL, local.options = list( |
|
| 751 |
M.method = "ML", |
|
| 752 |
lambda.correction = TRUE, |
|
| 753 |
alpha.correction = 0L, |
|
| 754 |
twolevel.method = "h1" |
|
| 755 |
)) {
|
|
| 756 | ||
| 757 |
# local.twolevel.method |
|
| 758 | ! |
local.twolevel.method <- tolower(local.options[["twolevel.method"]]) |
| 759 | ! |
if (!local.twolevel.method %in% c("h1", "anova", "mean")) {
|
| 760 | ! |
lav_msg_stop(gettext( |
| 761 | ! |
"local option twolevel.method should be one of h1, anova or mean.")) |
| 762 |
} |
|
| 763 | ||
| 764 | ! |
local.M.method <- toupper(local.options[["M.method"]]) |
| 765 | ||
| 766 | ! |
lavpta <- FIT@pta |
| 767 | ! |
ngroups <- lavpta$ngroups |
| 768 | ! |
nlevels <- lavpta$nlevels |
| 769 | ! |
nblocks <- lavpta$nblocks |
| 770 | ||
| 771 |
# do we need H1? |
|
| 772 | ! |
if (nlevels > 1L && local.twolevel.method == "h1") {
|
| 773 | ! |
H1 <- lav_h1_implied_logl( |
| 774 | ! |
lavdata = FIT@Data, |
| 775 | ! |
lavsamplestats = FIT@SampleStats, |
| 776 | ! |
lavoptions = FIT@Options |
| 777 |
) |
|
| 778 | ! |
h1implied <- H1$implied |
| 779 |
} else {
|
|
| 780 | ! |
h1implied <- FIT@h1$implied |
| 781 |
# if (FIT@Options$conditional.x) {
|
|
| 782 |
# h1implied <- lav_model_implied_cond2uncond(h1implied) |
|
| 783 |
# } |
|
| 784 |
} |
|
| 785 | ||
| 786 |
# containers |
|
| 787 | ! |
COV.list <- vector("list", nblocks)
|
| 788 | ! |
YBAR.list <- vector("list", nblocks)
|
| 789 | ||
| 790 |
# label |
|
| 791 | ! |
if (nblocks > 1L) {
|
| 792 | ! |
names(COV.list) <- FIT@Data@block.label |
| 793 | ! |
names(YBAR.list) <- FIT@Data@block.label |
| 794 |
} |
|
| 795 | ||
| 796 |
# collect COV/YBAR per block |
|
| 797 | ! |
for (b in seq_len(nblocks)) {
|
| 798 | ||
| 799 |
# get sample statistics for this block |
|
| 800 | ! |
if (nlevels > 1L) {
|
| 801 | ! |
if (ngroups > 1L) {
|
| 802 | ! |
this.level <- (b - 1L) %% ngroups + 1L |
| 803 |
} else {
|
|
| 804 | ! |
this.level <- b |
| 805 |
} |
|
| 806 | ! |
this.group <- floor(b / nlevels + 0.5) |
| 807 | ||
| 808 | ! |
if (this.level == 1L) {
|
| 809 | ! |
if (local.twolevel.method == "h1") {
|
| 810 | ! |
COV <- h1implied$cov[[1]] |
| 811 | ! |
YBAR <- h1implied$mean[[1]] |
| 812 | ! |
} else if (local.twolevel.method == "anova" || |
| 813 | ! |
local.twolevel.method == "mean") {
|
| 814 | ! |
COV <- FIT@SampleStats@YLp[[this.group]][[2]]$Sigma.W |
| 815 | ! |
YBAR <- FIT@SampleStats@YLp[[this.group]][[2]]$Mu.W |
| 816 |
} |
|
| 817 | ||
| 818 |
# reduce |
|
| 819 | ! |
ov.idx <- FIT@Data@Lp[[this.group]]$ov.idx[[this.level]] |
| 820 | ! |
COV <- COV[ov.idx, ov.idx, drop = FALSE] |
| 821 | ! |
YBAR <- YBAR[ov.idx] |
| 822 | ! |
} else if (this.level == 2L) {
|
| 823 | ! |
if (local.twolevel.method == "h1") {
|
| 824 | ! |
COV <- h1implied$cov[[2]] |
| 825 | ! |
YBAR <- h1implied$mean[[2]] |
| 826 | ! |
} else if (local.twolevel.method == "anova") {
|
| 827 | ! |
COV <- FIT@SampleStats@YLp[[this.group]][[2]]$Sigma.B |
| 828 | ! |
YBAR <- FIT@SampleStats@YLp[[this.group]][[2]]$Mu.B |
| 829 | ! |
} else if (local.twolevel.method == "mean") {
|
| 830 | ! |
S.PW <- FIT@SampleStats@YLp[[this.group]][[2]]$Sigma.W |
| 831 | ! |
NJ <- FIT@SampleStats@YLp[[this.group]][[2]]$s |
| 832 | ! |
Y2 <- FIT@SampleStats@YLp[[this.group]][[2]]$Y2 |
| 833 |
# grand mean |
|
| 834 | ! |
MU.Y <- (FIT@SampleStats@YLp[[this.group]][[2]]$Mu.W + FIT@SampleStats@YLp[[this.group]][[2]]$Mu.B) |
| 835 | ! |
Y2c <- t(t(Y2) - MU.Y) # MUST be centered |
| 836 | ! |
YB <- crossprod(Y2c) / nrow(Y2c) |
| 837 | ! |
COV <- YB - 1 / NJ * S.PW |
| 838 | ! |
YBAR <- FIT@SampleStats@YLp[[this.group]][[2]]$Mu.B |
| 839 |
} |
|
| 840 | ||
| 841 |
# reduce |
|
| 842 | ! |
ov.idx <- FIT@Data@Lp[[this.group]]$ov.idx[[this.level]] |
| 843 | ! |
COV <- COV[ov.idx, ov.idx, drop = FALSE] |
| 844 | ! |
YBAR <- YBAR[ov.idx] |
| 845 |
} else {
|
|
| 846 | ! |
lav_msg_stop(gettext("level 3 not supported (yet)."))
|
| 847 |
} |
|
| 848 | ||
| 849 |
# single level |
|
| 850 |
} else {
|
|
| 851 | ! |
this.group <- b |
| 852 | ! |
if (FIT@Model@conditional.x) {
|
| 853 | ! |
YBAR <- h1implied$res.int[[b]] |
| 854 | ! |
COV <- h1implied$res.cov[[b]] |
| 855 |
} else {
|
|
| 856 | ! |
YBAR <- h1implied$mean[[b]] # EM version if missing="ml" |
| 857 | ! |
COV <- h1implied$cov[[b]] |
| 858 |
} |
|
| 859 |
} # single level |
|
| 860 | ||
| 861 | ! |
COV.list[[b]] <- COV |
| 862 | ! |
YBAR.list[[b]] <- YBAR |
| 863 |
} |
|
| 864 | ||
| 865 | ! |
list(COV = COV.list, YBAR = YBAR.list) |
| 866 |
} |
|
| 867 | ||
| 868 |
# automatically generate mm.list; we create measurement blocks so that: |
|
| 869 |
# - unlinked factors become a singleton |
|
| 870 |
# - linked factor are joined into a single measurement block |
|
| 871 |
# based: cross-loadings, or correlated residuals between item errors |
|
| 872 |
lav_sam_get_mmlist <- function(lavobject) {
|
|
| 873 | ||
| 874 | ! |
lavmodel <- lavobject@Model |
| 875 | ! |
lavpta <- lavobject@pta |
| 876 | ! |
nblocks <- lavpta$nblocks |
| 877 | ||
| 878 |
# flags |
|
| 879 | ! |
lv.interaction.flag <- FALSE |
| 880 | ! |
lv.higherorder.flag <- FALSE |
| 881 | ! |
if (length(unlist(lavpta$vnames$lv.interaction)) > 0L) {
|
| 882 | ! |
lv.interaction.flag <- TRUE |
| 883 |
} |
|
| 884 | ! |
if (length(unlist(lavpta$vnames$lv.ind)) > 0L) {
|
| 885 | ! |
lv.higherorder.flag <- TRUE |
| 886 |
} |
|
| 887 | ||
| 888 | ! |
lambda.idx <- which(names(lavmodel@GLIST) == "lambda") |
| 889 | ||
| 890 | ! |
mm.list <- vector("list", length = nblocks)
|
| 891 | ||
| 892 | ! |
GLIST <- lavTech(lavobject, "partable") |
| 893 | ! |
for (b in seq_len(nblocks)) {
|
| 894 | ! |
mm.in.block <- (seq_len(lavmodel@nmat[b]) + |
| 895 | ! |
cumsum(c(0, lavmodel@nmat))[b]) |
| 896 | ! |
MLIST <- GLIST[mm.in.block] |
| 897 | ! |
CC <- t(MLIST$lambda) %*% MLIST$theta %*% MLIST$lambda |
| 898 | ||
| 899 |
# note: CC contains dummy lv's, higher-order, etc... and they |
|
| 900 |
# must be removed |
|
| 901 | ||
| 902 |
# get ALL lv names (including dummy ov.x/ov.y) |
|
| 903 | ! |
ov.names <- lavmodel@dimNames[[lambda.idx[b]]][[1L]] |
| 904 | ! |
lv.names <- lavmodel@dimNames[[lambda.idx[b]]][[2L]] |
| 905 | ! |
NAMES <- lv.names |
| 906 | ||
| 907 |
# needs to removed: |
|
| 908 |
# - all lv.ind variables |
|
| 909 |
# - all higher-order latent variables |
|
| 910 |
# - all dummy lv's |
|
| 911 | ! |
rm.idx <- c(match(lavpta$vnames$lv.ind[[b]], lv.names), |
| 912 | ! |
match(lavpta$vnames$lv.interaction[[b]], lv.names), |
| 913 | ! |
which(lv.names %in% ov.names)) |
| 914 | ! |
if (length(rm.idx) > 0L) {
|
| 915 | ! |
CC <- CC[-rm.idx, -rm.idx, drop = FALSE] |
| 916 | ! |
NAMES <- lv.names[-rm.idx] |
| 917 |
} |
|
| 918 | ||
| 919 |
# cluster membership |
|
| 920 | ! |
membership <- lav_graph_get_connected_nodes(CC) |
| 921 | ||
| 922 | ! |
out <- split(NAMES, NAMES[membership]) |
| 923 | ! |
names(out) <- paste("block", seq_len(length(out)), sep = "")
|
| 924 | ||
| 925 | ! |
mm.list[[b]] <- out |
| 926 |
} |
|
| 927 | ||
| 928 | ! |
mm.list |
| 929 |
} |
|
| 930 | ||
| 931 |
lav_sam_veta_partable <- function(lavobject, block = 1L) {
|
|
| 932 | ||
| 933 | ! |
lavmodel <- lavobject@Model |
| 934 | ! |
lavpta <- lavobject@pta |
| 935 | ! |
nblocks <- lavpta$nblocks |
| 936 | ||
| 937 | ! |
lambda.idx <- which(names(lavmodel@GLIST) == "lambda") |
| 938 | ||
| 939 | ! |
GLIST <- lavTech(lavobject, "partable") |
| 940 | ! |
b <- block |
| 941 | ! |
mm.in.block <- (seq_len(lavmodel@nmat[b]) + cumsum(c(0, lavmodel@nmat))[b]) |
| 942 | ! |
MLIST <- GLIST[mm.in.block] |
| 943 | ! |
PSI <- (MLIST$psi != 0) + 0L |
| 944 | ! |
nr <- nrow(MLIST$psi) |
| 945 | ! |
if (!is.null(MLIST$beta)) {
|
| 946 | ! |
BETA <- (MLIST$beta != 0) + 0L |
| 947 | ! |
tmp <- -BETA |
| 948 | ! |
tmp[lav_matrix_diag_idx(nr)] <- 1 |
| 949 | ! |
IB.inv <- solve(tmp) |
| 950 |
} else {
|
|
| 951 | ! |
IB.inv <- diag(nr) |
| 952 |
} |
|
| 953 | ! |
VETA <- IB.inv %*% PSI %*% t(IB.inv) |
| 954 |
# get ALL lv names (including dummy ov.x/ov.y) |
|
| 955 | ! |
lv.names <- lavmodel@dimNames[[lambda.idx[b]]][[2L]] |
| 956 | ! |
colnames(VETA) <- rownames(VETA) <- lv.names |
| 957 | ||
| 958 | ! |
VETA |
| 959 |
} |
|
| 960 | ||
| 961 |
lav_sam_veta_con <- function(S = NULL, LAMBDA = NULL, THETA = NULL, |
|
| 962 |
L.veta = NULL, local.M.method = "ML", |
|
| 963 |
tol = 1e-07, max.iter = 100L) {
|
|
| 964 | ||
| 965 |
# first do GLS/ULS |
|
| 966 | ! |
M <- ncol(LAMBDA) |
| 967 | ! |
if (local.M.method == "ULS") {
|
| 968 | ! |
W <- diag(M) |
| 969 |
} else {
|
|
| 970 | ! |
W <- solve(S) |
| 971 |
} |
|
| 972 | ||
| 973 | ! |
WL <- W %*% LAMBDA |
| 974 | ! |
tLW <- t(WL) |
| 975 | ! |
tLWL <- tLW %*% LAMBDA |
| 976 | ! |
tmp1 <- t(L.veta) %*% (tLWL %x% tLWL) %*% L.veta |
| 977 | ! |
tmp2 <- t(L.veta) %*% lav_matrix_vec(tLW %*% (S - THETA) %*% WL) |
| 978 | ! |
out <- solve(tmp1, tmp2) |
| 979 | ! |
VETA.init <- matrix(L.veta %*% out, M, M) |
| 980 | ||
| 981 | ! |
if (local.M.method != "ML") {
|
| 982 |
# we are done! |
|
| 983 | ! |
return(VETA.init) |
| 984 |
} |
|
| 985 | ||
| 986 | ! |
VETA.new <- VETA.init |
| 987 | ! |
for(i in seq_len(max.iter)) {
|
| 988 | ! |
Sigma.ml <- LAMBDA %*% VETA.new %*% t(LAMBDA) + THETA |
| 989 | ! |
W <- solve(Sigma.ml) |
| 990 | ! |
WL <- W %*% LAMBDA |
| 991 | ! |
tLW <- t(WL) |
| 992 | ! |
tLWL <- tLW %*% LAMBDA |
| 993 | ! |
tmp1 <- t(L.veta) %*% (tLWL %x% tLWL) %*% L.veta |
| 994 | ! |
tmp2 <- t(L.veta) %*% lav_matrix_vec(tLW %*% (S - THETA) %*% WL) |
| 995 | ! |
out <- solve(tmp1, tmp2) |
| 996 | ! |
VETA.ml <- matrix(L.veta %*% out, M, M) |
| 997 | ! |
rmsea <- sqrt(sum((VETA.new - VETA.ml)^2)) |
| 998 |
#cat("i = ", i, " rmsea = ", rmsea, "\n")
|
|
| 999 | ! |
VETA.new <- VETA.ml |
| 1000 | ! |
if (rmsea < tol) {
|
| 1001 | ! |
break |
| 1002 |
} |
|
| 1003 |
} |
|
| 1004 | ||
| 1005 | ! |
VETA.new |
| 1006 |
} |
|
| 1007 | ||
| 1008 |
| 1 |
# only compute 'H1' (=unrestricted/saturated) sample statistics |
|
| 2 |
# (which usually go into the lavh1 slot) (and perhaps some extras, like icc) |
|
| 3 |
# |
|
| 4 |
# YR 14 June 2024: initial version |
|
| 5 | ||
| 6 |
lavH1 <- function(object, # nolint |
|
| 7 |
# lavdata options |
|
| 8 |
ordered = NULL, |
|
| 9 |
sampling.weights = NULL, |
|
| 10 |
group = NULL, |
|
| 11 |
cluster = NULL, |
|
| 12 |
ov.names.x = character(0L), |
|
| 13 |
ov.names.l = list(), |
|
| 14 |
# other options (for lavaan) |
|
| 15 |
..., |
|
| 16 |
output = "h1", |
|
| 17 |
add.extra = TRUE, |
|
| 18 |
# lavInspect() options |
|
| 19 |
add.labels = TRUE, |
|
| 20 |
add.class = TRUE, |
|
| 21 |
drop.list.single.group = TRUE) {
|
|
| 22 | ||
| 23 |
# shortcut if object = lavaan object |
|
| 24 | ! |
if (inherits(object, "lavaan")) {
|
| 25 | ! |
lavh1 <- lavInspect(object, "h1") |
| 26 |
# if multilevel: add icc |
|
| 27 | ! |
if (add.extra && object@Data@nlevels > 1L) {
|
| 28 | ! |
lavh1$icc <- lavInspect(object, "icc", |
| 29 | ! |
add.labels = add.labels, |
| 30 | ! |
add.class = add.class, drop.list.single.group = drop.list.single.group |
| 31 |
) |
|
| 32 |
} |
|
| 33 | ! |
return(lavh1) |
| 34 |
} |
|
| 35 | ||
| 36 |
# output |
|
| 37 | ! |
output <- tolower(output) |
| 38 | ||
| 39 |
# dotdotdot |
|
| 40 | ! |
dotdotdot <- list(...) |
| 41 | ||
| 42 |
# verbose? |
|
| 43 | ! |
if (!is.null(dotdotdot$verbose)) {
|
| 44 | ! |
if (dotdotdot$verbose) {
|
| 45 | ! |
lav_verbose(TRUE) |
| 46 |
} |
|
| 47 | ! |
dotdotdot$verbose <- NULL |
| 48 |
} |
|
| 49 | ||
| 50 |
# check object class |
|
| 51 | ! |
if (inherits(object, "lavData")) {
|
| 52 | ! |
lavdata <- object |
| 53 | ! |
} else if (inherits(object, "data.frame") || |
| 54 | ! |
inherits(object, "matrix")) {
|
| 55 | ! |
object <- as.data.frame(object) |
| 56 |
} else {
|
|
| 57 | ! |
lav_msg_stop( |
| 58 | ! |
gettext("lavH1 can not handle objects of class"),
|
| 59 | ! |
paste(class(object), collapse = " ") |
| 60 |
) |
|
| 61 |
} |
|
| 62 | ||
| 63 |
# prepare to create lavdata object |
|
| 64 | ! |
if (inherits(object, "lavData")) {
|
| 65 | ! |
ov.names <- unique(unlist(lavdata@ov.names)) |
| 66 | ! |
ov.names.x <- unique(unlist(lavdata@ov.names.x)) |
| 67 | ! |
ordered <- lavdata@ordered |
| 68 | ! |
ov.names.l <- lavdata@ov.names.l |
| 69 | ! |
group <- lavdata@group |
| 70 | ! |
cluster <- lavdata@cluster |
| 71 | ! |
dotdotdot@missing <- lavdata@missing |
| 72 | ||
| 73 |
# just a regular data.frame |
|
| 74 |
} else {
|
|
| 75 |
# ov.names |
|
| 76 | ! |
ov.names <- names(object) |
| 77 | ! |
if (!is.null(group)) {
|
| 78 | ! |
ov.names <- ov.names[-match(group, ov.names)] |
| 79 |
} |
|
| 80 | ! |
if (!is.null(cluster)) {
|
| 81 | ! |
ov.names <- ov.names[-match(cluster, ov.names)] |
| 82 |
} |
|
| 83 | ! |
if (!is.null(sampling.weights)) {
|
| 84 | ! |
ov.names <- ov.names[-match(sampling.weights, ov.names)] |
| 85 |
} |
|
| 86 | ! |
if (!is.null(dotdotdot$conditional.x) && dotdotdot$conditional.x) {
|
| 87 | ! |
if (length(ov.names.x) == 0L) {
|
| 88 | ! |
lav_msg_stop( |
| 89 | ! |
gettext("conditional.x = TRUE, but ov.names.x is empty")
|
| 90 |
) |
|
| 91 |
} |
|
| 92 | ! |
ov.names.x <- unique(unlist(ov.names.x)) |
| 93 | ! |
ov.names <- ov.names[-match(ov.names.x, ov.names)] |
| 94 |
} |
|
| 95 | ||
| 96 |
# ordered |
|
| 97 | ! |
if (is.logical(ordered) && ordered) {
|
| 98 | ! |
ordered <- ov.names |
| 99 | ! |
} else if (is.null(ordered) || |
| 100 | ! |
(length(ordered) == 1L && nchar(ordered) == 0L)) {
|
| 101 |
# check data |
|
| 102 | ! |
ordered <- ov.names[sapply(object, is.ordered)] |
| 103 | ! |
} else if (!is.character(ordered)) {
|
| 104 | ! |
lav_msg_stop(gettext("ordered argument must be a character vector"))
|
| 105 |
} |
|
| 106 | ||
| 107 | ! |
if (length(ordered) > 0L) {
|
| 108 |
# check if all names in "ordered" occur in the dataset? |
|
| 109 | ! |
missing.idx <- which(!ordered %in% ov.names) |
| 110 | ! |
if (length(missing.idx) > 0L) {
|
| 111 | ! |
lav_msg_warn(gettextf("ordered variable(s): %s could not be found
|
| 112 | ! |
in the data and will be ignored", lav_msg_view(ordered[missing.idx]))) |
| 113 |
} |
|
| 114 |
# if ov.names.x, remove them from ordered (sanity check) |
|
| 115 | ! |
if (length(ov.names.x) > 0L) {
|
| 116 | ! |
rm.idx <- which(ordered %in% ov.names.x) |
| 117 | ! |
if (length(rm.idx) > 0L) {
|
| 118 | ! |
ordered <- ordered[-rm.idx] |
| 119 |
} |
|
| 120 |
} |
|
| 121 |
} |
|
| 122 | ||
| 123 |
# group/cluster |
|
| 124 | ! |
if (!is.null(cluster)) {
|
| 125 | ! |
ngroups <- 1L |
| 126 | ! |
if (!is.null(group)) {
|
| 127 | ! |
ngroups <- length(unique(object[, group])) |
| 128 |
} |
|
| 129 | ! |
if (is.null(ov.names.l) || length(ov.names.l) == 0L) {
|
| 130 | ! |
ov.names.l <- vector("list", ngroups)
|
| 131 |
# only two levels for now |
|
| 132 | ! |
for (g in seq_len(ngroups)) {
|
| 133 | ! |
ov.names.l[[g]] <- vector("list", 2L)
|
| 134 | ! |
ov.names.l[[g]][[1]] <- ov.names |
| 135 | ! |
ov.names.l[[g]][[2]] <- ov.names |
| 136 |
} |
|
| 137 |
} else {
|
|
| 138 |
# check ov.names.l |
|
| 139 | ! |
if (!is.list(ov.names.l)) { # just a single vector of names?
|
| 140 | ! |
ov.names.l <- rep(list(ov.names.l), 2L) # twolevels |
| 141 | ! |
} else if (length(ov.names.l) == ngroups && |
| 142 | ! |
is.list(ov.names.l[[ngroups]])) {
|
| 143 |
} else {
|
|
| 144 | ! |
ov.names.l <- rep(list(ov.names.l), ngroups) |
| 145 |
} |
|
| 146 | ! |
tmp <- unique(unlist(ov.names.l)) |
| 147 | ! |
if (!all(tmp %in% ov.names)) {
|
| 148 | ! |
lav_msg_stop(gettextf( |
| 149 | ! |
"some variable names in ov.names.l |
| 150 | ! |
are missing: %1$s", |
| 151 | ! |
lav_msg_view(tmp[!tmp %in% ov.names]) |
| 152 |
)) |
|
| 153 |
} |
|
| 154 |
} |
|
| 155 |
} |
|
| 156 |
} # object = data |
|
| 157 | ||
| 158 |
# lavoptions |
|
| 159 | ! |
lavoptions <- lav_lavaan_step02_options( |
| 160 | ! |
slotOptions = NULL, # nolint |
| 161 | ! |
slotData = NULL, # nolint |
| 162 | ! |
flat.model = NULL, |
| 163 | ! |
ordered = ordered, |
| 164 | ! |
sample.cov = NULL, |
| 165 | ! |
sample.mean = NULL, |
| 166 | ! |
sample.th = NULL, |
| 167 | ! |
sample.nobs = NULL, |
| 168 | ! |
ov.names.l = ov.names.l, |
| 169 | ! |
sampling.weights = sampling.weights, |
| 170 | ! |
constraints = NULL, |
| 171 | ! |
group = group, |
| 172 | ! |
ov.names.x = ov.names.x, |
| 173 | ! |
ov.names.y = ov.names[!ov.names %in% ov.names.x], |
| 174 | ! |
dotdotdot = dotdotdot, |
| 175 | ! |
cluster = cluster, |
| 176 | ! |
data = "not.null" |
| 177 |
) |
|
| 178 | ||
| 179 |
# annoying: ov.names should not contain ov.names.x if categorical |
|
| 180 | ! |
if (length(ordered) > 0L && lavoptions$conditional.x) {
|
| 181 | ! |
rm.idx <- which(ov.names %in% ov.names.x) |
| 182 | ! |
if (length(rm.idx) > 0L) {
|
| 183 | ! |
ov.names <- ov.names[-rm.idx] |
| 184 |
} |
|
| 185 |
} |
|
| 186 | ||
| 187 |
# create lavdata (if needed) |
|
| 188 | ! |
if (!inherits(object, "lavdata")) {
|
| 189 | ! |
lavdata <- lav_lavdata( |
| 190 | ! |
data = object, group = group, cluster = cluster, |
| 191 | ! |
ov.names = ov.names, ordered = ordered, |
| 192 | ! |
sampling.weights = sampling.weights, |
| 193 | ! |
ov.names.x = ov.names.x, ov.names.l = ov.names.l, |
| 194 | ! |
lavoptions = lavoptions |
| 195 |
) |
|
| 196 |
} |
|
| 197 | ||
| 198 |
# create SampleStats (needed for multilevel - YLp slot) |
|
| 199 | ! |
lavsamplestats <- lav_samplestats_from_data( |
| 200 | ! |
lavdata = lavdata, |
| 201 | ! |
lavoptions = lavoptions |
| 202 |
) |
|
| 203 | ||
| 204 |
# generate partable for unrestricted model |
|
| 205 | ! |
lavpartable.un <- lav_partable_unrestricted( |
| 206 | ! |
lavobject = NULL, |
| 207 | ! |
lavdata = lavdata, |
| 208 | ! |
lavsamplestats = lavsamplestats, |
| 209 | ! |
lavh1 = NULL, |
| 210 | ! |
lavoptions = lavoptions |
| 211 |
) |
|
| 212 | ||
| 213 |
# override some options |
|
| 214 | ! |
lavoptions$h1 <- TRUE |
| 215 | ! |
lavoptions$model.type <- "unrestricted" |
| 216 | ! |
lavoptions$start <- "simple" # we have a full ustart column in lavpartable.un |
| 217 | ! |
if (output != "lavaan") {
|
| 218 | ! |
lavoptions$implied <- FALSE |
| 219 | ! |
lavoptions$loglik <- FALSE |
| 220 | ! |
lavoptions$postcheck <- FALSE |
| 221 | ! |
lavoptions$bounds <- "none" |
| 222 | ! |
lavoptions$optim.method <- "none" |
| 223 | ! |
lavoptions$estimator <- "none" |
| 224 | ! |
lavoptions$se <- "none" |
| 225 | ! |
lavoptions$test <- "none" |
| 226 | ! |
lavoptions$baseline <- FALSE |
| 227 |
} |
|
| 228 | ||
| 229 |
# create lavaan object (usually without fitting) |
|
| 230 | ! |
lavobject <- lavaan( |
| 231 | ! |
slotParTable = lavpartable.un, slotData = lavdata, |
| 232 | ! |
slotSampleStats = lavsamplestats, slotOptions = lavoptions |
| 233 |
) |
|
| 234 | ||
| 235 | ! |
output <- tolower(output) |
| 236 | ! |
if (output == "lavaan") {
|
| 237 | ! |
return(lavobject) |
| 238 |
} else {
|
|
| 239 | ! |
lavh1 <- lav_object_inspect_sampstat( |
| 240 | ! |
object = lavobject, h1 = TRUE, |
| 241 | ! |
add.labels = add.labels, add.class = add.class, |
| 242 | ! |
drop.list.single.group = drop.list.single.group |
| 243 |
) |
|
| 244 | ||
| 245 |
# add additional info? |
|
| 246 | ||
| 247 |
# if multilevel: add icc |
|
| 248 | ! |
if (add.extra && lavobject@Data@nlevels > 1L) {
|
| 249 | ! |
lavh1$icc <- lavInspect(lavobject, "icc", |
| 250 | ! |
add.labels = add.labels, |
| 251 | ! |
add.class = add.class, drop.list.single.group = drop.list.single.group |
| 252 |
) |
|
| 253 |
} |
|
| 254 |
} |
|
| 255 | ||
| 256 | ! |
lavh1 |
| 257 |
} |
| 1 |
# keep 'old' names for some function names that have been used |
|
| 2 |
# (or are still being used) by external packages |
|
| 3 |
# rsem |
|
| 4 |
computeExpectedInformation <- lav_model_information_expected # nolint start |
|
| 5 |
# only for simsem .... |
|
| 6 |
getParameterLabels <- lav_partable_labels |
|
| 7 | ||
| 8 |
# standardize function names in lav_utils.R / 31 Oct 2025 |
|
| 9 |
getCov <- function(x, lower = TRUE, diagonal = TRUE, sds = NULL, |
|
| 10 |
names = paste("V", 1:nvar, sep = "")) {
|
|
| 11 | 2x |
lav_deprecated("lav_getcov")
|
| 12 | 2x |
if (diagonal) {
|
| 13 | 2x |
nvar <- (sqrt(1 + 8 * length(x)) - 1)/2 |
| 14 |
} |
|
| 15 |
else {
|
|
| 16 | ! |
nvar <- (sqrt(1 + 8 * length(x)) + 1)/2 |
| 17 |
} |
|
| 18 | 2x |
sc <- sys.call() |
| 19 | 2x |
sc[[1L]] <- quote(lavaan::lav_getcov) |
| 20 | 2x |
eval(sc, parent.frame()) |
| 21 |
} |
|
| 22 |
char2num <- function(s = "") {
|
|
| 23 | ! |
lav_deprecated("lav_char2num")
|
| 24 | ! |
sc <- sys.call() |
| 25 | ! |
sc[[1L]] <- quote(lavaan::lav_char2num) |
| 26 | ! |
eval(sc, parent.frame()) |
| 27 |
} |
|
| 28 |
cor2cov <- function(R, sds, names = NULL) {
|
|
| 29 | ! |
lav_deprecated("lav_cor2cov")
|
| 30 | ! |
sc <- sys.call() |
| 31 | ! |
sc[[1L]] <- quote(lavaan::lav_cor2cov) |
| 32 | ! |
eval(sc, parent.frame()) |
| 33 |
} |
|
| 34 | ||
| 35 |
# standardize function names in lav_mplus_lavaan / 7 Nov 2025 |
|
| 36 |
mplus2lavaan.modelSyntax <- function(syntax) {
|
|
| 37 | ! |
lav_deprecated("lav_mplus_syntax_model")
|
| 38 | ! |
sc <- sys.call() |
| 39 | ! |
sc[[1L]] <- quote(lavaan::lav_mplus_syntax_model) |
| 40 | ! |
eval(sc, parent.frame()) |
| 41 |
} |
|
| 42 |
mplus2lavaan <- function(inpfile, run = TRUE) {
|
|
| 43 | ! |
lav_deprecated("lav_mplus_lavaan")
|
| 44 | ! |
sc <- sys.call() |
| 45 | ! |
sc[[1L]] <- quote(lavaan::lav_mplus_lavaan) |
| 46 | ! |
eval(sc, parent.frame()) |
| 47 |
} |
|
| 48 | ||
| 49 |
# standardize function names in lav_partable_vnames.R / 9 December 2025 |
|
| 50 |
lavaanNames <- function(object, type = "ov", ...) {
|
|
| 51 | ! |
lav_deprecated("lavNames", times = 0L) #--> for now no warning
|
| 52 | ! |
sc <- sys.call() |
| 53 | ! |
sc[[1L]] <- quote(lavaan::lavNames) |
| 54 | ! |
eval(sc, parent.frame()) |
| 55 |
} |
|
| 56 | ||
| 57 |
# standardize function names in lav_simulate_old.R / 9 December 2025 |
|
| 58 |
simulateData <- function( |
|
| 59 |
model = NULL, |
|
| 60 |
model.type = "sem", |
|
| 61 |
meanstructure = FALSE, |
|
| 62 |
int.ov.free = TRUE, |
|
| 63 |
int.lv.free = FALSE, |
|
| 64 |
marker.int.zero = FALSE, |
|
| 65 |
conditional.x = FALSE, |
|
| 66 |
composites = TRUE, |
|
| 67 |
fixed.x = FALSE, |
|
| 68 |
orthogonal = FALSE, |
|
| 69 |
std.lv = TRUE, |
|
| 70 |
auto.fix.first = FALSE, |
|
| 71 |
auto.fix.single = FALSE, |
|
| 72 |
auto.var = TRUE, |
|
| 73 |
auto.cov.lv.x = TRUE, |
|
| 74 |
auto.cov.y = TRUE, |
|
| 75 |
..., |
|
| 76 |
sample.nobs = 500L, |
|
| 77 |
ov.var = NULL, |
|
| 78 |
group.label = paste("G", 1:ngroups, sep = ""),
|
|
| 79 |
skewness = NULL, |
|
| 80 |
kurtosis = NULL, |
|
| 81 |
seed = NULL, |
|
| 82 |
empirical = FALSE, |
|
| 83 |
return.type = "data.frame", |
|
| 84 |
return.fit = FALSE, |
|
| 85 |
debug = FALSE, |
|
| 86 |
standardized = FALSE) {
|
|
| 87 | ! |
lav_deprecated("lavSimulateData", times = 0L) #--> for now no warning
|
| 88 | ! |
if (is.list(model)) {
|
| 89 | ! |
ngroups <- lav_partable_ngroups(model) |
| 90 |
} else {
|
|
| 91 | ! |
ngroups <- sample.nobs |
| 92 |
} |
|
| 93 | ! |
sc <- sys.call() |
| 94 |
# call new function |
|
| 95 | ! |
sc[[1L]] <- quote(lavaan::lavSimulateData) |
| 96 | ! |
eval(sc, parent.frame()) |
| 97 |
} |
|
| 98 |
# standardize function names in lav_bootstrap.R / 9 December 2025 |
|
| 99 |
bootstrapLavaan <- function(object, |
|
| 100 |
R = 1000L, |
|
| 101 |
type = "ordinary", |
|
| 102 |
verbose = FALSE, |
|
| 103 |
FUN = "coef", |
|
| 104 |
keep.idx = FALSE, |
|
| 105 |
parallel = c("no", "multicore", "snow"),
|
|
| 106 |
ncpus = max(1L, parallel::detectCores() - 2L), |
|
| 107 |
cl = NULL, |
|
| 108 |
iseed = NULL, |
|
| 109 |
h0.rmsea = NULL, |
|
| 110 |
...) {
|
|
| 111 | ! |
lav_deprecated("lavBootstrap", times = 0L) #--> for now no warning
|
| 112 | ! |
sc <- sys.call() |
| 113 |
# call new function |
|
| 114 | ! |
sc[[1L]] <- quote(lavaan::lavBootstrap) |
| 115 | ! |
eval(sc, parent.frame()) |
| 116 |
} |
|
| 117 | ||
| 118 |
# standardize exported functions / 13 December 2025 |
|
| 119 |
inspectSampleCov <- function(model, data, ...) {
|
|
| 120 | ! |
lav_deprecated("lavInspectSampleCov") #--> for now no warning
|
| 121 | ! |
sc <- sys.call() |
| 122 | ! |
sc[[1L]] <- quote(lavaan::lavInspectSampleCov) |
| 123 | ! |
eval(sc, parent.frame()) |
| 124 |
} # nolint end |
|
| 125 | ||
| 126 |
# parameterestimates <- function(object, |
|
| 127 |
# se = TRUE, zstat = TRUE, pvalue = TRUE, |
|
| 128 |
# ci = TRUE, standardized = FALSE, |
|
| 129 |
# fmi = FALSE, plabel = FALSE, |
|
| 130 |
# level = 0.95, boot.ci.type = "perc", |
|
| 131 |
# cov.std = TRUE, fmi.options = list(), |
|
| 132 |
# rsquare = FALSE, |
|
| 133 |
# remove.system.eq = TRUE, remove.eq = TRUE, |
|
| 134 |
# remove.ineq = TRUE, remove.def = FALSE, |
|
| 135 |
# remove.nonfree = FALSE, remove.step1 = TRUE, |
|
| 136 |
# remove.unused = FALSE, add.attributes = FALSE, |
|
| 137 |
# output = "data.frame", header = FALSE) {
|
|
| 138 |
# lav_deprecated("lavParameterEstimates", times = 1L) #--> for now no warning
|
|
| 139 |
# sc <- sys.call() |
|
| 140 |
# sc[[1L]] <- quote(lavaan::lavParameterEstimates) |
|
| 141 |
# eval(sc, parent.frame()) |
|
| 142 |
# } |
|
| 143 |
parameterestimates <- parameterEstimates # alias |
|
| 144 | ||
| 145 |
# for tidySEM in 0.6-21 only |
|
| 146 |
# vnames <- lav_partable_vnames |
| 1 |
# James-Stein estimator |
|
| 2 |
# |
|
| 3 |
# Burghgraeve, E., De Neve, J., & Rosseel, Y. (2021). Estimating structural |
|
| 4 |
# equation models using James-Stein type shrinkage estimators. Psychometrika, |
|
| 5 |
# 86(1), 96-130. |
|
| 6 |
# |
|
| 7 |
# YR 08 Feb 2023: - first version in lavaan, cfa only (for now) |
|
| 8 | ||
| 9 |
lav_cfa_jamesstein <- function(S, |
|
| 10 |
Y = NULL, # raw data |
|
| 11 |
marker.idx = NULL, |
|
| 12 |
lambda.nonzero.idx = NULL, |
|
| 13 |
theta = NULL, # vector! |
|
| 14 |
theta.bounds = TRUE, |
|
| 15 |
aggregated = FALSE) { # aggregated?
|
|
| 16 |
# dimensions |
|
| 17 | ! |
nvar <- ncol(S) |
| 18 | ! |
nfac <- length(marker.idx) |
| 19 | ! |
stopifnot(length(theta) == nvar) |
| 20 | ! |
N <- nrow(Y) |
| 21 | ! |
stopifnot(ncol(Y) == nvar) |
| 22 | ||
| 23 |
# overview of lambda structure |
|
| 24 | ! |
B <- LAMBDA <- B.nomarker <- matrix(0, nvar, nfac) |
| 25 | ! |
lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx |
| 26 | ! |
B[lambda.marker.idx] <- LAMBDA[lambda.marker.idx] <- 1L |
| 27 | ! |
B[lambda.nonzero.idx] <- B.nomarker[lambda.nonzero.idx] <- 1L |
| 28 | ||
| 29 |
# Nu |
|
| 30 | ! |
NU <- numeric(nvar) |
| 31 | ||
| 32 |
# do we first 'clip' the theta values so they are within standard bounds? |
|
| 33 |
# (Question: do we need the 0.01 and 0.99 multipliers?) |
|
| 34 | ! |
diagS <- diag(S) |
| 35 | ! |
if (theta.bounds) {
|
| 36 |
# lower bound |
|
| 37 | ! |
lower.bound <- diagS * 0 # * 0.01 |
| 38 | ! |
too.small.idx <- which(theta < lower.bound) |
| 39 | ! |
if (length(too.small.idx) > 0L) {
|
| 40 | ! |
theta[too.small.idx] <- lower.bound[too.small.idx] |
| 41 |
} |
|
| 42 | ||
| 43 |
# upper bound |
|
| 44 | ! |
upper.bound <- diagS * 1 # * 0.99 |
| 45 | ! |
too.large.idx <- which(theta > upper.bound) |
| 46 | ! |
if (length(too.large.idx) > 0L) {
|
| 47 | ! |
theta[too.large.idx] <- upper.bound[too.large.idx] |
| 48 |
} |
|
| 49 |
} |
|
| 50 | ||
| 51 |
# compute conditional expectation conditional on the scaling indicator |
|
| 52 | ! |
E.JS1 <- lav_cfa_jamesstein_ce( |
| 53 | ! |
Y = Y, marker.idx = marker.idx, |
| 54 | ! |
resvars.markers = theta[marker.idx] |
| 55 |
) |
|
| 56 | ||
| 57 |
# compute LAMBDA |
|
| 58 | ! |
for (f in seq_len(nfac)) {
|
| 59 | ! |
nomarker.idx <- which(B.nomarker[, f] == 1) |
| 60 | ! |
Y.nomarker.f <- Y[, nomarker.idx, drop = FALSE] |
| 61 | ||
| 62 |
# regress no.marker.idx data on E(\eta|Y) |
|
| 63 | ! |
fit <- lm(Y.nomarker.f ~ E.JS1[, f, drop = FALSE]) |
| 64 | ||
| 65 |
# extract 'lambda' values |
|
| 66 | ! |
LAMBDA[nomarker.idx, f] <- drop(coef(fit)[-1, ]) |
| 67 | ||
| 68 |
# (optional) extract means |
|
| 69 |
# NU[nomarker.idx] <- drop(coef(fit)[1,]) |
|
| 70 | ||
| 71 | ! |
if (aggregated) {
|
| 72 |
# local copy of 'scaling' LAMBDA |
|
| 73 | ! |
LAMBDA.scaling <- LAMBDA |
| 74 | ||
| 75 | ! |
J <- length(nomarker.idx) |
| 76 | ! |
for (j in seq_len(J)) {
|
| 77 |
# data without this indicator |
|
| 78 | ! |
j.idx <- nomarker.idx[j] |
| 79 | ! |
no.j.idx <- c(marker.idx[f], nomarker.idx[-j]) |
| 80 | ! |
Y.agg <- Y[, no.j.idx, drop = FALSE] |
| 81 | ! |
Y.j <- Y[, j.idx, drop = FALSE] |
| 82 | ||
| 83 |
# retrieve estimated values scaling JS |
|
| 84 | ! |
lambda.JS.scaling <- LAMBDA.scaling[no.j.idx, f, drop = FALSE] |
| 85 | ||
| 86 |
# optimize the weights |
|
| 87 | ! |
starting.weights <- rep(1 / J, times = J) |
| 88 | ! |
w <- optim( |
| 89 | ! |
par = starting.weights, |
| 90 | ! |
fn = lav_cfa_jamesstein_rel, |
| 91 | ! |
data = Y.agg, |
| 92 | ! |
resvars = theta[no.j.idx] |
| 93 | ! |
)$par |
| 94 | ||
| 95 |
# make sure the weights sum up to 1 |
|
| 96 | ! |
w.optim <- w / sum(w) |
| 97 | ||
| 98 |
# compute aggregated indicator using the optimal weights |
|
| 99 | ! |
y_agg <- t(t(w.optim) %*% t(Y.agg)) |
| 100 | ||
| 101 |
# compute error variance of the aggregated indicator |
|
| 102 | ! |
var_eps_agg <- drop(t(w.optim) %*% |
| 103 | ! |
diag(theta[no.j.idx], nrow = length(no.j.idx)) %*% w.optim) |
| 104 | ||
| 105 |
# compute conditional expectation using aggregated indicator |
|
| 106 | ! |
tmp <- lav_cfa_jamesstein_ce( |
| 107 | ! |
Y = y_agg, marker.idx = 1L, |
| 108 | ! |
resvars.markers = var_eps_agg |
| 109 |
) |
|
| 110 | ! |
CE_agg <- tmp / drop(w.optim %*% lambda.JS.scaling) |
| 111 | ||
| 112 |
# compute factor loading |
|
| 113 | ! |
fit <- lm(Y.j ~ CE_agg) |
| 114 | ! |
LAMBDA[j.idx, f] <- drop(coef(fit)[-1]) |
| 115 | ||
| 116 |
# (optional) extract means |
|
| 117 |
# NU[j.idx] <- drop(coef(fit)[1,]) |
|
| 118 |
} # j |
|
| 119 |
} # aggregate |
|
| 120 |
} # f |
|
| 121 | ||
| 122 | ! |
out <- list(lambda = LAMBDA, nu = NU) |
| 123 |
} |
|
| 124 | ||
| 125 |
# internal function to be used inside lav_optim_noniter |
|
| 126 |
# return 'x', the estimated vector of free parameters |
|
| 127 |
lav_cfa_jamesstein_internal <- function(lavobject = NULL, # convenience |
|
| 128 |
# internal slot |
|
| 129 |
lavmodel = NULL, |
|
| 130 |
lavsamplestats = NULL, |
|
| 131 |
lavpartable = NULL, |
|
| 132 |
lavdata = NULL, |
|
| 133 |
lavoptions = NULL, |
|
| 134 |
theta.bounds = TRUE) {
|
|
| 135 | ! |
lavpta <- NULL |
| 136 | ! |
if (!is.null(lavobject)) {
|
| 137 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 138 | ||
| 139 |
# extract slots |
|
| 140 | ! |
lavmodel <- lavobject@Model |
| 141 | ! |
lavsamplestats <- lavobject@SampleStats |
| 142 | ! |
lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta) |
| 143 | ! |
lavpta <- lavobject@pta |
| 144 | ! |
lavdata <- lavobject@Data |
| 145 | ! |
lavoptions <- lavobject@Options |
| 146 |
} |
|
| 147 | ! |
if (is.null(lavpta)) {
|
| 148 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 149 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 150 |
} |
|
| 151 | ||
| 152 |
# no structural part! |
|
| 153 | ! |
if (any(lavpartable$op == "~")) {
|
| 154 | ! |
lav_msg_stop(gettext( |
| 155 | ! |
"JS(A) estimator only available for CFA models (for now)")) |
| 156 |
} |
|
| 157 |
# no BETA matrix! (i.e., no higher-order factors) |
|
| 158 | ! |
if (!is.null(lavmodel@GLIST$beta)) {
|
| 159 | ! |
lav_msg_stop(gettext( |
| 160 | ! |
"JS(A) estimator not available for models that require a BETA matrix")) |
| 161 |
} |
|
| 162 |
# no std.lv = TRUE for now |
|
| 163 | ! |
if (lavoptions$std.lv) {
|
| 164 | ! |
lav_msg_stop(gettext("S(A) estimator not available if std.lv = TRUE"))
|
| 165 |
} |
|
| 166 | ||
| 167 | ! |
nblocks <- lav_partable_nblocks(lavpartable) |
| 168 | ! |
stopifnot(nblocks == 1L) # for now |
| 169 | ! |
b <- 1L |
| 170 | ! |
sample.cov <- lavsamplestats@cov[[b]] |
| 171 | ! |
nvar <- nrow(sample.cov) |
| 172 | ! |
lv.names <- lavpta$vnames$lv.regular[[b]] |
| 173 | ! |
nfac <- length(lv.names) |
| 174 | ! |
marker.idx <- lavpta$vidx$lv.marker[[b]] |
| 175 | ! |
lambda.idx <- which(names(lavmodel@GLIST) == "lambda") |
| 176 | ! |
lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]] |
| 177 |
# only diagonal THETA for now... |
|
| 178 | ! |
theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2' |
| 179 | ! |
m.theta <- lavmodel@m.free.idx[[theta.idx]] |
| 180 | ! |
nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)] |
| 181 | ! |
if (length(nondiag.idx) > 0L) {
|
| 182 | ! |
lav_msg_warn(gettext( |
| 183 | ! |
"this implementation of JS/JSA does not handle correlated residuals yet!" |
| 184 |
)) |
|
| 185 |
} |
|
| 186 | ||
| 187 | ||
| 188 |
# 1. obtain estimate for (diagonal elements of) THETA |
|
| 189 |
# for now we use Spearman per factor |
|
| 190 | ! |
B <- matrix(0, nvar, nfac) |
| 191 | ! |
lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx |
| 192 | ! |
B[lambda.marker.idx] <- 1L |
| 193 | ! |
B[lambda.nonzero.idx] <- 1L |
| 194 | ! |
theta <- numeric(nvar) |
| 195 | ! |
for (f in seq_len(nfac)) {
|
| 196 | ! |
ov.idx <- which(B[, f] == 1L) |
| 197 | ! |
S.fac <- sample.cov[ov.idx, ov.idx, drop = FALSE] |
| 198 | ! |
theta[ov.idx] <- lav_cfa_theta_spearman(S.fac, bounds = "wide") |
| 199 |
} |
|
| 200 | ! |
THETA <- diag(theta, nrow = nvar) |
| 201 | ||
| 202 |
# 2. run James-Stein algorithm |
|
| 203 | ! |
Y <- lavdata@X[[1]] # raw data |
| 204 | ! |
aggregated <- FALSE |
| 205 | ! |
if (lavoptions$estimator == "JSA") {
|
| 206 | ! |
aggregated <- TRUE |
| 207 |
} |
|
| 208 | ! |
out <- lav_cfa_jamesstein( |
| 209 | ! |
S = sample.cov, Y = Y, marker.idx = marker.idx, |
| 210 | ! |
lambda.nonzero.idx = lambda.nonzero.idx, |
| 211 | ! |
theta = theta, |
| 212 |
# experimental |
|
| 213 | ! |
theta.bounds = theta.bounds, |
| 214 |
# |
|
| 215 | ! |
aggregated = aggregated |
| 216 |
) |
|
| 217 | ! |
LAMBDA <- out$lambda |
| 218 | ||
| 219 |
# 3. PSI |
|
| 220 | ! |
PSI <- lav_cfa_lambdatheta2psi( |
| 221 | ! |
lambda = LAMBDA, theta = theta, |
| 222 | ! |
S = sample.cov, mapping = "ML" |
| 223 |
) |
|
| 224 | ||
| 225 |
# store matrices in lavmodel@GLIST |
|
| 226 | ! |
lavmodel@GLIST$lambda <- LAMBDA |
| 227 | ! |
lavmodel@GLIST$theta <- THETA |
| 228 | ! |
lavmodel@GLIST$psi <- PSI |
| 229 | ||
| 230 |
# extract free parameters only |
|
| 231 | ! |
x <- lav_model_get_parameters(lavmodel) |
| 232 | ||
| 233 |
# apply bounds (if any) |
|
| 234 | ! |
if (!is.null(lavpartable$lower)) {
|
| 235 | ! |
lower.x <- lavpartable$lower[lavpartable$free > 0] |
| 236 | ! |
too.small.idx <- which(x < lower.x) |
| 237 | ! |
if (length(too.small.idx) > 0L) {
|
| 238 | ! |
x[too.small.idx] <- lower.x[too.small.idx] |
| 239 |
} |
|
| 240 |
} |
|
| 241 | ! |
if (!is.null(lavpartable$upper)) {
|
| 242 | ! |
upper.x <- lavpartable$upper[lavpartable$free > 0] |
| 243 | ! |
too.large.idx <- which(x > upper.x) |
| 244 | ! |
if (length(too.large.idx) > 0L) {
|
| 245 | ! |
x[too.large.idx] <- upper.x[too.large.idx] |
| 246 |
} |
|
| 247 |
} |
|
| 248 | ||
| 249 | ! |
x |
| 250 |
} |
|
| 251 | ||
| 252 | ||
| 253 |
# Conditional expectation (Section 2.1, eq. 10) |
|
| 254 |
lav_cfa_jamesstein_ce <- function(Y = NULL, |
|
| 255 |
marker.idx = NULL, |
|
| 256 |
resvars.markers = NULL) {
|
|
| 257 | ! |
Y <- as.matrix(Y) |
| 258 | ||
| 259 |
# sample size |
|
| 260 | ! |
N <- nrow(Y) |
| 261 | ! |
N1 <- N - 1 |
| 262 | ! |
N3 <- N - 3 |
| 263 | ||
| 264 |
# markers only |
|
| 265 | ! |
Y.marker <- Y[, marker.idx, drop = FALSE] |
| 266 | ||
| 267 |
# means and variances |
|
| 268 | ! |
MEAN <- colMeans(Y.marker, na.rm = TRUE) |
| 269 | ! |
VAR <- apply(Y.marker, 2, var, na.rm = TRUE) |
| 270 | ||
| 271 |
# 1 - R per maker |
|
| 272 | ! |
oneminR <- N3 * resvars.markers / (N1 * VAR) |
| 273 | ||
| 274 |
# R per marker |
|
| 275 | ! |
R <- 1 - oneminR |
| 276 | ||
| 277 |
# create E(\eta | Y) |
|
| 278 | ! |
E.eta.cond.Y <- t(t(Y.marker) * R + oneminR * MEAN) |
| 279 | ||
| 280 | ! |
E.eta.cond.Y |
| 281 |
} |
|
| 282 | ||
| 283 |
# Reliability function used to obtain the weights (Section 4, Aggregation) |
|
| 284 |
lav_cfa_jamesstein_rel <- function(w = NULL, data = NULL, resvars = NULL) {
|
|
| 285 |
# construct weight vector |
|
| 286 | ! |
w <- matrix(w, ncol = 1) |
| 287 | ||
| 288 |
# construct aggregated indicator: y_agg = t(w) %*% y_i |
|
| 289 | ! |
y_agg <- t(t(w) %*% t(data)) |
| 290 | ||
| 291 |
# calculate variance of aggregated indicator |
|
| 292 | ! |
var_y_agg <- var(y_agg) |
| 293 | ||
| 294 |
# calculate error variance of the aggregated indicator |
|
| 295 | ! |
var_eps_agg <- t(w) %*% diag(resvars) %*% w |
| 296 | ||
| 297 |
# reliability function to be maximized |
|
| 298 | ! |
rel <- (var_y_agg - var_eps_agg) %*% solve(var_y_agg) |
| 299 | ||
| 300 |
# return value |
|
| 301 | ! |
return(-rel) |
| 302 |
} |
| 1 |
# classic score test (= Lagrange Multiplier test) |
|
| 2 |
# |
|
| 3 |
# this function can run in two modes: |
|
| 4 |
# |
|
| 5 |
# MODE 1: 'add' |
|
| 6 |
# add new parameters that are currently not included in de model |
|
| 7 |
# (aka fixed to zero), but should be released |
|
| 8 |
# |
|
| 9 |
# MODE 2: 'release' (the default) |
|
| 10 |
# release existing "==" constraints |
|
| 11 |
# |
|
| 12 |
# - YR 8 Jan 2026: use ceq.JAC instead of con.jac (as we do not support |
|
| 13 |
# inequality constraints anyway, and we do not want to |
|
| 14 |
# release the EFA constraints) |
|
| 15 | ||
| 16 |
lavTestScore <- function(object, add = NULL, release = NULL, |
|
| 17 |
univariate = TRUE, cumulative = FALSE, |
|
| 18 |
epc = FALSE, standardized = epc, cov.std = epc, |
|
| 19 |
verbose = FALSE, warn = TRUE, |
|
| 20 |
information = "expected") {
|
|
| 21 |
# check object |
|
| 22 | ! |
object <- lav_object_check_version(object) |
| 23 | ||
| 24 | ! |
if (!missing(warn)) {
|
| 25 | ! |
current.warn <- lav_warn() |
| 26 | ! |
if (lav_warn(warn)) |
| 27 | ! |
on.exit(lav_warn(current.warn)) |
| 28 |
} |
|
| 29 | ! |
if (!missing(verbose)) {
|
| 30 | ! |
current.verbose <- lav_verbose() |
| 31 | ! |
if (lav_verbose(verbose)) |
| 32 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 33 |
} |
|
| 34 |
# check object |
|
| 35 | ! |
stopifnot(inherits(object, "lavaan")) |
| 36 | ! |
lavoptions <- object@Options |
| 37 | ||
| 38 | ! |
if (object@optim$npar > 0L && !object@optim$converged) {
|
| 39 | ! |
lav_msg_stop(gettext("model did not converge"))
|
| 40 |
} |
|
| 41 | ||
| 42 |
# check for inequality constraints |
|
| 43 | ! |
PT <- object@ParTable |
| 44 | ! |
if (any(PT$op == ">" | PT$op == "<")) {
|
| 45 | ! |
lav_msg_stop(gettext( |
| 46 | ! |
"lavTestScore() does not handle inequality constraints (yet)")) |
| 47 |
} |
|
| 48 | ||
| 49 |
# check arguments |
|
| 50 | ! |
if (cumulative) {
|
| 51 | ! |
univariate <- TRUE |
| 52 |
} |
|
| 53 | ||
| 54 | ||
| 55 |
# Mode 1: ADDING new parameters |
|
| 56 | ! |
if (!is.null(add) && all(nchar(add) > 0L)) {
|
| 57 |
# check release argument |
|
| 58 | ! |
if (!is.null(release)) {
|
| 59 | ! |
lav_msg_stop(gettext( |
| 60 | ! |
"`add' and `release' arguments cannot be used together.")) |
| 61 |
} |
|
| 62 | ||
| 63 |
# extend model with extra set of parameters |
|
| 64 | ! |
FIT <- lav_object_extended(object, add = add) |
| 65 | ||
| 66 | ! |
score <- lavTech(FIT, "gradient.logl") |
| 67 | ! |
Information <- lavTech(FIT, paste("information", information, sep = "."))
|
| 68 | ||
| 69 | ! |
npar <- object@Model@nx.free |
| 70 | ! |
nadd <- FIT@Model@nx.free - npar |
| 71 | ||
| 72 |
# R |
|
| 73 | ! |
R.model <- object@Model@ceq.JAC[, , drop = FALSE] |
| 74 | ! |
if (nrow(R.model) > 0L) {
|
| 75 | ! |
R.model <- cbind(R.model, matrix(0, nrow(R.model), ncol = nadd)) |
| 76 | ! |
R.add <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd)) |
| 77 | ! |
R <- rbind(R.model, R.add) |
| 78 | ||
| 79 | ! |
Z <- cbind( |
| 80 | ! |
rbind(Information, R.model), |
| 81 | ! |
rbind(t(R.model), matrix(0, nrow(R.model), nrow(R.model))) |
| 82 |
) |
|
| 83 | ! |
Z.plus <- MASS::ginv(Z) |
| 84 | ! |
J.inv <- Z.plus[1:nrow(Information), 1:nrow(Information)] |
| 85 | ||
| 86 | ! |
r.idx <- seq_len(nadd) + nrow(R.model) |
| 87 |
} else {
|
|
| 88 | ! |
R <- cbind(matrix(0, nrow = nadd, ncol = npar), diag(nadd)) |
| 89 | ! |
J.inv <- MASS::ginv(Information) |
| 90 | ||
| 91 | ! |
r.idx <- seq_len(nadd) |
| 92 |
} |
|
| 93 | ||
| 94 |
# lhs/rhs |
|
| 95 | ! |
lhs <- lav_partable_labels(FIT@ParTable)[FIT@ParTable$user == 10L] |
| 96 | ! |
op <- rep("==", nadd)
|
| 97 | ! |
rhs <- rep("0", nadd)
|
| 98 | ! |
Table <- data.frame( |
| 99 | ! |
lhs = lhs, op = op, rhs = rhs, |
| 100 | ! |
stringsAsFactors = FALSE |
| 101 |
) |
|
| 102 | ! |
class(Table) <- c("lavaan.data.frame", "data.frame")
|
| 103 |
} else {
|
|
| 104 |
# MODE 2: releasing constraints |
|
| 105 | ||
| 106 | ! |
R <- object@Model@ceq.JAC[, , drop = FALSE] |
| 107 | ! |
if (nrow(R) == 0L) {
|
| 108 | ! |
lav_msg_stop(gettext("no equality constraints found in model."))
|
| 109 |
} |
|
| 110 | ||
| 111 | ! |
score <- lavTech(object, "gradient.logl") |
| 112 | ! |
Information <- lavTech( |
| 113 | ! |
object, |
| 114 | ! |
paste("information", information, sep = ".")
|
| 115 |
) |
|
| 116 | ! |
J.inv <- MASS::ginv(Information) # FIXME: move into if(is.null(release))? |
| 117 |
# else written over with Z1.plus if(is.numeric(release)) |
|
| 118 |
# R <- object@Model@con.jac[,] |
|
| 119 | ||
| 120 | ! |
if (is.null(release)) {
|
| 121 |
# ALL constraints |
|
| 122 | ! |
r.idx <- seq_len(nrow(R)) |
| 123 | ! |
} else if (is.numeric(release)) {
|
| 124 | ! |
r.idx <- release |
| 125 | ! |
if (max(r.idx) > nrow(R)) {
|
| 126 | ! |
lav_msg_stop(gettextf( |
| 127 | ! |
"maximum constraint number (%1$s) is larger than number of |
| 128 | ! |
constraints (%2$s)", max(r.idx), nrow(R))) |
| 129 |
} |
|
| 130 | ||
| 131 |
# neutralize the non-needed constraints |
|
| 132 | ! |
R1 <- R[-r.idx, , drop = FALSE] |
| 133 | ! |
Z1 <- cbind( |
| 134 | ! |
rbind(Information, R1), |
| 135 | ! |
rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) |
| 136 |
) |
|
| 137 | ! |
Z1.plus <- MASS::ginv(Z1) |
| 138 | ! |
J.inv <- Z1.plus[1:nrow(Information), 1:nrow(Information)] |
| 139 | ! |
} else if (is.character(release)) {
|
| 140 | ! |
lav_msg_stop(gettext("not implemented yet"))
|
| 141 |
} |
|
| 142 | ||
| 143 |
# lhs/rhs |
|
| 144 | ! |
eq.idx <- which(object@ParTable$op == "==") |
| 145 | ! |
if (length(eq.idx) > 0L) {
|
| 146 | ! |
lhs <- object@ParTable$lhs[eq.idx][r.idx] |
| 147 | ! |
op <- rep("==", length(r.idx))
|
| 148 | ! |
rhs <- object@ParTable$rhs[eq.idx][r.idx] |
| 149 |
} |
|
| 150 | ! |
Table <- data.frame( |
| 151 | ! |
lhs = lhs, op = op, rhs = rhs, |
| 152 | ! |
stringsAsFactors = FALSE |
| 153 |
) |
|
| 154 | ! |
class(Table) <- c("lavaan.data.frame", "data.frame")
|
| 155 |
} |
|
| 156 | ||
| 157 | ! |
if (object@Data@nlevels == 1L) {
|
| 158 | ! |
N <- object@SampleStats@ntotal |
| 159 | ! |
if (lavoptions$mimic == "EQS") {
|
| 160 | ! |
N <- N - 1 |
| 161 |
} |
|
| 162 |
} else {
|
|
| 163 |
# total number of clusters (over groups) |
|
| 164 | ! |
N <- 0 |
| 165 | ! |
for (g in 1:object@SampleStats@ngroups) {
|
| 166 | ! |
N <- N + object@Data@Lp[[g]]$nclusters[[2]] |
| 167 |
} |
|
| 168 |
# score <- score * (2 * object@SampleStats@ntotal) / N |
|
| 169 | ! |
score <- score / 2 # -2 * LRT |
| 170 |
} |
|
| 171 | ||
| 172 | ! |
if (lavoptions$se == "standard") {
|
| 173 | ! |
stat <- as.numeric(N * score %*% J.inv %*% score) |
| 174 |
} else {
|
|
| 175 |
# generalized score test |
|
| 176 | ! |
lav_msg_warn(gettext("se is not `standard'; not implemented yet;
|
| 177 | ! |
falling back to ordinary score test")) |
| 178 | ||
| 179 |
# NOTE!!! |
|
| 180 |
# we can NOT use VCOV here, because it reflects the constraints, |
|
| 181 |
# and the whole point is to test for these constraints... |
|
| 182 | ||
| 183 | ! |
stat <- as.numeric(N * score %*% J.inv %*% score) |
| 184 |
} |
|
| 185 | ||
| 186 |
# compute df, taking into account that some of the constraints may |
|
| 187 |
# be needed to identify the model (and hence Information is singular) |
|
| 188 |
# Information.plus <- Information + crossprod(R) |
|
| 189 |
# df <- qr(R[r.idx,,drop = FALSE])$rank + |
|
| 190 |
# ( qr(Information)$rank - qr(Information.plus)$rank ) |
|
| 191 | ! |
df <- nrow(R[r.idx, , drop = FALSE]) |
| 192 | ! |
pvalue <- 1 - pchisq(stat, df = df) |
| 193 | ||
| 194 |
# total score test |
|
| 195 | ! |
TEST <- data.frame( |
| 196 | ! |
test = "score", X2 = stat, df = df, p.value = pvalue, |
| 197 | ! |
stringsAsFactors = FALSE |
| 198 |
) |
|
| 199 | ! |
class(TEST) <- c("lavaan.data.frame", "data.frame")
|
| 200 | ! |
attr(TEST, "header") <- "total score test:" |
| 201 | ||
| 202 | ! |
OUT <- list(test = TEST) |
| 203 | ||
| 204 | ! |
if (univariate) {
|
| 205 | ! |
TS <- numeric(nrow(R)) |
| 206 | ! |
EPC.uni <- numeric(nrow(R)) # ignored in release= mode |
| 207 | ! |
for (r in r.idx) {
|
| 208 | ! |
R1 <- R[-r, , drop = FALSE] |
| 209 | ! |
Z1 <- cbind( |
| 210 | ! |
rbind(Information, R1), |
| 211 | ! |
rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) |
| 212 |
) |
|
| 213 | ! |
Z1.plus <- MASS::ginv(Z1) |
| 214 | ! |
Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)] |
| 215 | ! |
TS[r] <- as.numeric(N * t(score) %*% Z1.plus1 %*% score) |
| 216 | ! |
if (epc && !is.null(add)) {
|
| 217 |
# EPC.uni[r] <- -1 * utils::tail(as.numeric(score %*% Z1.plus1), |
|
| 218 |
# n = nrow(R))[r] |
|
| 219 |
# to keep the 'sign' consistent with modindices(), which |
|
| 220 |
# uses epc = 'new - old' |
|
| 221 | ! |
EPC.uni[r] <- +1 * utils::tail(as.numeric(score %*% Z1.plus1), |
| 222 | ! |
n = nrow(R) |
| 223 | ! |
)[r] |
| 224 |
} |
|
| 225 |
} |
|
| 226 | ||
| 227 | ! |
Table2 <- Table |
| 228 | ! |
Table2$X2 <- TS[r.idx] |
| 229 | ! |
Table2$df <- rep(1, length(r.idx)) |
| 230 | ! |
Table2$p.value <- 1 - pchisq(Table2$X2, df = Table2$df) |
| 231 | ! |
if (epc && !is.null(add)) {
|
| 232 | ! |
Table2$epc <- EPC.uni[r.idx] |
| 233 |
} |
|
| 234 | ! |
attr(Table2, "header") <- "univariate score tests:" |
| 235 | ! |
OUT$uni <- Table2 |
| 236 |
} |
|
| 237 | ||
| 238 | ! |
if (cumulative) {
|
| 239 | ! |
TS.order <- sort.int(TS, index.return = TRUE, decreasing = TRUE)$ix |
| 240 | ! |
ROW.order <- sort.int(TS[r.idx], index.return = TRUE, decreasing = TRUE)$ix |
| 241 | ! |
TS <- numeric(length(r.idx)) |
| 242 | ! |
for (r in 1:length(r.idx)) {
|
| 243 | ! |
rcumul.idx <- TS.order[1:r] |
| 244 | ||
| 245 | ! |
R1 <- R[-rcumul.idx, , drop = FALSE] |
| 246 | ! |
Z1 <- cbind( |
| 247 | ! |
rbind(Information, R1), |
| 248 | ! |
rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) |
| 249 |
) |
|
| 250 | ! |
Z1.plus <- MASS::ginv(Z1) |
| 251 | ! |
Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)] |
| 252 | ! |
TS[r] <- as.numeric(N * t(score) %*% Z1.plus1 %*% score) |
| 253 |
} |
|
| 254 | ||
| 255 | ! |
Table3 <- Table[ROW.order, ] |
| 256 | ! |
Table3$X2 <- TS |
| 257 | ! |
Table3$df <- seq_len(length(TS)) |
| 258 | ! |
Table3$p.value <- 1 - pchisq(Table3$X2, df = Table3$df) |
| 259 | ! |
attr(Table3, "header") <- "cumulative score tests:" |
| 260 | ! |
OUT$cumulative <- Table3 |
| 261 |
} |
|
| 262 | ||
| 263 | ! |
if (epc) {
|
| 264 |
# EPC <- vector("list", length = length(r.idx))
|
|
| 265 |
# for(i in 1:length(r.idx)) {
|
|
| 266 |
# r <- r.idx[i] |
|
| 267 |
# R1 <- R[-r,,drop = FALSE] |
|
| 268 |
# Z1 <- cbind( rbind(Information, R1), |
|
| 269 |
# rbind(t(R1), matrix(0,nrow(R1),nrow(R1))) ) |
|
| 270 |
# Z1.plus <- MASS::ginv(Z1) |
|
| 271 |
# Z1.plus1 <- Z1.plus[ 1:nrow(Information), 1:nrow(Information) ] |
|
| 272 |
# EPC[[i]] <- -1 * as.numeric(score %*% Z1.plus1) |
|
| 273 |
# } |
|
| 274 |
# |
|
| 275 |
# OUT$EPC <- EPC |
|
| 276 | ||
| 277 |
# alltogether |
|
| 278 | ! |
R1 <- R[-r.idx, , drop = FALSE] |
| 279 | ! |
Z1 <- cbind( |
| 280 | ! |
rbind(Information, R1), |
| 281 | ! |
rbind(t(R1), matrix(0, nrow(R1), nrow(R1))) |
| 282 |
) |
|
| 283 | ! |
Z1.plus <- MASS::ginv(Z1) |
| 284 | ! |
Z1.plus1 <- Z1.plus[1:nrow(Information), 1:nrow(Information)] |
| 285 |
# EPC.all <- -1 * as.numeric(score %*% Z1.plus1) |
|
| 286 |
# to keep the 'sign' consistent with modindices(), which |
|
| 287 |
# uses epc = 'new - old' |
|
| 288 | ! |
EPC.all <- +1 * as.numeric(score %*% Z1.plus1) |
| 289 | ||
| 290 |
# create epc table for the 'free' parameters |
|
| 291 | ! |
if (!is.null(add) && all(nchar(add) > 0L)) {
|
| 292 | ! |
LIST <- parTable(FIT) |
| 293 |
} else {
|
|
| 294 |
## release mode |
|
| 295 | ! |
LIST <- parTable(object) |
| 296 |
} |
|
| 297 | ! |
if (lav_partable_ngroups(LIST) == 1L) {
|
| 298 | ! |
LIST$group <- NULL |
| 299 |
} |
|
| 300 | ! |
nonpar.idx <- which(LIST$op %in% c("==", ":=", "<", ">"))
|
| 301 | ! |
if (length(nonpar.idx) > 0L) {
|
| 302 | ! |
LIST <- LIST[-nonpar.idx, ] |
| 303 |
} |
|
| 304 | ||
| 305 | ! |
LIST$est[LIST$free > 0 & LIST$user != 10] <- lav_object_inspect_coef(object, type = "free") |
| 306 | ! |
LIST$est[LIST$user == 10L] <- 0 |
| 307 | ! |
LIST$epc <- rep(as.numeric(NA), length(LIST$lhs)) |
| 308 | ! |
LIST$epc[LIST$free > 0] <- EPC.all |
| 309 | ! |
LIST$epv <- LIST$est + LIST$epc |
| 310 | ||
| 311 | ! |
if (standardized) {
|
| 312 | ! |
EPC <- LIST$epc |
| 313 | ||
| 314 | ! |
if (cov.std) {
|
| 315 |
# replace epc values for variances by est values |
|
| 316 | ! |
var.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs & |
| 317 | ! |
LIST$exo == 0L) |
| 318 | ! |
EPC[var.idx] <- LIST$est[var.idx] |
| 319 |
} |
|
| 320 | ||
| 321 |
# two problems: |
|
| 322 |
# - EPC of variances can be negative, and that is |
|
| 323 |
# perfectly legal |
|
| 324 |
# - EPC (of variances) can be tiny (near-zero), and we should |
|
| 325 |
# not divide by tiny variables |
|
| 326 | ! |
small.idx <- which(LIST$op == "~~" & |
| 327 | ! |
LIST$lhs == LIST$rhs & |
| 328 | ! |
abs(EPC) < sqrt(.Machine$double.eps)) |
| 329 | ! |
if (length(small.idx) > 0L) {
|
| 330 | ! |
EPC[small.idx] <- as.numeric(NA) |
| 331 |
} |
|
| 332 | ||
| 333 |
# get the sign |
|
| 334 | ! |
EPC.sign <- sign(LIST$epc) |
| 335 | ||
| 336 | ! |
LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object, |
| 337 | ! |
partable = LIST, |
| 338 | ! |
est = abs(EPC), |
| 339 | ! |
cov.std = cov.std |
| 340 |
) |
|
| 341 | ! |
if (length(small.idx) > 0L) {
|
| 342 | ! |
LIST$sepc.lv[small.idx] <- 0 |
| 343 |
} |
|
| 344 | ! |
LIST$sepc.all <- EPC.sign * lav_standardize_all(object, |
| 345 | ! |
partable = LIST, |
| 346 | ! |
est = abs(EPC), |
| 347 | ! |
cov.std = cov.std |
| 348 |
) |
|
| 349 | ! |
if (length(small.idx) > 0L) {
|
| 350 | ! |
LIST$sepc.all[small.idx] <- 0 |
| 351 |
} |
|
| 352 | ! |
LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object, |
| 353 | ! |
partable = LIST, |
| 354 | ! |
est = abs(EPC), |
| 355 | ! |
cov.std = cov.std |
| 356 |
) |
|
| 357 | ! |
if (length(small.idx) > 0L) {
|
| 358 | ! |
LIST$sepc.nox[small.idx] <- 0 |
| 359 |
} |
|
| 360 |
} |
|
| 361 | ||
| 362 | ! |
LIST$free[LIST$user == 10L] <- 0 |
| 363 | ! |
LIST$user <- NULL |
| 364 |
# remove some more columns |
|
| 365 | ! |
LIST$id <- LIST$ustart <- LIST$exo <- LIST$start <- LIST$se <- LIST$prior <- NULL |
| 366 | ! |
if (lav_partable_nblocks(LIST) == 1L) {
|
| 367 | ! |
LIST$block <- NULL |
| 368 | ! |
LIST$group <- NULL |
| 369 | ! |
LIST$level <- NULL |
| 370 |
} |
|
| 371 | ||
| 372 | ! |
attr(LIST, "header") <- "expected parameter changes (epc) and expected parameter values (epv):" |
| 373 | ||
| 374 | ! |
OUT$epc <- LIST |
| 375 |
} |
|
| 376 | ||
| 377 | ! |
OUT |
| 378 |
} |
| 1 |
# fitting function for standard ML |
|
| 2 |
lav_model_objective_ml <- function(Sigma.hat = NULL, Mu.hat = NULL, |
|
| 3 |
data.cov = NULL, data.mean = NULL, |
|
| 4 |
data.cov.log.det = NULL, |
|
| 5 |
meanstructure = FALSE) {
|
|
| 6 |
# FIXME: WHAT IS THE BEST THING TO DO HERE?? |
|
| 7 |
# CURRENTLY: return Inf (at least for nlminb, this works well) |
|
| 8 | 1587x |
if (!attr(Sigma.hat, "po")) {
|
| 9 | 12x |
return(Inf) |
| 10 |
} |
|
| 11 | ||
| 12 | ||
| 13 | 1575x |
Sigma.hat.inv <- attr(Sigma.hat, "inv") |
| 14 | 1575x |
Sigma.hat.log.det <- attr(Sigma.hat, "log.det") |
| 15 | 1575x |
nvar <- ncol(Sigma.hat) |
| 16 | ||
| 17 | 1575x |
if (!meanstructure) {
|
| 18 | 761x |
fx <- (Sigma.hat.log.det + sum(data.cov * Sigma.hat.inv) - |
| 19 | 761x |
data.cov.log.det - nvar) |
| 20 |
} else {
|
|
| 21 | 814x |
W.tilde <- data.cov + tcrossprod(data.mean - Mu.hat) |
| 22 | 814x |
fx <- (Sigma.hat.log.det + sum(W.tilde * Sigma.hat.inv) - |
| 23 | 814x |
data.cov.log.det - nvar) |
| 24 |
} |
|
| 25 | ||
| 26 |
# no negative values |
|
| 27 | 24x |
if (is.finite(fx) && fx < 0.0) fx <- 0.0 |
| 28 | ||
| 29 | 1575x |
fx |
| 30 |
} |
|
| 31 | ||
| 32 |
# fitting function for standard ML |
|
| 33 |
lav_model_objective_ml_res <- function(Sigma.hat = NULL, Mu.hat = NULL, PI = NULL, |
|
| 34 |
res.cov = NULL, res.int = NULL, res.slopes = NULL, |
|
| 35 |
res.cov.log.det = NULL, |
|
| 36 |
cov.x = NULL, mean.x = NULL) {
|
|
| 37 | ! |
if (!attr(Sigma.hat, "po")) {
|
| 38 | ! |
return(Inf) |
| 39 |
} |
|
| 40 | ||
| 41 |
# augmented mean.x + cov.x matrix |
|
| 42 | ! |
C3 <- rbind( |
| 43 | ! |
c(1, mean.x), |
| 44 | ! |
cbind(mean.x, cov.x + tcrossprod(mean.x)) |
| 45 |
) |
|
| 46 | ||
| 47 | ! |
Sigma.hat.inv <- attr(Sigma.hat, "inv") |
| 48 | ! |
Sigma.hat.log.det <- attr(Sigma.hat, "log.det") |
| 49 | ! |
nvar <- ncol(Sigma.hat) |
| 50 | ||
| 51 |
# sigma |
|
| 52 | ! |
objective.sigma <- (Sigma.hat.log.det + sum(res.cov * Sigma.hat.inv) - |
| 53 | ! |
res.cov.log.det - nvar) |
| 54 |
# beta |
|
| 55 | ! |
OBS <- t(cbind(res.int, res.slopes)) |
| 56 | ! |
EST <- t(cbind(Mu.hat, PI)) |
| 57 | ! |
Diff <- OBS - EST |
| 58 | ! |
objective.beta <- sum(Sigma.hat.inv * crossprod(Diff, C3) %*% Diff) |
| 59 | ||
| 60 | ! |
fx <- objective.sigma + objective.beta |
| 61 | ||
| 62 |
# no negative values |
|
| 63 | ! |
if (is.finite(fx) && fx < 0.0) fx <- 0.0 |
| 64 | ||
| 65 | ! |
fx |
| 66 |
} |
|
| 67 | ||
| 68 | ||
| 69 |
# fitting function for restricted ML |
|
| 70 |
lav_model_objective_reml <- function(Sigma.hat = NULL, Mu.hat = NULL, |
|
| 71 |
data.cov = NULL, data.mean = NULL, |
|
| 72 |
data.cov.log.det = NULL, |
|
| 73 |
meanstructure = FALSE, |
|
| 74 |
group = 1L, lavmodel = NULL, |
|
| 75 |
lavsamplestats = NULL, lavdata = NULL) {
|
|
| 76 | ! |
if (!attr(Sigma.hat, "po")) {
|
| 77 | ! |
return(Inf) |
| 78 |
} |
|
| 79 | ||
| 80 | ! |
Sigma.hat.inv <- attr(Sigma.hat, "inv") |
| 81 | ! |
Sigma.hat.log.det <- attr(Sigma.hat, "log.det") |
| 82 | ! |
nvar <- ncol(Sigma.hat) |
| 83 | ||
| 84 | ! |
if (!meanstructure) {
|
| 85 | ! |
fx <- (Sigma.hat.log.det + sum(data.cov * Sigma.hat.inv) - |
| 86 | ! |
data.cov.log.det - nvar) |
| 87 |
} else {
|
|
| 88 | ! |
W.tilde <- data.cov + tcrossprod(data.mean - Mu.hat) |
| 89 | ! |
fx <- (Sigma.hat.log.det + sum(W.tilde * Sigma.hat.inv) - |
| 90 | ! |
data.cov.log.det - nvar) |
| 91 |
} |
|
| 92 | ||
| 93 | ! |
lambda.idx <- which(names(lavmodel@GLIST) == "lambda") |
| 94 | ! |
LAMBDA <- lavmodel@GLIST[[lambda.idx[group]]] |
| 95 | ! |
data.cov.inv <- lavsamplestats@icov[[group]] |
| 96 | ! |
reml.h0 <- log(det(t(LAMBDA) %*% Sigma.hat.inv %*% LAMBDA)) |
| 97 | ! |
reml.h1 <- log(det(t(LAMBDA) %*% data.cov.inv %*% LAMBDA)) |
| 98 | ! |
nobs <- lavsamplestats@nobs[[group]] |
| 99 | ||
| 100 |
# fx <- (Sigma.hat.log.det + tmp - data.cov.log.det - nvar) + 1/Ng * (reml.h0 - reml.h1) |
|
| 101 | ! |
fx <- fx + (1 / nobs * (reml.h0 - reml.h1)) |
| 102 | ||
| 103 |
# no negative values |
|
| 104 | ! |
if (is.finite(fx) && fx < 0.0) fx <- 0.0 |
| 105 | ||
| 106 | ! |
fx |
| 107 |
} |
|
| 108 | ||
| 109 |
# 'classic' fitting function for GLS |
|
| 110 |
# used again since 0.6-10 (we used the much slower lav_model_objective_wls before) |
|
| 111 |
lav_model_objective_gls <- function(Sigma.hat = NULL, Mu.hat = NULL, |
|
| 112 |
data.cov = NULL, data.cov.inv = NULL, |
|
| 113 |
data.mean = NULL, |
|
| 114 |
meanstructure = FALSE, correlation = FALSE) {
|
|
| 115 | 416x |
tmp <- data.cov.inv %*% (data.cov - Sigma.hat) |
| 116 |
# tmp is not perfectly symmetric, so we use t(tmp) on the next line |
|
| 117 |
# to obtain the same value as lav_model_objective_wls |
|
| 118 | 416x |
fx <- 0.5 * sum(tmp * t(tmp)) |
| 119 | ||
| 120 | 416x |
if (correlation) {
|
| 121 |
# Bentler & Savalei (2010) eq 1.31 |
|
| 122 | ! |
DD <- as.matrix(diag(tmp)) |
| 123 | ! |
TT <- diag(nrow(data.cov)) + data.cov * data.cov.inv |
| 124 | ! |
fx <- fx - drop(t(DD) %*% solve(TT) %*% DD) |
| 125 |
} |
|
| 126 | ||
| 127 | 416x |
if (meanstructure) {
|
| 128 | 112x |
tmp2 <- sum(data.cov.inv * tcrossprod(data.mean - Mu.hat)) |
| 129 | 112x |
fx <- fx + tmp2 |
| 130 |
} |
|
| 131 | ||
| 132 |
# no negative values |
|
| 133 | ! |
if (is.finite(fx) && fx < 0.0) fx <- 0.0 |
| 134 | ||
| 135 | 416x |
fx |
| 136 |
} |
|
| 137 | ||
| 138 |
# general WLS estimator (Muthen, Appendix 4, eq 99 single group) |
|
| 139 |
# full weight (WLS.V) matrix |
|
| 140 |
lav_model_objective_wls <- function(WLS.est = NULL, WLS.obs = NULL, WLS.V = NULL) {
|
|
| 141 |
# diff <- as.matrix(WLS.obs - WLS.est) |
|
| 142 |
# fx <- as.numeric( t(diff) %*% WLS.V %*% diff ) |
|
| 143 | ||
| 144 |
# since 0.5-17, we use crossprod twice |
|
| 145 | 396x |
diff <- WLS.obs - WLS.est |
| 146 | 396x |
fx <- as.numeric(crossprod(crossprod(WLS.V, diff), diff)) |
| 147 |
# todo alternative: using chol(WLS.V) |
|
| 148 | ||
| 149 |
# no negative values |
|
| 150 | ! |
if (is.finite(fx) && fx < 0.0) fx <- 0.0 |
| 151 | ||
| 152 | 396x |
fx |
| 153 |
} |
|
| 154 | ||
| 155 |
# diagonally weighted LS (DWLS) |
|
| 156 |
lav_model_objective_dwls <- function(WLS.est = NULL, WLS.obs = NULL, WLS.VD = NULL) {
|
|
| 157 | 3098x |
diff <- WLS.obs - WLS.est |
| 158 | 3098x |
fx <- sum(diff * diff * WLS.VD) |
| 159 | ||
| 160 |
# no negative values |
|
| 161 | ! |
if (is.finite(fx) && fx < 0.0) fx <- 0.0 |
| 162 | ||
| 163 | 3098x |
fx |
| 164 |
} |
|
| 165 | ||
| 166 |
# Full Information ML estimator (FIML) handling the missing values |
|
| 167 |
lav_model_objective_fiml <- function(Sigma.hat = NULL, Mu.hat = NULL, Yp = NULL, |
|
| 168 |
h1 = NULL, N = NULL) {
|
|
| 169 | 636x |
if (is.null(N)) {
|
| 170 | ! |
N <- sum(sapply(Yp, "[[", "freq")) |
| 171 |
} |
|
| 172 | ||
| 173 |
# Note: we ignore x.idx (if any) |
|
| 174 | 636x |
fx <- lav_mvnorm_missing_loglik_samplestats( |
| 175 | 636x |
Yp = Yp, |
| 176 | 636x |
Mu = Mu.hat, Sigma = Sigma.hat, |
| 177 | 636x |
log2pi = FALSE, |
| 178 | 636x |
minus.two = TRUE |
| 179 | 636x |
) / N |
| 180 | ||
| 181 |
# ajust for h1 |
|
| 182 | 636x |
if (!is.null(h1)) {
|
| 183 | 636x |
fx <- fx - h1 |
| 184 | ||
| 185 |
# no negative values |
|
| 186 | 6x |
if (is.finite(fx) && fx < 0.0) fx <- 0.0 |
| 187 |
} |
|
| 188 | ||
| 189 | 636x |
fx |
| 190 |
} |
|
| 191 | ||
| 192 |
# pairwise maximum likelihood |
|
| 193 |
# this is adapted from code written by Myrsini Katsikatsou |
|
| 194 |
# |
|
| 195 |
# some changes: |
|
| 196 |
# - no distinction between x/y (ksi/eta) |
|
| 197 |
# - 29/03/2016: adapt for exogenous covariates |
|
| 198 |
# - 21/09/2016: added code for missing = doubly.robust (contributed by |
|
| 199 |
# Myrsini Katsikatsou) |
|
| 200 |
# - HJ 18/10/2023: For sampling weights the lavcache$bifreq are weighted |
|
| 201 |
lav_model_objective_pml <- function(Sigma.hat = NULL, # model-based var/cov/cor |
|
| 202 |
Mu.hat = NULL, # model-based means |
|
| 203 |
TH = NULL, # model-based thresholds + means |
|
| 204 |
PI = NULL, # slopes |
|
| 205 |
th.idx = NULL, # threshold idx per variable |
|
| 206 |
num.idx = NULL, # which variables are numeric |
|
| 207 |
X = NULL, # raw data |
|
| 208 |
eXo = NULL, # eXo data |
|
| 209 |
wt = NULL, # case weights |
|
| 210 |
lavcache = NULL, # housekeeping stuff |
|
| 211 |
missing = NULL) { # how to deal with missings?
|
|
| 212 | ||
| 213 |
# YR 3 okt 2012 |
|
| 214 |
# - the idea is to compute for each pair of variables, the model-based |
|
| 215 |
# probability (or likelihood in mixed case) (that we observe the data |
|
| 216 |
# for this pair under the model) |
|
| 217 |
# - if we have exogenous variables + conditional.x, do this for each case |
|
| 218 |
# - after taking logs, the sum over the cases gives the |
|
| 219 |
# log probablity/likelihood for this pair |
|
| 220 |
# - the sum over all pairs gives the final PL based logl |
|
| 221 | ||
| 222 |
# first of all: check if all correlations are within [-1,1] |
|
| 223 |
# if not, return Inf; (at least with nlminb, this works well) |
|
| 224 | ||
| 225 |
# diagonal of Sigma.hat is not necessarily 1, even for categorical vars |
|
| 226 | ! |
Sigma.hat2 <- Sigma.hat |
| 227 | ! |
if (length(num.idx) > 0L) {
|
| 228 | ! |
diag(Sigma.hat2)[-num.idx] <- 1 |
| 229 |
} else {
|
|
| 230 | ! |
diag(Sigma.hat2) <- 1 |
| 231 |
} |
|
| 232 |
# all positive variances? (for continuous variables) |
|
| 233 | ! |
if (any(diag(Sigma.hat2) < 0)) {
|
| 234 | ! |
OUT <- +Inf |
| 235 | ! |
attr(OUT, "logl") <- as.numeric(NA) |
| 236 | ! |
return(OUT) |
| 237 |
} |
|
| 238 | ! |
Cor.hat <- cov2cor(Sigma.hat2) # to get correlations (rho!) |
| 239 | ! |
cors <- lav_matrix_vech(Cor.hat, diagonal = FALSE) |
| 240 | ||
| 241 | ! |
if (length(cors) > 0L && (any(abs(cors) > 1) || |
| 242 | ! |
any(is.na(cors)))) {
|
| 243 |
# question: what is the best approach here?? |
|
| 244 | ! |
OUT <- +Inf |
| 245 | ! |
attr(OUT, "logl") <- as.numeric(NA) |
| 246 | ! |
return(OUT) |
| 247 |
} |
|
| 248 | ||
| 249 | ! |
nvar <- nrow(Sigma.hat) |
| 250 | ! |
if (is.null(eXo)) {
|
| 251 | ! |
nexo <- 0L |
| 252 |
} else {
|
|
| 253 | ! |
nexo <- NCOL(eXo) |
| 254 |
} |
|
| 255 | ! |
pstar <- nvar * (nvar - 1) / 2 |
| 256 | ! |
ov.types <- rep("ordered", nvar)
|
| 257 | ! |
if (length(num.idx) > 0L) {
|
| 258 | ! |
ov.types[num.idx] <- "numeric" |
| 259 |
} |
|
| 260 | ||
| 261 | ||
| 262 |
##### Three cases: |
|
| 263 |
##### 1) all ordered, no exogenous (fast!) |
|
| 264 |
##### 2) mixed ordered + continuous, no exogenous |
|
| 265 |
##### 3) mixed ordered + continuous, exogenous (conditional.x = TRUE) |
|
| 266 | ||
| 267 | ||
| 268 | ||
| 269 | ||
| 270 |
##### Case 1: |
|
| 271 |
##### all ordered |
|
| 272 |
##### no exogenous covariates |
|
| 273 |
##### |
|
| 274 | ! |
if (all(ov.types == "ordered") && nexo == 0L) {
|
| 275 |
# prepare for Myrsini's vectorization scheme |
|
| 276 | ! |
long2 <- lav_pml_longvec_th_rho( |
| 277 | ! |
no.x = nvar, |
| 278 | ! |
all.thres = TH, |
| 279 | ! |
index.var.of.thres = th.idx, |
| 280 | ! |
rho.xixj = cors |
| 281 |
) |
|
| 282 |
# get expected probability per table, per pair |
|
| 283 | ! |
pairwisePI <- lav_pml_expprob_vec( |
| 284 | ! |
ind.vec = lavcache$long, |
| 285 | ! |
th.rho.vec = long2 |
| 286 |
) |
|
| 287 | ! |
pairwisePI_orig <- pairwisePI # for doubly.robust |
| 288 | ||
| 289 |
# get frequency per table, per pair |
|
| 290 | ! |
logl <- sum(lavcache$bifreq * log(pairwisePI)) |
| 291 | ||
| 292 |
# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 293 | ||
| 294 |
# FYI the bifreq are already weighted so this will work. Alternatively: |
|
| 295 | ! |
if (!is.null(wt)) {
|
| 296 | ! |
logl <- sum(lavcache$sum_obs_weights_xixj_ab_vec * log(pairwisePI)) |
| 297 |
} |
|
| 298 | ||
| 299 |
# more convenient fit function |
|
| 300 | ! |
prop <- lavcache$bifreq / lavcache$nobs |
| 301 | ! |
freq <- lavcache$bifreq |
| 302 | ! |
if (!is.null(wt)) {
|
| 303 | ! |
prop <- lavcache$sum_obs_weights_xixj_ab_vec / sum(wt) |
| 304 | ! |
freq <- lavcache$sum_obs_weights_xixj_ab_vec |
| 305 |
} |
|
| 306 | ||
| 307 |
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 308 | ||
| 309 |
# remove zero props # FIXME!!! or add 0.5??? |
|
| 310 |
# zero.idx <- which(prop == 0.0) |
|
| 311 | ! |
zero.idx <- which((prop == 0.0) | !is.finite(prop)) |
| 312 | ! |
if (length(zero.idx) > 0L) {
|
| 313 | ! |
freq <- freq[-zero.idx] |
| 314 | ! |
prop <- prop[-zero.idx] |
| 315 | ! |
pairwisePI <- pairwisePI[-zero.idx] |
| 316 |
} |
|
| 317 |
## Fmin <- sum( prop*log(prop/pairwisePI) ) |
|
| 318 | ! |
Fmin <- sum(freq * log(prop / pairwisePI)) # to avoid 'N' |
| 319 | ||
| 320 | ! |
if (missing == "available.cases" || missing == "doubly.robust") {
|
| 321 | ! |
uniPI <- lav_pml_th_uni_prob(TH = TH, th.idx = th.idx) |
| 322 | ||
| 323 |
# shortcuts |
|
| 324 | ! |
unifreq <- lavcache$unifreq |
| 325 | ! |
uninobs <- lavcache$uninobs |
| 326 | ! |
uniweights <- lavcache$uniweights |
| 327 | ||
| 328 | ! |
logl <- logl + sum(uniweights * log(uniPI)) |
| 329 | ||
| 330 | ! |
uniprop <- unifreq / uninobs |
| 331 | ||
| 332 |
# remove zero props |
|
| 333 |
# uni.zero.idx <- which(uniprop == 0.0) |
|
| 334 | ! |
uni.zero.idx <- which((uniprop == 0.0) | !is.finite(uniprop)) |
| 335 | ! |
if (length(uni.zero.idx) > 0L) {
|
| 336 | ! |
uniprop <- uniprop[-uni.zero.idx] |
| 337 | ! |
uniPI <- uniPI[-uni.zero.idx] |
| 338 | ! |
uniweights <- uniweights[-uni.zero.idx] |
| 339 |
} |
|
| 340 | ||
| 341 | ! |
Fmin <- Fmin + sum(uniweights * log(uniprop / uniPI)) |
| 342 |
} |
|
| 343 | ||
| 344 | ! |
if (missing == "doubly.robust") {
|
| 345 |
# COMPUTE THE SUM OF THE EXPECTED BIVARIATE CONDITIONAL LIKELIHOODS |
|
| 346 |
# SUM_{i,j} [ E_{Yi,Yj|y^o}(lnf(Yi,Yj))) ]
|
|
| 347 | ||
| 348 |
# First compute the terms of the summand. Since the cells of |
|
| 349 |
# pairwiseProbGivObs are zero for the pairs of variables that at least |
|
| 350 |
# one of the variables is observed (hence not contributing to the summand) |
|
| 351 |
# there is no need to construct an index vector for summing appropriately |
|
| 352 |
# within each individual. |
|
| 353 | ! |
log_pairwisePI_orig <- log(pairwisePI_orig) |
| 354 | ! |
pairwiseProbGivObs <- lavcache$pairwiseProbGivObs |
| 355 | ! |
tmp_prod <- t(t(pairwiseProbGivObs) * log_pairwisePI_orig) |
| 356 | ||
| 357 | ! |
SumElnfijCasewise <- apply(tmp_prod, 1, sum) |
| 358 | ! |
SumElnfij <- sum(SumElnfijCasewise) |
| 359 | ! |
logl <- logl + SumElnfij |
| 360 | ! |
Fmin <- Fmin - SumElnfij |
| 361 | ||
| 362 |
# COMPUTE THE THE SUM OF THE EXPECTED UNIVARIATE CONDITIONAL LIKELIHOODS |
|
| 363 |
# SUM_{i,j} [ E_{Yj|y^o}(lnf(Yj|yi))) ]
|
|
| 364 | ||
| 365 |
# First compute the model-implied conditional univariate probabilities |
|
| 366 |
# p(y_i=a|y_j=b). Let ModProbY1Gy2 be the vector of these |
|
| 367 |
# probabilities. The order the probabilities |
|
| 368 |
# are listed in the vector ModProbY1Gy2 is as follows: |
|
| 369 |
# y1|y2, y1|y3, ..., y1|yp, y2|y1, y2|y3, ..., y2|yp, |
|
| 370 |
# ..., yp|y1, yp|y2, ..., yp|y(p-1). Within each pair of variables the |
|
| 371 |
# index "a" which represents the response category of variable yi runs faster than |
|
| 372 |
# "b" which represents the response category of the given variable yj. |
|
| 373 |
# The computation of these probabilities are based on the model-implied |
|
| 374 |
# bivariate probabilities p(y_i=a,y_j=b). To do the appropriate summations |
|
| 375 |
# and divisions we need some index vectors to keep track of the index i, j, |
|
| 376 |
# a, and b, as well as the pair index. These index vectors should be |
|
| 377 |
# computed once and stored in lavcache. About where in the lavaan code |
|
| 378 |
# we will add the computations and how they will be done please see the |
|
| 379 |
# file "new objects in lavcache for DR-PL.r" |
|
| 380 | ||
| 381 | ! |
idx.pairs <- lavcache$idx.pairs |
| 382 | ! |
idx.cat.y2.split <- lavcache$idx.cat.y2.split |
| 383 | ! |
idx.cat.y1.split <- lavcache$idx.cat.y1.split |
| 384 | ! |
idx.Y1 <- lavcache$idx.Y1 |
| 385 | ! |
idx.Gy2 <- lavcache$idx.Gy2 |
| 386 | ! |
idx.cat.Y1 <- lavcache$idx.cat.Y1 |
| 387 | ! |
idx.cat.Gy2 <- lavcache$idx.cat.Gy2 |
| 388 | ! |
id.uniPrGivObs <- lavcache$id.uniPrGivObs |
| 389 |
# the latter keeps track which variable each column of the matrix |
|
| 390 |
# univariateProbGivObs refers to |
|
| 391 | ||
| 392 |
# For the function lav_pml_bivprob_unicondprob see the .r file |
|
| 393 |
# with the same name. |
|
| 394 | ! |
ModProbY1Gy2 <- lav_pml_bivprob_unicondprob( |
| 395 | ! |
bivProb = pairwisePI_orig, |
| 396 | ! |
nvar = nvar, |
| 397 | ! |
idx.pairs = idx.pairs, |
| 398 | ! |
idx.Y1 = idx.Y1, |
| 399 | ! |
idx.Gy2 = idx.Gy2, |
| 400 | ! |
idx.cat.y1.split = idx.cat.y1.split, |
| 401 | ! |
idx.cat.y2.split = idx.cat.y2.split |
| 402 |
) |
|
| 403 | ||
| 404 | ! |
log_ModProbY1Gy2 <- log(ModProbY1Gy2) |
| 405 | ||
| 406 |
# Let univariateProbGivObs be the matrix of the conditional univariate |
|
| 407 |
# probabilities Pr(y_i=a|y^o) that has been computed in advance and are |
|
| 408 |
# fed to the DR-PL function. The rows represent different individuals, |
|
| 409 |
# i.e. nrow=nobs, and the columns different probabilities. The columns |
|
| 410 |
# are listed as follows: a runs faster than i. |
|
| 411 | ||
| 412 |
# Note that the number of columns of univariateProbGivObs is not the |
|
| 413 |
# same with the length(log_ModProbY1Gy2), actually |
|
| 414 |
# ncol(univariateProbGivObs) < length(log_ModProbY1Gy2). |
|
| 415 |
# For this we use the following commands in order to multiply correctly. |
|
| 416 | ||
| 417 |
# Compute for each case the product Pr(y_i=a|y^o) * log[ p(y_i=a|y_j=b) ] |
|
| 418 |
# i.e. univariateProbGivObs * log_ModProbY1Gy2 |
|
| 419 | ! |
univariateProbGivObs <- lavcache$univariateProbGivObs |
| 420 | ! |
nobs <- nrow(X) |
| 421 | ! |
uniweights.casewise <- lavcache$uniweights.casewise |
| 422 | ! |
id.cases.with.missing <- which(uniweights.casewise > 0) |
| 423 | ! |
no.cases.with.missing <- length(id.cases.with.missing) |
| 424 | ! |
no.obs.casewise <- nvar - uniweights.casewise |
| 425 | ! |
idx.missing.var <- apply(X, 1, function(x) {
|
| 426 | ! |
which(is.na(x)) |
| 427 |
}) |
|
| 428 | ! |
idx.observed.var <- lapply(idx.missing.var, function(x) {
|
| 429 | ! |
c(1:nvar)[-x] |
| 430 |
}) |
|
| 431 | ! |
idx.cat.observed.var <- sapply(1:nobs, function(i) {
|
| 432 | ! |
X[i, idx.observed.var[[i]]] |
| 433 |
}) |
|
| 434 | ! |
ElnyiGivyjbCasewise <- sapply(1:no.cases.with.missing, function(i) {
|
| 435 | ! |
tmp.id.case <- id.cases.with.missing[i] |
| 436 | ! |
tmp.no.mis <- uniweights.casewise[tmp.id.case] |
| 437 | ! |
tmp.idx.mis <- idx.missing.var[[tmp.id.case]] |
| 438 | ! |
tmp.idx.obs <- idx.observed.var[[tmp.id.case]] |
| 439 | ! |
tmp.no.obs <- no.obs.casewise[tmp.id.case] |
| 440 | ! |
tmp.idx.cat.obs <- idx.cat.observed.var[[tmp.id.case]] |
| 441 | ! |
tmp.uniProbGivObs.i <- univariateProbGivObs[tmp.id.case, ] |
| 442 | ! |
sapply(1:tmp.no.mis, function(k) {
|
| 443 | ! |
tmp.idx.mis.var <- tmp.idx.mis[k] |
| 444 | ! |
tmp.uniProbGivObs.ik <- |
| 445 | ! |
tmp.uniProbGivObs.i[id.uniPrGivObs == tmp.idx.mis.var] |
| 446 | ! |
tmp.log_ModProbY1Gy2 <- sapply(1:tmp.no.obs, function(z) {
|
| 447 | ! |
log_ModProbY1Gy2[idx.Y1 == tmp.idx.mis.var & |
| 448 | ! |
idx.Gy2 == tmp.idx.obs[z] & |
| 449 | ! |
idx.cat.Gy2 == tmp.idx.cat.obs[z]] |
| 450 |
}) |
|
| 451 | ! |
sum(tmp.log_ModProbY1Gy2 * tmp.uniProbGivObs.ik) |
| 452 |
}) |
|
| 453 |
}) |
|
| 454 | ! |
ElnyiGivyjb <- sum(unlist(ElnyiGivyjbCasewise)) |
| 455 | ! |
logl <- logl + ElnyiGivyjb |
| 456 |
# for the Fmin function |
|
| 457 | ! |
Fmin <- Fmin - ElnyiGivyjb |
| 458 |
} # end of if (missing =="doubly.robust") |
|
| 459 | ||
| 460 | ||
| 461 |
##### Case 2: |
|
| 462 |
##### mixed ordered + numeric |
|
| 463 |
##### no exogenous covariates |
|
| 464 |
##### |
|
| 465 | ! |
} else if (nexo == 0L) {
|
| 466 |
# mixed ordered/numeric variables, but no exogenous covariates |
|
| 467 |
# - no need to compute 'casewise' (log)likelihoods |
|
| 468 | ||
| 469 | ! |
PSTAR <- matrix(0, nvar, nvar) # utility matrix, to get indices |
| 470 | ! |
PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar |
| 471 | ! |
N <- NROW(X) |
| 472 | ||
| 473 | ! |
logLikPair <- numeric(pstar) # logl per pair (summed over cases) |
| 474 | ! |
for (j in seq_len(nvar - 1L)) {
|
| 475 | ! |
for (i in (j + 1L):nvar) {
|
| 476 | ! |
pstar.idx <- PSTAR[i, j] |
| 477 | ! |
if (ov.types[i] == "numeric" && |
| 478 | ! |
ov.types[j] == "numeric") {
|
| 479 | ! |
logLIK <- lav_mvnorm_loglik_data( |
| 480 | ! |
Y = X[, c(i, j)], wt = wt, Mu = Mu.hat[c(i, j)], |
| 481 | ! |
Sigma = Sigma.hat[c(i, j), c(i, j)], casewise = TRUE |
| 482 |
) |
|
| 483 | ! |
logLikPair[pstar.idx] <- sum(logLIK, na.rm = TRUE) |
| 484 | ! |
} else if (ov.types[i] == "numeric" && |
| 485 | ! |
ov.types[j] == "ordered") {
|
| 486 |
# polyserial correlation |
|
| 487 | ! |
logLIK <- lav_bvmix_lik( |
| 488 | ! |
Y1 = X[, i], Y2 = X[, j], |
| 489 | ! |
wt = wt, |
| 490 | ! |
evar.y1 = Sigma.hat[i, i], |
| 491 | ! |
beta.y1 = Mu.hat[i], |
| 492 | ! |
th.y2 = TH[th.idx == j], |
| 493 | ! |
rho = Cor.hat[i, j], .log = TRUE |
| 494 |
) |
|
| 495 | ! |
logLikPair[pstar.idx] <- sum(logLIK, na.rm = TRUE) |
| 496 | ! |
} else if (ov.types[j] == "numeric" && |
| 497 | ! |
ov.types[i] == "ordered") {
|
| 498 |
# polyserial correlation |
|
| 499 | ! |
logLIK <- lav_bvmix_lik( |
| 500 | ! |
Y1 = X[, j], Y2 = X[, i], |
| 501 | ! |
wt = wt, |
| 502 | ! |
evar.y1 = Sigma.hat[j, j], |
| 503 | ! |
beta.y1 = Mu.hat[j], |
| 504 | ! |
th.y2 = TH[th.idx == i], |
| 505 | ! |
rho = Cor.hat[i, j], .log = TRUE |
| 506 |
) |
|
| 507 | ! |
logLikPair[pstar.idx] <- sum(logLIK, na.rm = TRUE) |
| 508 | ! |
} else if (ov.types[i] == "ordered" && |
| 509 | ! |
ov.types[j] == "ordered") {
|
| 510 |
# polychoric correlation |
|
| 511 | ! |
pairwisePI <- lav_bvord_noexo_pi( |
| 512 | ! |
rho = Cor.hat[i, j], |
| 513 | ! |
th.y1 = TH[th.idx == i], |
| 514 | ! |
th.y2 = TH[th.idx == j] |
| 515 |
) |
|
| 516 |
# avoid zeroes |
|
| 517 | ! |
pairwisePI[pairwisePI < .Machine$double.eps] <- |
| 518 | ! |
.Machine$double.eps |
| 519 |
# note: missing values are just not counted |
|
| 520 | ! |
FREQ <- lav_bvord_freq(X[, i], X[, j], wt = wt) |
| 521 | ! |
logLikPair[pstar.idx] <- sum(FREQ * log(pairwisePI)) |
| 522 |
} |
|
| 523 |
} |
|
| 524 |
} # all pairs |
|
| 525 | ||
| 526 | ! |
na.idx <- which(is.na(logLikPair)) |
| 527 | ! |
if (length(na.idx) > 0L) {
|
| 528 | ! |
lav_msg_warn(gettext("some pairs produces NA values for logl:"),
|
| 529 | ! |
lav_msg_view(round(logLikPair, 3), "none") |
| 530 |
) |
|
| 531 |
} |
|
| 532 | ||
| 533 |
# sum over pairs |
|
| 534 | ! |
logl <- sum(logLikPair) |
| 535 | ||
| 536 |
# Fmin |
|
| 537 | ! |
Fmin <- (-1) * logl |
| 538 | ||
| 539 | ||
| 540 |
##### Case 3: |
|
| 541 |
##### mixed ordered + numeric |
|
| 542 |
##### exogenous covariates |
|
| 543 |
##### (conditional.x = TRUE) |
|
| 544 |
} else {
|
|
| 545 | ! |
LIK <- matrix(0, nrow(X), pstar) # likelihood per case, per pair |
| 546 | ! |
PSTAR <- matrix(0, nvar, nvar) # utility matrix, to get indices |
| 547 | ! |
PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar |
| 548 | ! |
N <- NROW(X) |
| 549 | ||
| 550 | ! |
for (j in seq_len(nvar - 1L)) {
|
| 551 | ! |
for (i in (j + 1L):nvar) {
|
| 552 | ! |
pstar.idx <- PSTAR[i, j] |
| 553 |
# cat("pstar.idx =", pstar.idx, "i = ", i, " j = ", j, "\n")
|
|
| 554 | ! |
if (ov.types[i] == "numeric" && |
| 555 | ! |
ov.types[j] == "numeric") {
|
| 556 |
# ordinary pearson correlation |
|
| 557 | ! |
LIK[, pstar.idx] <- |
| 558 | ! |
lav_bvreg_lik( |
| 559 | ! |
Y1 = X[, i], Y2 = X[, j], eXo = eXo, |
| 560 | ! |
wt = wt, |
| 561 | ! |
evar.y1 = Sigma.hat[i, i], |
| 562 | ! |
beta.y1 = c(Mu.hat[i], PI[i, ]), |
| 563 | ! |
evar.y2 = Sigma.hat[j, j], |
| 564 | ! |
beta.y2 = c(Mu.hat[j], PI[j, ]), |
| 565 | ! |
rho = Cor.hat[i, j] |
| 566 |
) |
|
| 567 | ! |
} else if (ov.types[i] == "numeric" && |
| 568 | ! |
ov.types[j] == "ordered") {
|
| 569 |
# polyserial correlation |
|
| 570 |
### FIXME: th.y2 should go into ps_lik!!! |
|
| 571 | ! |
LIK[, pstar.idx] <- |
| 572 | ! |
lav_bvmix_lik( |
| 573 | ! |
Y1 = X[, i], Y2 = X[, j], eXo = eXo, |
| 574 | ! |
wt = wt, |
| 575 | ! |
evar.y1 = Sigma.hat[i, i], |
| 576 | ! |
beta.y1 = c(Mu.hat[i], PI[i, ]), |
| 577 | ! |
th.y2 = TH[th.idx == j], |
| 578 | ! |
sl.y2 = PI[j, ], |
| 579 | ! |
rho = Cor.hat[i, j] |
| 580 |
) |
|
| 581 | ! |
} else if (ov.types[j] == "numeric" && |
| 582 | ! |
ov.types[i] == "ordered") {
|
| 583 |
# polyserial correlation |
|
| 584 |
### FIXME: th.y1 should go into ps_lik!!! |
|
| 585 | ! |
LIK[, pstar.idx] <- |
| 586 | ! |
lav_bvmix_lik( |
| 587 | ! |
Y1 = X[, j], Y2 = X[, i], eXo = eXo, |
| 588 | ! |
wt = wt, |
| 589 | ! |
evar.y1 = Sigma.hat[j, j], |
| 590 | ! |
beta.y1 = c(Mu.hat[j], PI[j, ]), |
| 591 | ! |
th.y2 = TH[th.idx == i], |
| 592 | ! |
sl.y2 = PI[i, ], |
| 593 | ! |
rho = Cor.hat[i, j] |
| 594 |
) |
|
| 595 | ! |
} else if (ov.types[i] == "ordered" && |
| 596 | ! |
ov.types[j] == "ordered") {
|
| 597 | ! |
LIK[, pstar.idx] <- |
| 598 | ! |
lav_pml_bi_lik_x( |
| 599 | ! |
Y1 = X[, i], |
| 600 | ! |
Y2 = X[, j], |
| 601 | ! |
Rho = Sigma.hat[i, j], |
| 602 | ! |
th.y1 = TH[th.idx == i], |
| 603 | ! |
th.y2 = TH[th.idx == j], |
| 604 | ! |
eXo = eXo, |
| 605 | ! |
PI.y1 = PI[i, ], |
| 606 | ! |
PI.y2 = PI[j, ], |
| 607 | ! |
missing.ind = missing |
| 608 |
) |
|
| 609 |
} |
|
| 610 |
} |
|
| 611 |
} # all pairs |
|
| 612 | ||
| 613 |
# check for zero likelihoods/probabilities |
|
| 614 |
# FIXME: or should we replace them with a tiny number? |
|
| 615 | ! |
if (any(LIK == 0.0, na.rm = TRUE)) {
|
| 616 | ! |
OUT <- +Inf |
| 617 | ! |
attr(OUT, "logl") <- as.numeric(NA) |
| 618 | ! |
return(OUT) |
| 619 |
} |
|
| 620 | ||
| 621 |
# loglikelihood |
|
| 622 | ! |
LogLIK.cases <- log(LIK) |
| 623 | ||
| 624 |
# sum over cases |
|
| 625 | ! |
LogLIK.pairs <- colSums(LogLIK.cases, na.rm = TRUE) |
| 626 | ||
| 627 |
# sum over pairs |
|
| 628 | ! |
logl <- logl_pairs <- sum(LogLIK.pairs) |
| 629 | ||
| 630 | ! |
if (missing == "available.cases" && all(ov.types == "ordered") && |
| 631 | ! |
nexo != 0L) {
|
| 632 | ! |
uni_LIK <- matrix(0, nrow(X), ncol(X)) |
| 633 | ! |
for (i in seq_len(nvar)) {
|
| 634 | ! |
uni_LIK[, i] <- lav_pml_uni_lik( |
| 635 | ! |
Y1 = X[, i], |
| 636 | ! |
th.y1 = TH[th.idx == i], |
| 637 | ! |
eXo = eXo, |
| 638 | ! |
PI.y1 = PI[i, ] |
| 639 |
) |
|
| 640 |
} |
|
| 641 | ||
| 642 | ! |
if (any(uni_LIK == 0.0, na.rm = TRUE)) {
|
| 643 | ! |
OUT <- +Inf |
| 644 | ! |
attr(OUT, "logl") <- as.numeric(NA) |
| 645 | ! |
return(OUT) |
| 646 |
} |
|
| 647 | ||
| 648 | ! |
uni_logLIK_cases <- log(uni_LIK) * lavcache$uniweights.casewise |
| 649 | ||
| 650 |
# sum over cases |
|
| 651 | ! |
uni_logLIK_varwise <- colSums(uni_logLIK_cases) |
| 652 | ||
| 653 |
# sum over variables |
|
| 654 | ! |
uni_logLIK <- sum(uni_logLIK_varwise) |
| 655 | ||
| 656 |
# add with the pairwise part of LogLik |
|
| 657 | ! |
logl <- logl_pairs + uni_logLIK |
| 658 |
} |
|
| 659 | ||
| 660 |
# we minimise |
|
| 661 | ! |
Fmin <- (-1) * logl |
| 662 |
} |
|
| 663 | ||
| 664 | ||
| 665 |
# here, we should have two quantities: logl and Fmin |
|
| 666 | ||
| 667 |
# function value as returned to the minimizer |
|
| 668 | ! |
fx <- Fmin |
| 669 | ||
| 670 |
# attach 'loglikelihood' |
|
| 671 | ! |
attr(fx, "logl") <- logl |
| 672 | ||
| 673 | ! |
fx |
| 674 |
} |
|
| 675 | ||
| 676 |
# full information maximum likelihood |
|
| 677 |
# underlying multivariate normal approach (see Joreskog & Moustaki, 2001) |
|
| 678 |
# |
|
| 679 |
lav_model_objective_fml <- function(Sigma.hat = NULL, # model-based var/cov/cor |
|
| 680 |
TH = NULL, # model-based thresholds + means |
|
| 681 |
th.idx = NULL, # threshold idx per variable |
|
| 682 |
num.idx = NULL, # which variables are numeric |
|
| 683 |
X = NULL, # raw data |
|
| 684 |
lavcache = NULL) { # patterns
|
|
| 685 | ||
| 686 |
# YR 27 aug 2013 |
|
| 687 |
# just for fun, and to compare with PML for small models |
|
| 688 | ||
| 689 |
# first of all: check if all correlations are within [-1,1] |
|
| 690 |
# if not, return Inf; (at least with nlminb, this works well) |
|
| 691 | ! |
cors <- Sigma.hat[lower.tri(Sigma.hat)] |
| 692 | ||
| 693 | ! |
if (any(abs(cors) > 1)) {
|
| 694 | ! |
return(+Inf) |
| 695 |
} |
|
| 696 | ||
| 697 | ! |
nvar <- nrow(Sigma.hat) |
| 698 | ! |
pstar <- nvar * (nvar - 1) / 2 |
| 699 | ! |
ov.types <- rep("ordered", nvar)
|
| 700 | ! |
if (length(num.idx) > 0L) ov.types[num.idx] <- "numeric" |
| 701 | ! |
MEAN <- rep(0, nvar) |
| 702 | ||
| 703 |
# shortcut for all ordered - per pattern |
|
| 704 | ! |
if (all(ov.types == "ordered")) {
|
| 705 | ! |
PAT <- lavcache$pat |
| 706 | ! |
npatterns <- nrow(PAT) |
| 707 | ! |
freq <- as.numeric(rownames(PAT)) |
| 708 | ! |
PI <- numeric(npatterns) |
| 709 | ! |
TH.VAR <- lapply(1:nvar, function(x) c(-Inf, TH[th.idx == x], +Inf)) |
| 710 |
# FIXME!!! ok to set diagonal to 1.0? |
|
| 711 | ! |
diag(Sigma.hat) <- 1.0 |
| 712 | ! |
for (r in 1:npatterns) {
|
| 713 |
# compute probability for each pattern |
|
| 714 | ! |
lower <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x]]) |
| 715 | ! |
upper <- sapply(1:nvar, function(x) TH.VAR[[x]][PAT[r, x] + 1L]) |
| 716 | ||
| 717 | ||
| 718 |
# how accurate must we be here??? |
|
| 719 | ! |
PI[r] <- sadmvn(lower, upper, |
| 720 | ! |
mean = MEAN, varcov = Sigma.hat, |
| 721 | ! |
maxpts = 10000 * nvar, abseps = 1e-07 |
| 722 |
) |
|
| 723 |
} |
|
| 724 |
# sum (log)likelihood over all patterns |
|
| 725 |
# LogLik <- sum(log(PI) * freq) |
|
| 726 | ||
| 727 |
# more convenient fit function |
|
| 728 | ! |
prop <- freq / sum(freq) |
| 729 |
# remove zero props # FIXME!!! or add 0.5??? |
|
| 730 | ! |
zero.idx <- which(prop == 0.0) |
| 731 | ! |
if (length(zero.idx) > 0L) {
|
| 732 | ! |
prop <- prop[-zero.idx] |
| 733 | ! |
PI <- PI[-zero.idx] |
| 734 |
} |
|
| 735 | ! |
Fmin <- sum(prop * log(prop / PI)) |
| 736 |
} else { # case-wise
|
|
| 737 | ! |
PI <- numeric(nobs) |
| 738 | ! |
for (i in 1:nobs) {
|
| 739 |
# compute probability for each case |
|
| 740 | ! |
PI[i] <- lav_msg_stop(gettext("not implemented"))
|
| 741 |
} |
|
| 742 |
# sum (log)likelihood over all observations |
|
| 743 | ! |
LogLik <- sum(log(PI)) |
| 744 | ! |
lav_msg_stop(gettext("not implemented"))
|
| 745 |
} |
|
| 746 | ||
| 747 |
# function value as returned to the minimizer |
|
| 748 |
# fx <- -1 * LogLik |
|
| 749 | ! |
fx <- Fmin |
| 750 | ||
| 751 | ! |
fx |
| 752 |
} |
|
| 753 | ||
| 754 |
lav_model_objective_mml <- function(lavmodel = NULL, |
|
| 755 |
THETA = NULL, |
|
| 756 |
TH = NULL, |
|
| 757 |
GLIST = NULL, |
|
| 758 |
group = 1L, |
|
| 759 |
lavdata = NULL, |
|
| 760 |
sample.mean = NULL, |
|
| 761 |
sample.mean.x = NULL, |
|
| 762 |
lavcache = NULL) {
|
|
| 763 |
# compute case-wise likelihoods |
|
| 764 | ! |
lik <- lav_model_lik_mml( |
| 765 | ! |
lavmodel = lavmodel, THETA = THETA, TH = TH, |
| 766 | ! |
GLIST = GLIST, group = group, lavdata = lavdata, |
| 767 | ! |
sample.mean = sample.mean, sample.mean.x = sample.mean.x, |
| 768 | ! |
lavcache = lavcache |
| 769 |
) |
|
| 770 | ||
| 771 |
# log + sum over observations |
|
| 772 | ! |
logl <- sum(log(lik)) |
| 773 | ||
| 774 |
# function value as returned to the minimizer |
|
| 775 | ! |
fx <- -logl |
| 776 | ||
| 777 | ! |
fx |
| 778 |
} |
|
| 779 | ||
| 780 |
lav_model_objective_2l <- function(lavmodel = NULL, |
|
| 781 |
GLIST = NULL, |
|
| 782 |
Y1 = NULL, # only for missing |
|
| 783 |
Lp = NULL, |
|
| 784 |
Mp = NULL, |
|
| 785 |
lavsamplestats = NULL, |
|
| 786 |
group = 1L) {
|
|
| 787 |
# compute model-implied statistics for all blocks |
|
| 788 | 336x |
implied <- lav_model_implied(lavmodel, GLIST = GLIST) |
| 789 | ||
| 790 |
# here, we assume only 2!!! levels, at [[1]] and [[2]] |
|
| 791 | 336x |
if (lavmodel@conditional.x) {
|
| 792 | ! |
Res.Sigma.W <- implied$res.cov[[ (group - 1) * 2 + 1]] |
| 793 | ! |
Res.Int.W <- implied$res.int[[ (group - 1) * 2 + 1]] |
| 794 | ! |
Res.Pi.W <- implied$res.slopes[[(group - 1) * 2 + 1]] |
| 795 | ||
| 796 | ! |
Res.Sigma.B <- implied$res.cov[[ (group - 1) * 2 + 2]] |
| 797 | ! |
Res.Int.B <- implied$res.int[[ (group - 1) * 2 + 2]] |
| 798 | ! |
Res.Pi.B <- implied$res.slopes[[(group - 1) * 2 + 2]] |
| 799 |
} else {
|
|
| 800 | 336x |
Sigma.W <- implied$cov[[( group - 1) * 2 + 1]] |
| 801 | 336x |
Mu.W <- implied$mean[[(group - 1) * 2 + 1]] |
| 802 | 336x |
Sigma.B <- implied$cov[[ (group - 1) * 2 + 2]] |
| 803 | 336x |
Mu.B <- implied$mean[[(group - 1) * 2 + 2]] |
| 804 |
} |
|
| 805 | ||
| 806 | 336x |
if (lavsamplestats@missing.flag) {
|
| 807 | ! |
if (lavmodel@conditional.x) {
|
| 808 | ! |
lav_msg_stop(gettext("multilevel + conditional.x is not ready yet for
|
| 809 | ! |
fiml; rerun with conditional.x = FALSE")) |
| 810 |
} |
|
| 811 |
# SIGMA.B <- Sigma.B[Lp$both.idx[[2]], Lp$both.idx[[2]], drop = FALSE] |
|
| 812 |
# if(any(diag(SIGMA.B) < 0)) {
|
|
| 813 |
# return(+Inf) |
|
| 814 |
# } |
|
| 815 |
# COR.B <- cov2cor(SIGMA.B) |
|
| 816 |
# if(any(abs(lav_matrix_vech(COR.B, diagonal = FALSE)) > 1)) {
|
|
| 817 |
# return(+Inf) |
|
| 818 |
# } |
|
| 819 | ||
| 820 | ! |
Y2 <- lavsamplestats@YLp[[group]][[2]]$Y2 |
| 821 | ! |
Yp <- lavsamplestats@missing[[group]] |
| 822 | ! |
loglik <- lav_mvnorm_cluster_missing_loglik_samplestats_2l( |
| 823 | ! |
Y1 = Y1, |
| 824 | ! |
Y2 = Y2, Lp = Lp, Mp = Mp, |
| 825 | ! |
Mu.W = Mu.W, Sigma.W = Sigma.W, |
| 826 | ! |
Mu.B = Mu.B, Sigma.B = Sigma.B, |
| 827 | ! |
log2pi = FALSE, minus.two = TRUE |
| 828 |
) |
|
| 829 |
} else {
|
|
| 830 | 336x |
YLp <- lavsamplestats@YLp[[group]] |
| 831 | 336x |
if (lavmodel@conditional.x) {
|
| 832 | ! |
loglik <- lav_mvreg_cluster_loglik_samplestats_2l( |
| 833 | ! |
YLp = YLp, Lp = Lp, |
| 834 | ! |
Res.Sigma.W = Res.Sigma.W, |
| 835 | ! |
Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W, |
| 836 | ! |
Res.Sigma.B = Res.Sigma.B, |
| 837 | ! |
Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B, |
| 838 | ! |
log2pi = FALSE, minus.two = TRUE |
| 839 |
) |
|
| 840 |
} else {
|
|
| 841 | 336x |
loglik <- lav_mvnorm_cluster_loglik_samplestats_2l( |
| 842 | 336x |
YLp = YLp, Lp = Lp, |
| 843 | 336x |
Mu.W = Mu.W, Sigma.W = Sigma.W, |
| 844 | 336x |
Mu.B = Mu.B, Sigma.B = Sigma.B, |
| 845 | 336x |
log2pi = FALSE, minus.two = TRUE |
| 846 |
) |
|
| 847 |
} |
|
| 848 |
} |
|
| 849 | ||
| 850 |
# minimize (we already did -2*) |
|
| 851 | 336x |
objective <- 1 * loglik |
| 852 | ||
| 853 |
# divide by (N*2) |
|
| 854 | 336x |
objective <- objective / (lavsamplestats@ntotal * 2) |
| 855 | ||
| 856 |
# should be strictly positive |
|
| 857 |
# if(objective < 0) {
|
|
| 858 |
# objective <- +Inf |
|
| 859 |
# } |
|
| 860 | ||
| 861 | 336x |
objective |
| 862 |
} |
| 1 |
# residual diagnostics |
|
| 2 | ||
| 3 |
# two types: |
|
| 4 |
# 1) residuals for summary statistics |
|
| 5 |
# 2) case-wise residuals |
|
| 6 | ||
| 7 |
# this (new) version written around Aug/Sept 2018 for 0.6-3 |
|
| 8 |
# - based on obsList (inspect_sampstat) and estList (inspect_implied) |
|
| 9 |
# - pre-scaling for type = "cor.bollen" and type = "cor.bentler" |
|
| 10 |
# - summary statistics: rmr, srmr, crmr, urmr, usrmr, ucrmr; standard errors, |
|
| 11 |
# confidence intervals (for u(cs)rmr), |
|
| 12 |
# z-statistics (exact test, close test), p-values |
|
| 13 |
# - type = "normalized" is based on lav_model_h1_acov(), and should now work |
|
| 14 |
# for all estimators |
|
| 15 |
# - type = "standardized" now uses the correct formula, and should work for |
|
| 16 |
# for all estimators |
|
| 17 |
# - type = "standardized.mplus" uses the simplified Mplus/LISREL version, |
|
| 18 |
# often resulting in NAs due to negative var(resid) estimates |
|
| 19 |
# (this was "standardized" in lavaan < 0.6.3 |
|
| 20 | ||
| 21 |
# WARNING: only partial support for conditional.x = TRUE!! |
|
| 22 |
# - in categorical case: we only compute summary statistics, using cor + th |
|
| 23 |
# (no var, slopes, ...) |
|
| 24 |
# - twolevel not supported here; see lav_fit_srmr.R, where we convert to |
|
| 25 |
# the unconditional setting |
|
| 26 | ||
| 27 |
# - change 0.6-6: we enforce observed.information = "h1" to ensure 'Q' is a |
|
| 28 |
# projection matrix (see lav_residuals_acov) |
|
| 29 | ||
| 30 |
# - change 0.6-13: fixed.x = TRUE is ignored (to conform with 'tradition') |
|
| 31 | ||
| 32 |
setMethod( |
|
| 33 |
"residuals", "lavaan", |
|
| 34 |
function(object, type = "raw", labels = TRUE, ...) {
|
|
| 35 | 31x |
dotdotdot <- list(...) |
| 36 | 31x |
if (length(dotdotdot) > 0L) {
|
| 37 | ! |
for (j in seq_along(dotdotdot)) {
|
| 38 | ! |
lav_msg_warn(gettextf( |
| 39 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 40 | ! |
sQuote("residuals"))
|
| 41 |
) |
|
| 42 |
} |
|
| 43 |
} |
|
| 44 |
# lowercase type |
|
| 45 | 31x |
type <- tolower(type) |
| 46 | ||
| 47 |
# type = "casewise" |
|
| 48 | 31x |
if (type %in% c("casewise", "case", "obs", "observations", "ov")) {
|
| 49 | 3x |
return(lav_residuals_casewise(object, labels = labels)) |
| 50 |
} else {
|
|
| 51 | 28x |
out <- lav_residuals( |
| 52 | 28x |
object = object, type = type, h1 = TRUE, |
| 53 | 28x |
add.type = TRUE, |
| 54 | 28x |
rename.cov.cor = FALSE, # should become FALSE! |
| 55 |
# after packages (eg jmv) |
|
| 56 |
# have adapted 0.6-3 style |
|
| 57 | 28x |
add.labels = labels, add.class = TRUE, |
| 58 | 28x |
drop.list.single.group = TRUE |
| 59 |
) |
|
| 60 |
} |
|
| 61 | ||
| 62 | 28x |
out |
| 63 |
} |
|
| 64 |
) |
|
| 65 | ||
| 66 |
setMethod( |
|
| 67 |
"resid", "lavaan", |
|
| 68 |
function(object, type = "raw", ...) {
|
|
| 69 | 17x |
dotdotdot <- list(...) |
| 70 | 17x |
if (length(dotdotdot) > 0L) {
|
| 71 | ! |
for (j in seq_along(dotdotdot)) {
|
| 72 | ! |
lav_msg_warn(gettextf( |
| 73 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 74 | ! |
sQuote("resid"))
|
| 75 |
) |
|
| 76 |
} |
|
| 77 |
} |
|
| 78 | 17x |
residuals(object, type = type, labels = TRUE) |
| 79 |
} |
|
| 80 |
) |
|
| 81 | ||
| 82 | ||
| 83 |
# user-visible function |
|
| 84 |
lavResiduals <- function(object, type = "cor.bentler", custom.rmr = NULL, |
|
| 85 |
se = FALSE, zstat = TRUE, summary = TRUE, |
|
| 86 |
h1.acov = "unstructured", |
|
| 87 |
add.type = TRUE, add.labels = TRUE, add.class = TRUE, |
|
| 88 |
drop.list.single.group = TRUE, |
|
| 89 |
maximum.number = length(res.vech), |
|
| 90 |
output = "list") {
|
|
| 91 | ! |
out <- lav_residuals( |
| 92 | ! |
object = object, type = type, h1 = TRUE, |
| 93 | ! |
custom.rmr = custom.rmr, se = se, zstat = zstat, |
| 94 | ! |
summary = summary, |
| 95 | ! |
summary.options = list( |
| 96 | ! |
se = TRUE, zstat = TRUE, pvalue = TRUE, |
| 97 | ! |
unbiased = TRUE, unbiased.se = TRUE, unbiased.ci = TRUE, |
| 98 | ! |
unbiased.ci.level = 0.90, unbiased.zstat = TRUE, |
| 99 | ! |
unbiased.test.val = 0.05, unbiased.pvalue = TRUE |
| 100 |
), |
|
| 101 | ! |
h1.acov = h1.acov, add.type = add.type, |
| 102 | ! |
add.labels = add.labels, add.class = add.class, |
| 103 | ! |
drop.list.single.group = drop.list.single.group |
| 104 |
) |
|
| 105 | ||
| 106 |
# no pretty printing yet... |
|
| 107 | ! |
if (output == "table") {
|
| 108 |
# new in 0.6-18: handle multiple blocks |
|
| 109 | ! |
nblocks <- lav_partable_nblocks(object@ParTable) |
| 110 | ! |
out.list <- vector("list", length = nblocks)
|
| 111 | ! |
for (block in seq_len(nblocks)) {
|
| 112 | ! |
if (nblocks == 1L) {
|
| 113 | ! |
res <- out$cov |
| 114 |
} else {
|
|
| 115 | ! |
res <- out[[block]]$cov |
| 116 |
} |
|
| 117 |
# extract only below-diagonal elements |
|
| 118 | ! |
res.vech <- lav_matrix_vech(res, diagonal = FALSE) |
| 119 | ||
| 120 |
# get names |
|
| 121 | ! |
P <- nrow(res) |
| 122 | ! |
NAMES <- colnames(res) |
| 123 | ||
| 124 | ! |
nam <- expand.grid( |
| 125 | ! |
NAMES, |
| 126 | ! |
NAMES |
| 127 | ! |
)[lav_matrix_vech_idx(P, diagonal = FALSE), ] |
| 128 | ! |
NAMES.vech <- paste(nam[, 1], "~~", nam[, 2], sep = "") |
| 129 | ||
| 130 |
# create table |
|
| 131 | ! |
TAB <- data.frame( |
| 132 | ! |
name = NAMES.vech, res = round(res.vech, 3), |
| 133 | ! |
stringsAsFactors = FALSE |
| 134 |
) |
|
| 135 | ||
| 136 |
# sort table |
|
| 137 | ! |
idx <- sort.int(abs(TAB$res), |
| 138 | ! |
decreasing = TRUE, |
| 139 | ! |
index.return = TRUE |
| 140 | ! |
)$ix |
| 141 | ! |
out.sorted <- TAB[idx, ] |
| 142 | ||
| 143 |
# show first rows only |
|
| 144 | ! |
if (maximum.number == 0L || maximum.number > length(res.vech)) {
|
| 145 | ! |
maximum.number <- length(res.vech) |
| 146 |
} |
|
| 147 | ! |
out.list[[block]] <- out.sorted[seq_len(maximum.number), ] |
| 148 |
} |
|
| 149 | ! |
if (nblocks == 1L) {
|
| 150 | ! |
out <- out.list[[1]] |
| 151 |
} else {
|
|
| 152 | ! |
out <- out.list |
| 153 | ! |
names(out) <- object@Data@block.label |
| 154 |
} |
|
| 155 |
} else {
|
|
| 156 |
# list -> nothing to do |
|
| 157 |
} |
|
| 158 | ||
| 159 | ! |
out |
| 160 |
} |
|
| 161 | ||
| 162 |
# main function |
|
| 163 |
lav_residuals <- function(object, type = "raw", h1 = TRUE, custom.rmr = NULL, |
|
| 164 |
se = FALSE, zstat = FALSE, summary = FALSE, |
|
| 165 |
summary.options = list( |
|
| 166 |
se = TRUE, zstat = TRUE, |
|
| 167 |
pvalue = TRUE, unbiased = TRUE, unbiased.se = TRUE, |
|
| 168 |
unbiased.ci = TRUE, unbiased.ci.level = 0.90, |
|
| 169 |
unbiased.zstat = FALSE, unbiased.test.val = 0.05, |
|
| 170 |
unbiased.pvalue = FALSE |
|
| 171 |
), |
|
| 172 |
h1.acov = "unstructured", add.type = FALSE, |
|
| 173 |
rename.cov.cor = FALSE, |
|
| 174 |
add.labels = FALSE, add.class = FALSE, |
|
| 175 |
drop.list.single.group = FALSE) {
|
|
| 176 |
# check object |
|
| 177 | 97x |
object <- lav_object_check_version(object) |
| 178 | ||
| 179 |
# type |
|
| 180 | 97x |
type <- tolower(type)[1] |
| 181 | ||
| 182 |
# check type |
|
| 183 | 97x |
if (!type %in% c( |
| 184 | 97x |
"raw", "cor", "cor.bollen", "cor.bentler", "cor.eqs", |
| 185 | 97x |
"rmr", "srmr", "crmr", |
| 186 | 97x |
"normalized", "standardized", "standardized.mplus" |
| 187 |
)) {
|
|
| 188 | ! |
lav_msg_stop(gettext("unknown argument for type:"), dQuote(type))
|
| 189 |
} |
|
| 190 | ||
| 191 |
# if cor, choose 'default' |
|
| 192 | 97x |
if (type == "cor") {
|
| 193 | ! |
if (object@Options$mimic == "EQS") {
|
| 194 | ! |
type <- "cor.bentler" |
| 195 |
} else {
|
|
| 196 | ! |
type <- "cor.bollen" |
| 197 |
} |
|
| 198 |
} |
|
| 199 | 97x |
if (type == "cor.eqs") {
|
| 200 | ! |
type <- "cor.bentler" |
| 201 |
} |
|
| 202 | 97x |
if (type == "rmr") {
|
| 203 | ! |
type <- "raw" |
| 204 |
} |
|
| 205 | 97x |
if (type == "srmr") {
|
| 206 | ! |
type <- "cor.bentler" |
| 207 |
} |
|
| 208 | 97x |
if (type == "crmr") {
|
| 209 | ! |
type <- "cor.bollen" |
| 210 |
} |
|
| 211 | ||
| 212 |
# slots |
|
| 213 | 97x |
lavdata <- object@Data |
| 214 | 97x |
lavmodel <- object@Model |
| 215 | ||
| 216 |
# change options if multilevel (for now) |
|
| 217 | 97x |
if (lavdata@nlevels > 1L) {
|
| 218 | 2x |
zstat <- se <- FALSE |
| 219 | 2x |
summary <- FALSE |
| 220 |
} |
|
| 221 | ||
| 222 |
# change options if categorical (for now) |
|
| 223 | 97x |
if (lavmodel@categorical) {
|
| 224 |
# only if conditional.x = FALSE AND no continuous endogenous variables |
|
| 225 |
# -> only the simple setting where we only have thresholds and |
|
| 226 |
# correlations |
|
| 227 | ||
| 228 |
# As soon as we add continuous variables, we get means/variances too, |
|
| 229 |
# and we need to decide how WLS.obs/WLS.est/WLS.V will then map to |
|
| 230 |
# the output of lavInspect(fit, "implied") and |
|
| 231 |
# lavInspect(fit, "sampstat") |
|
| 232 | ||
| 233 | 3x |
if (lavmodel@conditional.x || length(unlist(lavmodel@num.idx)) > 0L) {
|
| 234 | 3x |
zstat <- se <- FALSE |
| 235 | 3x |
summary <- FALSE |
| 236 | 3x |
summary.options <- list( |
| 237 | 3x |
se = FALSE, zstat = FALSE, |
| 238 | 3x |
pvalue = FALSE, unbiased = FALSE, |
| 239 | 3x |
unbiased.se = FALSE, |
| 240 | 3x |
unbiased.ci = FALSE, unbiased.ci.level = 0.90, |
| 241 | 3x |
unbiased.zstat = FALSE, unbiased.test.val = 0.05, |
| 242 | 3x |
unbiased.pvalue = FALSE |
| 243 |
) |
|
| 244 |
} |
|
| 245 |
} |
|
| 246 | ||
| 247 |
# change options if conditional.x (for now) |
|
| 248 | 97x |
if (!lavmodel@categorical && lavmodel@conditional.x) {
|
| 249 | ! |
zstat <- se <- FALSE |
| 250 | ! |
summary <- FALSE |
| 251 | ! |
summary.options <- list( |
| 252 | ! |
se = FALSE, zstat = FALSE, |
| 253 | ! |
pvalue = FALSE, unbiased = FALSE, |
| 254 | ! |
unbiased.se = FALSE, |
| 255 | ! |
unbiased.ci = FALSE, unbiased.ci.level = 0.90, |
| 256 | ! |
unbiased.zstat = FALSE, unbiased.test.val = 0.05, |
| 257 | ! |
unbiased.pvalue = FALSE |
| 258 |
) |
|
| 259 |
} |
|
| 260 | ||
| 261 |
# observed and fitted sample statistics |
|
| 262 | 97x |
obsList <- lav_object_inspect_sampstat(object, |
| 263 | 97x |
h1 = h1, |
| 264 | 97x |
add.labels = add.labels, add.class = add.class, |
| 265 | 97x |
drop.list.single.group = FALSE |
| 266 |
) |
|
| 267 | 97x |
estList <- lav_object_inspect_implied(object, |
| 268 | 97x |
add.labels = add.labels, add.class = add.class, |
| 269 | 97x |
drop.list.single.group = FALSE |
| 270 |
) |
|
| 271 |
# blocks |
|
| 272 | 97x |
nblocks <- length(obsList) |
| 273 | ||
| 274 |
# pre-scale? |
|
| 275 | 97x |
if (type %in% c("cor.bentler", "cor.bollen")) {
|
| 276 | 46x |
for (b in seq_len(nblocks)) {
|
| 277 | 48x |
var.obs <- if (lavmodel@conditional.x) {
|
| 278 | 2x |
diag(obsList[[b]][["res.cov"]]) |
| 279 |
} else {
|
|
| 280 | 46x |
diag(obsList[[b]][["cov"]]) |
| 281 |
} |
|
| 282 | 48x |
var.est <- if (lavmodel@conditional.x) {
|
| 283 | 2x |
diag(estList[[b]][["res.cov"]]) |
| 284 |
} else {
|
|
| 285 | 46x |
diag(estList[[b]][["cov"]]) |
| 286 |
} |
|
| 287 | ||
| 288 |
# rescale obsList |
|
| 289 | 48x |
obsList[[b]] <- |
| 290 | 48x |
lav_residuals_rescale(x = obsList[[b]], diag.cov = var.obs) |
| 291 |
# rescale estList |
|
| 292 | 48x |
if (type == "cor.bentler") { # use obsList
|
| 293 | 24x |
estList[[b]] <- |
| 294 | 24x |
lav_residuals_rescale(x = estList[[b]], diag.cov = var.obs) |
| 295 | 24x |
} else if (type == "cor.bollen") { # use estList for COV only
|
| 296 | 24x |
estList[[b]] <- lav_residuals_rescale( |
| 297 | 24x |
x = estList[[b]], |
| 298 | 24x |
diag.cov = var.est, diag.cov2 = var.obs |
| 299 |
) |
|
| 300 |
} |
|
| 301 |
} |
|
| 302 |
} |
|
| 303 | ||
| 304 |
# compute residuals: (observed - implied) |
|
| 305 | 97x |
resList <- vector("list", length = nblocks)
|
| 306 | 97x |
for (b in seq_len(nblocks)) {
|
| 307 | 108x |
resList[[b]] <- lapply(seq_len(length(obsList[[b]])), |
| 308 | 108x |
FUN = function(el) {
|
| 309 | 177x |
obsList[[b]][[el]] - estList[[b]][[el]] |
| 310 |
} |
|
| 311 |
) |
|
| 312 |
# always name the elements, even if add.labels = FALSE |
|
| 313 | 108x |
NAMES <- names(obsList[[b]]) |
| 314 | 108x |
names(resList[[b]]) <- NAMES |
| 315 |
} |
|
| 316 | ||
| 317 |
# do we need seList? |
|
| 318 | 97x |
if (se || zstat) {
|
| 319 | ! |
seList <- lav_residuals_se(object, |
| 320 | ! |
type = type, z.type = "standardized", |
| 321 | ! |
h1.acov = h1.acov, |
| 322 | ! |
add.class = add.class, add.labels = add.labels |
| 323 |
) |
|
| 324 | 97x |
} else if (type %in% c("normalized", "standardized", "standardized.mplus")) {
|
| 325 | ! |
seList <- lav_residuals_se(object, |
| 326 | ! |
type = "raw", z.type = type, |
| 327 | ! |
h1.acov = h1.acov, |
| 328 | ! |
add.class = add.class, add.labels = add.labels |
| 329 |
) |
|
| 330 |
} else {
|
|
| 331 | 97x |
seList <- NULL |
| 332 |
} |
|
| 333 | ||
| 334 |
# normalize/standardize? |
|
| 335 | 97x |
if (type %in% c("normalized", "standardized", "standardized.mplus")) {
|
| 336 | ! |
for (b in seq_len(nblocks)) {
|
| 337 | ! |
if (add.labels) {
|
| 338 | ! |
NAMES <- names(resList[[b]]) |
| 339 |
} |
|
| 340 | ! |
resList[[b]] <- lapply(seq_len(length(resList[[b]])), |
| 341 | ! |
FUN = function(el) {
|
| 342 | ! |
A <- resList[[b]][[el]] |
| 343 | ! |
B <- seList[[b]][[el]] |
| 344 | ! |
near.zero.idx <- which(abs(A) < 1e-05) |
| 345 | ! |
if (length(near.zero.idx) > 0L) {
|
| 346 | ! |
B[near.zero.idx] <- 1 |
| 347 |
} |
|
| 348 | ! |
A / B |
| 349 |
} |
|
| 350 |
) |
|
| 351 | ! |
if (add.labels) {
|
| 352 | ! |
names(resList[[b]]) <- NAMES |
| 353 |
} |
|
| 354 |
} |
|
| 355 |
} |
|
| 356 | ||
| 357 |
# add se |
|
| 358 | 97x |
resList.orig <- resList |
| 359 | 97x |
if (se) {
|
| 360 | ! |
for (b in seq_len(nblocks)) {
|
| 361 | ! |
NAMES.res <- names(resList[[b]]) |
| 362 | ! |
NAMES.se <- paste0(NAMES.res, ".se") |
| 363 | ! |
resList[[b]] <- c(resList[[b]], seList[[b]]) |
| 364 | ! |
names(resList[[b]]) <- c(NAMES.res, NAMES.se) |
| 365 |
} |
|
| 366 |
} |
|
| 367 | ||
| 368 | ||
| 369 |
# add zstat |
|
| 370 | 97x |
if (zstat) {
|
| 371 | ! |
for (b in seq_len(nblocks)) {
|
| 372 | ! |
NAMES.res <- names(resList[[b]]) |
| 373 | ! |
NAMES.z <- paste0(names(resList.orig[[b]]), ".z") |
| 374 | ! |
tmp <- lapply(seq_len(length(resList.orig[[b]])), |
| 375 | ! |
FUN = function(el) {
|
| 376 | ! |
A <- resList.orig[[b]][[el]] |
| 377 | ! |
B <- seList[[b]][[el]] |
| 378 |
# NOTE: which threshold should we use? |
|
| 379 |
# used to be 1e-05 |
|
| 380 |
# changed to 1e-04 in 0.6-4 |
|
| 381 | ! |
near.zero.idx <- which(abs(A) < 1e-04) |
| 382 | ! |
if (length(near.zero.idx) > 0L) {
|
| 383 |
# B[near.zero.idx] <- as.numeric(NA) |
|
| 384 | ! |
B[near.zero.idx] <- 1.0 |
| 385 |
} |
|
| 386 | ! |
A / B |
| 387 |
} |
|
| 388 |
) |
|
| 389 | ! |
resList[[b]] <- c(resList[[b]], tmp) |
| 390 | ! |
names(resList[[b]]) <- c(NAMES.res, NAMES.z) |
| 391 |
} |
|
| 392 |
} |
|
| 393 | ||
| 394 |
# add summary statistics (rms, mabs) |
|
| 395 | 97x |
if (summary) {
|
| 396 | ! |
args <- c( |
| 397 | ! |
list( |
| 398 | ! |
object = object, type = type, h1.acov = h1.acov, |
| 399 | ! |
add.class = add.class, custom.rmr = custom.rmr |
| 400 |
), |
|
| 401 | ! |
summary.options |
| 402 |
) |
|
| 403 | ! |
sumStat <- do.call("lav_residuals_summary", args)
|
| 404 | ! |
for (b in seq_len(nblocks)) {
|
| 405 | ! |
NAMES <- names(resList[[b]]) |
| 406 | ! |
resList[[b]] <- c(resList[[b]], list(sumStat[[b]][[1]])) # only 1 |
| 407 | ! |
NAMES <- c(NAMES, "summary") |
| 408 | ! |
names(resList[[b]]) <- NAMES |
| 409 |
} |
|
| 410 |
} |
|
| 411 | ||
| 412 |
# last: add type |
|
| 413 | 97x |
if (add.type) {
|
| 414 | 28x |
for (b in seq_len(nblocks)) {
|
| 415 | 36x |
NAMES <- names(resList[[b]]) |
| 416 | 36x |
resList[[b]] <- c(type, resList[[b]]) |
| 417 | 36x |
NAMES <- c("type", NAMES)
|
| 418 | 36x |
names(resList[[b]]) <- NAMES |
| 419 |
} |
|
| 420 |
} |
|
| 421 | ||
| 422 |
# optional: rename 'cov' to 'cor' (if type = "cor") |
|
| 423 | 97x |
if (rename.cov.cor && type %in% c("cor.bentler", "cor.bollen")) {
|
| 424 | ! |
for (b in seq_len(nblocks)) {
|
| 425 | ! |
NAMES <- names(resList[[b]]) |
| 426 | ! |
NAMES <- gsub("cov", "cor", NAMES)
|
| 427 | ! |
names(resList[[b]]) <- NAMES |
| 428 |
} |
|
| 429 |
} |
|
| 430 | ||
| 431 | ||
| 432 |
# output |
|
| 433 | 97x |
OUT <- resList |
| 434 | 97x |
if (nblocks == 1L && drop.list.single.group) {
|
| 435 | 24x |
OUT <- OUT[[1]] |
| 436 |
} else {
|
|
| 437 | 73x |
if (lavdata@nlevels == 1L && |
| 438 | 73x |
length(lavdata@group.label) > 0L) {
|
| 439 | 5x |
names(OUT) <- unlist(lavdata@group.label) |
| 440 | 68x |
} else if (lavdata@nlevels > 1L && |
| 441 | 68x |
length(lavdata@group.label) == 0L) {
|
| 442 | ! |
names(OUT) <- lavdata@level.label |
| 443 |
} |
|
| 444 |
} |
|
| 445 | ||
| 446 | 97x |
OUT |
| 447 |
} |
|
| 448 | ||
| 449 |
# return ACOV as list per group |
|
| 450 |
lav_residuals_acov <- function(object, type = "raw", z.type = "standardized", |
|
| 451 |
h1.acov = "unstructured") {
|
|
| 452 |
# check type |
|
| 453 | ! |
if (z.type %in% c("normalized", "standardized.mplus") && type != "raw") {
|
| 454 | ! |
lav_msg_stop(gettextf( |
| 455 | ! |
"z.type = %1$s can only be used with type = %2$s", |
| 456 | ! |
dQuote(z.type), dQuote("raw")))
|
| 457 |
} |
|
| 458 | ||
| 459 |
# slots |
|
| 460 | ! |
lavdata <- object@Data |
| 461 | ! |
lavmodel <- object@Model |
| 462 | ! |
lavsamplestats <- object@SampleStats |
| 463 | ||
| 464 |
# return list per group |
|
| 465 | ! |
ACOV.res <- vector("list", length = lavdata@ngroups)
|
| 466 | ||
| 467 |
# compute ACOV for observed h1 sample statistics (ACOV == Gamma/N) |
|
| 468 | ! |
if (!is.null(lavsamplestats@NACOV[[1]])) {
|
| 469 | ! |
NACOV.obs <- lavsamplestats@NACOV # if this changes, tag @TDJorgensen in commit message |
| 470 | ! |
ACOV.obs <- lapply(NACOV.obs, function(x) x / lavsamplestats@ntotal) |
| 471 |
} else {
|
|
| 472 | ! |
ACOV.obs <- lav_model_h1_acov( |
| 473 | ! |
lavobject = object, |
| 474 | ! |
h1.information = h1.acov |
| 475 |
) |
|
| 476 |
} |
|
| 477 | ||
| 478 |
# shortcut for normalized |
|
| 479 | ! |
if (z.type == "normalized") {
|
| 480 | ! |
ACOV.res <- ACOV.obs |
| 481 | ! |
return(ACOV.res) |
| 482 |
} else {
|
|
| 483 | ! |
if (z.type == "standardized") {
|
| 484 | ! |
A1 <- lav_model_h1_information(object) |
| 485 | ! |
if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
|
| 486 |
# A1 is diagonal matrix |
|
| 487 | ! |
A1 <- lapply(A1, diag) |
| 488 |
} |
|
| 489 | ! |
if (type %in% c("cor.bentler", "cor.bollen")) {
|
| 490 | ! |
sampstat <- lavTech(object, "sampstat") |
| 491 |
} |
|
| 492 | ! |
} else if (z.type == "standardized.mplus") {
|
| 493 | ! |
VCOV <- lavTech(object, "vcov") |
| 494 |
} |
|
| 495 | ! |
DELTA <- lavTech(object, "delta") |
| 496 |
} |
|
| 497 | ||
| 498 |
# for each group, compute ACOV |
|
| 499 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 500 |
# group weight |
|
| 501 | ! |
gw <- object@SampleStats@nobs[[g]] / object@SampleStats@ntotal # if this changes, tag @TDJorgensen in commit message |
| 502 | ||
| 503 | ! |
if (z.type == "standardized.mplus") { # simplified formula
|
| 504 |
# also used by LISREL? |
|
| 505 |
# see https://www.statmodel.com/download/StandardizedResiduals.pdf |
|
| 506 | ||
| 507 | ! |
ACOV.est.g <- DELTA[[g]] %*% VCOV %*% t(DELTA[[g]]) |
| 508 | ! |
ACOV.res[[g]] <- ACOV.obs[[g]] - ACOV.est.g |
| 509 | ! |
} else if (z.type == "standardized") {
|
| 510 |
# see Ogasawara (2001) using Bentler & Dijkstra (1985) eq 1.7.4 |
|
| 511 | ||
| 512 |
# NVarCov, but always 'not' robust |
|
| 513 |
# |
|
| 514 |
# new in 0.6-6: to ensure Q is a projection matrix, we |
|
| 515 |
# force observed.information = "h1" |
|
| 516 |
# (only needed if information is observed) |
|
| 517 | ! |
this.options <- object@Options |
| 518 | ! |
this.options$observed.information[1] <- "h1" |
| 519 | ! |
A0.g.inv <- lav_model_information( |
| 520 | ! |
lavmodel = lavmodel, |
| 521 | ! |
lavsamplestats = object@SampleStats, |
| 522 | ! |
lavdata = lavdata, |
| 523 | ! |
lavcache = object@Cache, |
| 524 | ! |
lavimplied = object@implied, |
| 525 | ! |
lavh1 = object@h1, |
| 526 | ! |
lavoptions = this.options, |
| 527 | ! |
extra = FALSE, |
| 528 | ! |
augmented = TRUE, |
| 529 | ! |
inverted = TRUE, |
| 530 | ! |
use.ginv = TRUE |
| 531 |
) |
|
| 532 | ||
| 533 | ! |
ACOV.est.g <- gw * (DELTA[[g]] %*% A0.g.inv %*% t(DELTA[[g]])) |
| 534 | ! |
Q <- diag(nrow = nrow(ACOV.est.g)) - ACOV.est.g %*% A1[[g]] |
| 535 | ! |
ACOV.res[[g]] <- Q %*% ACOV.obs[[g]] %*% t(Q) |
| 536 | ||
| 537 |
# correct ACOV.res for type = "cor.bentler" or type = "cor.bollen" |
|
| 538 | ! |
if (type == "cor.bentler") {
|
| 539 | ! |
if (lavmodel@categorical) {
|
| 540 | ! |
if (lavmodel@conditional.x || |
| 541 | ! |
length(unlist(lavmodel@num.idx)) > 0L) {
|
| 542 | ! |
lav_msg_stop(gettext( |
| 543 | ! |
"SE for cor.bentler not available (yet) if categorical = TRUE, and |
| 544 | ! |
conditional.x = TRUE OR some endogenous variables are continuous")) |
| 545 |
} else {
|
|
| 546 |
# nothing to do, as we already are in correlation metric |
|
| 547 |
} |
|
| 548 |
} else {
|
|
| 549 |
# Ogasawara (2001), eq (13), or |
|
| 550 |
# Maydeu-Olivares (2017), eq (16) |
|
| 551 | ! |
COV <- if (lavmodel@conditional.x) {
|
| 552 | ! |
sampstat[[g]][["res.cov"]] |
| 553 |
} else {
|
|
| 554 | ! |
sampstat[[g]][["cov"]] |
| 555 |
} |
|
| 556 | ! |
SS <- 1 / sqrt(diag(COV)) |
| 557 | ! |
tmp <- lav_matrix_vech(tcrossprod(SS)) |
| 558 | ! |
G.inv.sqrt <- diag(tmp, nrow = length(tmp)) |
| 559 | ! |
if (lavmodel@meanstructure) {
|
| 560 | ! |
GG <- lav_matrix_bdiag( |
| 561 | ! |
diag(SS, nrow = length(SS)), |
| 562 | ! |
G.inv.sqrt |
| 563 |
) |
|
| 564 |
} else {
|
|
| 565 | ! |
GG <- G.inv.sqrt |
| 566 |
} |
|
| 567 | ! |
ACOV.res[[g]] <- GG %*% ACOV.res[[g]] %*% GG |
| 568 |
} # continuous |
|
| 569 | ! |
} else if (type == "cor.bollen") {
|
| 570 | ! |
if (lavmodel@categorical) {
|
| 571 | ! |
if (lavmodel@conditional.x || |
| 572 | ! |
length(unlist(lavmodel@num.idx)) > 0L) {
|
| 573 | ! |
lav_msg_stop(gettext( |
| 574 | ! |
"SE for cor.bentler not available (yet) if categorical = TRUE, and |
| 575 | ! |
conditional.x = TRUE OR some endogenous variables are continuous")) |
| 576 |
} else {
|
|
| 577 |
# nothing to do, as we already are in correlation metric |
|
| 578 |
} |
|
| 579 |
} else {
|
|
| 580 |
# here we use the Maydeu-Olivares (2017) approach, see eq 17 |
|
| 581 | ! |
COV <- if (lavmodel@conditional.x) {
|
| 582 | ! |
sampstat[[g]][["res.cov"]] |
| 583 |
} else {
|
|
| 584 | ! |
sampstat[[g]][["cov"]] |
| 585 |
} |
|
| 586 | ! |
F1 <- lav_deriv_cov2corB(COV) |
| 587 | ! |
if (lavmodel@meanstructure) {
|
| 588 | ! |
SS <- 1 / sqrt(diag(COV)) |
| 589 | ! |
FF <- lav_matrix_bdiag(diag(SS, nrow = length(SS)), F1) |
| 590 |
} else {
|
|
| 591 | ! |
FF <- F1 |
| 592 |
} |
|
| 593 | ! |
ACOV.res[[g]] <- FF %*% ACOV.res[[g]] %*% t(FF) |
| 594 |
} # continuous |
|
| 595 |
} # cor.bollen |
|
| 596 |
} # z.type = "standardized" |
|
| 597 |
} # g |
|
| 598 | ||
| 599 | ! |
ACOV.res |
| 600 |
} |
|
| 601 | ||
| 602 |
# return resList with 'se' values for each residual |
|
| 603 |
lav_residuals_se <- function(object, type = "raw", z.type = "standardized", |
|
| 604 |
h1.acov = "unstructured", |
|
| 605 |
add.class = FALSE, add.labels = FALSE) {
|
|
| 606 |
# slots |
|
| 607 | ! |
lavdata <- object@Data |
| 608 | ! |
lavmodel <- object@Model |
| 609 | ! |
lavpta <- object@pta |
| 610 | ||
| 611 |
# return list per group |
|
| 612 | ! |
seList <- vector("list", length = lavdata@ngroups)
|
| 613 | ||
| 614 |
# get ACOV per group |
|
| 615 | ! |
ACOV.res <- lav_residuals_acov( |
| 616 | ! |
object = object, type = type, |
| 617 | ! |
z.type = z.type, h1.acov = h1.acov |
| 618 |
) |
|
| 619 | ||
| 620 |
# labels |
|
| 621 | ! |
if (add.labels) {
|
| 622 | ! |
ov.names <- object@pta$vnames$ov |
| 623 | ! |
ov.names.res <- object@pta$vnames$ov.nox |
| 624 | ! |
ov.names.x <- object@pta$vnames$ov.x |
| 625 |
} |
|
| 626 | ||
| 627 |
# for each group, compute 'se' values, and fill list |
|
| 628 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 629 | ! |
nvar <- object@pta$nvar[[g]] # block or group-based? |
| 630 | ! |
diag.ACOV <- diag(ACOV.res[[g]]) |
| 631 | ||
| 632 |
# take care of negative, or non-finite diag.ACOV elements |
|
| 633 | ! |
diag.ACOV[!is.finite(diag.ACOV)] <- NA |
| 634 | ! |
diag.ACOV[diag.ACOV < 0] <- NA |
| 635 | ||
| 636 |
# categorical |
|
| 637 | ! |
if (lavmodel@categorical) {
|
| 638 | ! |
if (lavmodel@conditional.x || |
| 639 | ! |
length(unlist(lavmodel@num.idx)) > 0L) {
|
| 640 | ! |
lav_msg_stop(gettext("not ready yet!"))
|
| 641 |
} |
|
| 642 | ||
| 643 |
# COR |
|
| 644 | ! |
nth <- length(lavmodel@th.idx[[g]]) |
| 645 | ! |
tmp <- sqrt(diag.ACOV[-(1:nth)]) |
| 646 | ! |
cov.se <- lav_matrix_vech_reverse(tmp, diagonal = FALSE) |
| 647 | ||
| 648 |
# MEAN |
|
| 649 | ! |
mean.se <- rep(as.numeric(NA), nvar) |
| 650 | ||
| 651 |
# TH |
|
| 652 | ! |
th.se <- sqrt(diag.ACOV[1:nth]) |
| 653 | ||
| 654 | ! |
if (add.class) {
|
| 655 | ! |
class(cov.se) <- c("lavaan.matrix.symmetric", "matrix")
|
| 656 | ! |
class(mean.se) <- c("lavaan.vector", "numeric")
|
| 657 | ! |
class(th.se) <- c("lavaan.vector", "numeric")
|
| 658 |
} |
|
| 659 | ! |
if (add.labels) {
|
| 660 | ! |
rownames(cov.se) <- colnames(cov.se) <- ov.names[[g]] |
| 661 | ! |
names(mean.se) <- ov.names[[g]] |
| 662 | ! |
names(th.se) <- lavpta$vnames$th.mean[[g]] |
| 663 |
} |
|
| 664 | ! |
seList[[g]] <- list( |
| 665 | ! |
cov.se = cov.se, mean.se = mean.se, |
| 666 | ! |
th.se = th.se |
| 667 |
) |
|
| 668 | ||
| 669 |
# continuous -- single level |
|
| 670 | ! |
} else if (lavdata@nlevels == 1L) {
|
| 671 | ! |
if (lavmodel@conditional.x) {
|
| 672 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 673 |
} else {
|
|
| 674 | ! |
if (lavmodel@meanstructure) {
|
| 675 | ! |
tmp <- sqrt(diag.ACOV[-(1:nvar)]) |
| 676 | ! |
cov.se <- lav_matrix_vech_reverse(tmp) |
| 677 | ! |
mean.se <- sqrt(diag.ACOV[1:nvar]) |
| 678 | ! |
if (add.class) {
|
| 679 | ! |
class(cov.se) <- c("lavaan.matrix.symmetric", "matrix")
|
| 680 | ! |
class(mean.se) <- c("lavaan.vector", "numeric")
|
| 681 |
} |
|
| 682 | ! |
if (add.labels) {
|
| 683 | ! |
rownames(cov.se) <- colnames(cov.se) <- ov.names[[g]] |
| 684 | ! |
names(mean.se) <- ov.names[[g]] |
| 685 |
} |
|
| 686 | ! |
seList[[g]] <- list(cov.se = cov.se, mean.se = mean.se) |
| 687 |
} else {
|
|
| 688 | ! |
cov.se <- lav_matrix_vech_reverse(sqrt(diag.ACOV)) |
| 689 | ! |
if (add.class) {
|
| 690 | ! |
class(cov.se) <- c("lavaan.matrix.symmetric", "matrix")
|
| 691 |
} |
|
| 692 | ! |
if (add.labels) {
|
| 693 | ! |
rownames(cov.se) <- colnames(cov.se) <- ov.names[[g]] |
| 694 |
} |
|
| 695 | ! |
seList[[g]] <- list(cov.se = cov.se) |
| 696 |
} |
|
| 697 |
} |
|
| 698 | ||
| 699 |
# continuous -- multilevel |
|
| 700 | ! |
} else if (lavdata@nlevels > 1L) {
|
| 701 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 702 |
} |
|
| 703 |
} # g |
|
| 704 | ||
| 705 | ! |
seList |
| 706 |
} |
|
| 707 | ||
| 708 |
# return summary statistics as list per group |
|
| 709 |
lav_residuals_summary <- function(object, type = c("rmr", "srmr", "crmr"),
|
|
| 710 |
h1.acov = "unstructured", custom.rmr = NULL, |
|
| 711 |
se = FALSE, zstat = FALSE, pvalue = FALSE, |
|
| 712 |
unbiased = FALSE, unbiased.se = FALSE, |
|
| 713 |
unbiased.ci = FALSE, unbiased.ci.level = 0.90, |
|
| 714 |
unbiased.zstat = FALSE, |
|
| 715 |
unbiased.test.val = 0.05, |
|
| 716 |
unbiased.pvalue = FALSE, |
|
| 717 |
add.class = FALSE) {
|
|
| 718 |
# arguments |
|
| 719 | 23x |
if (length(custom.rmr)) {
|
| 720 | ! |
if (!is.list(custom.rmr)) lav_msg_stop(gettext("custom.rmr must be a list"))
|
| 721 |
## Each custom (S/C)RMR must have a unique name |
|
| 722 | ! |
customNAMES <- names(custom.rmr) |
| 723 | ! |
if (is.null(customNAMES)) lav_msg_stop(gettext( |
| 724 | ! |
"custom.rmr list must have names")) |
| 725 | ! |
if (length(unique(customNAMES)) < length(custom.rmr)) {
|
| 726 | ! |
lav_msg_stop(gettext( |
| 727 | ! |
"custom.rmr must have a unique name for each summary")) |
| 728 |
} |
|
| 729 |
## Each list must contain a list consisting of $cov and/or $mean (no $th yet) |
|
| 730 | ! |
for (i in seq_along(custom.rmr)) {
|
| 731 | ! |
if (!is.list(custom.rmr[[i]])) {
|
| 732 | ! |
lav_msg_stop(gettext("Each element in custom.rmr must be a list"))
|
| 733 |
} |
|
| 734 | ! |
if (is.null(names(custom.rmr[[i]]))) {
|
| 735 | ! |
lav_msg_stop(gettext("The list in custom.rmr must have names"))
|
| 736 |
} |
|
| 737 | ! |
if (!all(names(custom.rmr[[i]]) %in% c("cov", "mean"))) {
|
| 738 | ! |
lav_msg_stop(gettext( |
| 739 | ! |
'Elements in custom.rmr must be names "cov" and/or "mean"')) |
| 740 |
} |
|
| 741 |
## below, verify dimensions match rmsList.g |
|
| 742 |
} |
|
| 743 |
# FIXME: blocks can have unique models, need another layer of lists |
|
| 744 |
# between custom summaries and moments |
|
| 745 |
} else {
|
|
| 746 | 23x |
customNAMES <- NULL |
| 747 |
} |
|
| 748 | ||
| 749 | 23x |
if (pvalue) {
|
| 750 | ! |
zstat <- TRUE |
| 751 |
} |
|
| 752 | 23x |
if (zstat) {
|
| 753 | ! |
se <- TRUE |
| 754 |
} |
|
| 755 | 23x |
if (unbiased.pvalue) {
|
| 756 | ! |
unbiased.zstat <- TRUE |
| 757 |
} |
|
| 758 | 23x |
if (unbiased.zstat) {
|
| 759 | ! |
unbiased.se <- TRUE |
| 760 |
} |
|
| 761 | ||
| 762 | 23x |
if (!all(type %in% c( |
| 763 | 23x |
"rmr", "srmr", "crmr", |
| 764 | 23x |
"raw", "cor.bentler", "cor.bollen" |
| 765 |
))) {
|
|
| 766 | ! |
lav_msg_stop(gettext("unknown type:"), dQuote(type))
|
| 767 |
} |
|
| 768 | ||
| 769 |
# change type name |
|
| 770 | 23x |
idx <- which(type == "raw") |
| 771 | 23x |
if (length(idx) > 0L) {
|
| 772 | ! |
type[idx] <- "rmr" |
| 773 |
} |
|
| 774 | 23x |
idx <- which(type == "cor.bentler") |
| 775 | 23x |
if (length(idx) > 0L) {
|
| 776 | ! |
type[idx] <- "srmr" |
| 777 |
} |
|
| 778 | 23x |
idx <- which(type == "cor.bollen") |
| 779 | 23x |
if (length(idx) > 0L) {
|
| 780 | ! |
type[idx] <- "crmr" |
| 781 |
} |
|
| 782 | ||
| 783 |
# slots |
|
| 784 | 23x |
lavdata <- object@Data |
| 785 | 23x |
lavmodel <- object@Model |
| 786 | ||
| 787 |
# fixed.x/conditional.x |
|
| 788 | 23x |
fixed.x <- lavmodel@fixed.x |
| 789 | 23x |
conditional.x <- lavmodel@conditional.x |
| 790 | ||
| 791 | ||
| 792 | 23x |
rmrFlag <- srmrFlag <- crmrFlag <- FALSE |
| 793 | 23x |
if ("rmr" %in% type || "raw" %in% type) {
|
| 794 |
# FIXME: recursive call to lav_residuals() is summary = TRUE!! |
|
| 795 | 23x |
rmrList <- lav_residuals(object = object, type = "raw") |
| 796 | 23x |
if (se || unbiased) {
|
| 797 | ! |
rmrList.se <- lav_residuals_acov( |
| 798 | ! |
object = object, type = "raw", |
| 799 | ! |
z.type = "standardized", |
| 800 | ! |
h1.acov = "unstructured" |
| 801 |
) |
|
| 802 |
} |
|
| 803 |
} |
|
| 804 | 23x |
if ("srmr" %in% type || "cor.bentler" %in% type || "cor" %in% type) {
|
| 805 | 23x |
srmrList <- lav_residuals(object = object, type = "cor.bentler") |
| 806 | 23x |
if (se || unbiased) {
|
| 807 | ! |
srmrList.se <- lav_residuals_acov( |
| 808 | ! |
object = object, |
| 809 | ! |
type = "cor.bentler", |
| 810 | ! |
z.type = "standardized", |
| 811 | ! |
h1.acov = "unstructured" |
| 812 |
) |
|
| 813 |
} |
|
| 814 |
} |
|
| 815 | 23x |
if ("crmr" %in% type || "cor.bollen" %in% type) {
|
| 816 | 23x |
crmrList <- lav_residuals(object = object, type = "cor.bollen") |
| 817 | 23x |
if (se || unbiased) {
|
| 818 | ! |
crmrList.se <- lav_residuals_acov( |
| 819 | ! |
object = object, |
| 820 | ! |
type = "cor.bollen", |
| 821 | ! |
z.type = "standardized", |
| 822 | ! |
h1.acov = "unstructured" |
| 823 |
) |
|
| 824 |
} |
|
| 825 |
} |
|
| 826 | ||
| 827 |
# return list per group |
|
| 828 | 23x |
sumStat <- vector("list", length = lavdata@ngroups)
|
| 829 | ||
| 830 |
# for each group, compute ACOV |
|
| 831 | 23x |
for (g in seq_len(lavdata@ngroups)) {
|
| 832 | 24x |
nvar <- object@pta$nvar[[g]] # block or group-based? |
| 833 | ||
| 834 |
# categorical single level |
|
| 835 | 24x |
if (lavdata@nlevels == 1L && lavmodel@categorical) {
|
| 836 | 1x |
if ((se || unbiased) && (conditional.x || |
| 837 | 1x |
length(unlist(lavmodel@num.idx)) > 0L)) {
|
| 838 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 839 |
} else {
|
|
| 840 |
# remove fixed.x elements: |
|
| 841 |
# seems like a good idea, but nobody likes it |
|
| 842 |
# nvar.x <- pstar.x <- 0L |
|
| 843 |
# if(lavmodel@fixed.x) {
|
|
| 844 |
# nvar.x <- lavmodel@nexo[g] |
|
| 845 |
# pstar.x <- nvar.x * (nvar.x - 1) / 2 # note '-' |
|
| 846 |
# } |
|
| 847 | ||
| 848 | 1x |
OUT <- vector("list", length(type))
|
| 849 | 1x |
names(OUT) <- type |
| 850 | ||
| 851 | 1x |
for (typ in seq_len(length(type))) {
|
| 852 | 3x |
if (type[typ] == "rmr") {
|
| 853 | 1x |
rmsList.g <- rmrList[[g]] |
| 854 | 1x |
if (se || unbiased) {
|
| 855 | ! |
rmsList.se.g <- rmrList.se[[g]] |
| 856 |
} |
|
| 857 | 2x |
} else if (type[typ] == "srmr") {
|
| 858 | 1x |
rmsList.g <- srmrList[[g]] |
| 859 | 1x |
if (se || unbiased) {
|
| 860 | ! |
rmsList.se.g <- srmrList.se[[g]] |
| 861 |
} |
|
| 862 | 1x |
} else if (type[typ] == "crmr") {
|
| 863 | 1x |
rmsList.g <- crmrList[[g]] |
| 864 | 1x |
if (se || unbiased) {
|
| 865 | ! |
rmsList.se.g <- crmrList.se[[g]] |
| 866 |
} |
|
| 867 |
} |
|
| 868 | ||
| 869 |
# COR |
|
| 870 | 3x |
nth <- length(lavmodel@th.idx[[g]]) |
| 871 | 3x |
if (conditional.x) {
|
| 872 | 3x |
STATS <- lav_matrix_vech(rmsList.g[["res.cov"]], |
| 873 | 3x |
diagonal = FALSE |
| 874 |
) |
|
| 875 |
} else {
|
|
| 876 | ! |
STATS <- lav_matrix_vech(rmsList.g[["cov"]], |
| 877 | ! |
diagonal = FALSE |
| 878 |
) |
|
| 879 |
} |
|
| 880 | ||
| 881 |
# should pstar be p*(p+1)/2 or p*(p-1)/2 |
|
| 882 |
# we use the first for SRMR and the latter for CRMR |
|
| 883 | 3x |
if (type[typ] == "crmr") {
|
| 884 | 1x |
pstar <- length(STATS) |
| 885 |
} else {
|
|
| 886 | 2x |
pstar <- length(STATS) + nvar |
| 887 |
} |
|
| 888 | 3x |
ACOV <- NULL |
| 889 | 3x |
if (se || unbiased) {
|
| 890 | ! |
ACOV <- rmsList.se.g[-seq_len(nth), |
| 891 | ! |
-seq_len(nth), |
| 892 | ! |
drop = FALSE |
| 893 |
] |
|
| 894 |
} |
|
| 895 | 3x |
RMS.COR <- lav_residuals_summary_rms( |
| 896 | 3x |
STATS = STATS, |
| 897 | 3x |
ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue, |
| 898 | 3x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 899 | 3x |
unbiased.ci = unbiased.ci, |
| 900 | 3x |
unbiased.ci.level = unbiased.ci.level, |
| 901 | 3x |
unbiased.zstat = unbiased.zstat, |
| 902 | 3x |
unbiased.test.val = unbiased.test.val, |
| 903 | 3x |
unbiased.pvalue = unbiased.pvalue, |
| 904 | 3x |
pstar = pstar, type = type[typ] |
| 905 |
) |
|
| 906 | ||
| 907 | ||
| 908 |
# THRESHOLDS |
|
| 909 | 3x |
if (conditional.x) {
|
| 910 | 3x |
STATS <- rmsList.g[["res.th"]] |
| 911 |
} else {
|
|
| 912 | ! |
STATS <- rmsList.g[["th"]] |
| 913 |
} |
|
| 914 | 3x |
pstar <- length(STATS) |
| 915 | 3x |
ACOV <- NULL |
| 916 | 3x |
if (se || unbiased) {
|
| 917 | ! |
ACOV <- rmsList.se.g[seq_len(nth), |
| 918 | ! |
seq_len(nth), |
| 919 | ! |
drop = FALSE |
| 920 |
] |
|
| 921 |
} |
|
| 922 | 3x |
RMS.TH <- lav_residuals_summary_rms( |
| 923 | 3x |
STATS = STATS, |
| 924 | 3x |
ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue, |
| 925 | 3x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 926 | 3x |
unbiased.ci = unbiased.ci, |
| 927 | 3x |
unbiased.ci.level = unbiased.ci.level, |
| 928 | 3x |
unbiased.zstat = unbiased.zstat, |
| 929 | 3x |
unbiased.test.val = unbiased.test.val, |
| 930 | 3x |
unbiased.pvalue = unbiased.pvalue, |
| 931 | 3x |
pstar = pstar, type = type[typ] |
| 932 |
) |
|
| 933 | ||
| 934 |
# MEAN |
|
| 935 |
# STATS <- rmsList.g[["mean"]] |
|
| 936 | 3x |
STATS <- numeric(0L) |
| 937 | 3x |
pstar <- length(STATS) |
| 938 | 3x |
ACOV <- NULL |
| 939 | 3x |
if (se || unbiased) {
|
| 940 |
# TODO: extract from rmsList.se.g |
|
| 941 |
} |
|
| 942 | 3x |
RMS.MEAN <- lav_residuals_summary_rms( |
| 943 | 3x |
STATS = STATS, |
| 944 | 3x |
ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue, |
| 945 | 3x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 946 | 3x |
unbiased.ci = unbiased.ci, |
| 947 | 3x |
unbiased.ci.level = unbiased.ci.level, |
| 948 | 3x |
unbiased.zstat = unbiased.zstat, |
| 949 | 3x |
unbiased.test.val = unbiased.test.val, |
| 950 | 3x |
unbiased.pvalue = unbiased.pvalue, |
| 951 | 3x |
pstar = pstar, type = type[typ] |
| 952 |
) |
|
| 953 | ||
| 954 |
# VAR (not ready yet) |
|
| 955 |
# STATS <- diag(rmsList.g[["cov"]])[lavmodel@num.idx[[g]]] |
|
| 956 | 3x |
STATS <- numeric(0L) |
| 957 | 3x |
pstar <- length(STATS) |
| 958 | 3x |
ACOV <- NULL |
| 959 | 3x |
if (se || unbiased) {
|
| 960 |
# TODO: extract from rmsList.se.g |
|
| 961 |
} |
|
| 962 | 3x |
RMS.VAR <- lav_residuals_summary_rms( |
| 963 | 3x |
STATS = STATS, |
| 964 | 3x |
ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue, |
| 965 | 3x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 966 | 3x |
unbiased.ci = unbiased.ci, |
| 967 | 3x |
unbiased.ci.level = unbiased.ci.level, |
| 968 | 3x |
unbiased.zstat = unbiased.zstat, |
| 969 | 3x |
unbiased.test.val = unbiased.test.val, |
| 970 | 3x |
unbiased.pvalue = unbiased.pvalue, |
| 971 | 3x |
pstar = pstar, type = type[typ] |
| 972 |
) |
|
| 973 | ||
| 974 |
# TOTAL -- FIXME: for conditional.x .... |
|
| 975 | 3x |
if (conditional.x) {
|
| 976 | 3x |
STATS <- c( |
| 977 | 3x |
lav_matrix_vech(rmsList.g[["res.cov"]], |
| 978 | 3x |
diagonal = FALSE |
| 979 |
), |
|
| 980 | 3x |
rmsList.g[["res.th"]] |
| 981 |
) |
|
| 982 |
} else {
|
|
| 983 | ! |
STATS <- c( |
| 984 | ! |
lav_matrix_vech(rmsList.g[["cov"]], |
| 985 | ! |
diagonal = FALSE |
| 986 |
), |
|
| 987 | ! |
rmsList.g[["th"]] |
| 988 |
) |
|
| 989 |
# rmsList.g[["mean"]], |
|
| 990 |
# diag(rmsList.g[["cov"]])[lavmodel@num.idx[[g]]]) |
|
| 991 |
} |
|
| 992 | ||
| 993 |
# should pstar be p*(p+1)/2 or p*(p-1)/2 for COV/COR? |
|
| 994 |
# we use the first for SRMR and the latter for CRMR |
|
| 995 | 3x |
if (type[typ] == "crmr") {
|
| 996 | 1x |
pstar <- length(STATS) |
| 997 |
} else {
|
|
| 998 | 2x |
pstar <- length(STATS) + nvar |
| 999 |
} |
|
| 1000 | ||
| 1001 |
# if(lavmodel@fixed.x) {
|
|
| 1002 |
# pstar <- pstar - pstar.x |
|
| 1003 |
# } |
|
| 1004 | ||
| 1005 | 3x |
ACOV <- NULL |
| 1006 | 3x |
if (se || unbiased) {
|
| 1007 | ! |
ACOV <- rmsList.se.g |
| 1008 |
} |
|
| 1009 | 3x |
RMS.TOTAL <- lav_residuals_summary_rms( |
| 1010 | 3x |
STATS = STATS, |
| 1011 | 3x |
ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue, |
| 1012 | 3x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 1013 | 3x |
unbiased.ci = unbiased.ci, |
| 1014 | 3x |
unbiased.ci.level = unbiased.ci.level, |
| 1015 | 3x |
unbiased.zstat = unbiased.zstat, |
| 1016 | 3x |
unbiased.test.val = unbiased.test.val, |
| 1017 | 3x |
unbiased.pvalue = unbiased.pvalue, |
| 1018 | 3x |
pstar = pstar, type = type[typ] |
| 1019 |
) |
|
| 1020 | ||
| 1021 | 3x |
TABLE <- as.data.frame(cbind( |
| 1022 | 3x |
RMS.COR, |
| 1023 | 3x |
RMS.TH, |
| 1024 |
# RMS.MEAN, |
|
| 1025 |
# RMS.VAR, |
|
| 1026 | 3x |
RMS.TOTAL |
| 1027 |
)) |
|
| 1028 |
# colnames(TABLE) <- c("cor", "thresholds", "mean",
|
|
| 1029 |
# "var", "total") |
|
| 1030 | 3x |
colnames(TABLE) <- c("cor", "thresholds", "total")
|
| 1031 | 3x |
if (add.class) {
|
| 1032 | ! |
class(TABLE) <- c("lavaan.data.frame", "data.frame")
|
| 1033 |
} |
|
| 1034 | 3x |
OUT[[typ]] <- TABLE |
| 1035 |
} # type |
|
| 1036 |
} # not conditional.x or mixed cat/con |
|
| 1037 | ||
| 1038 |
# continuous -- single level |
|
| 1039 | 23x |
} else if (lavdata@nlevels == 1L) {
|
| 1040 | 23x |
if ((se || unbiased) && conditional.x) {
|
| 1041 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 1042 |
} else {
|
|
| 1043 |
# nvar.x <- pstar.x <- 0L |
|
| 1044 |
# if(lavmodel@fixed.x) {
|
|
| 1045 |
# nvar.x <- lavmodel@nexo[g] |
|
| 1046 |
# pstar.x <- nvar.x * (nvar.x + 1) / 2 |
|
| 1047 |
# } |
|
| 1048 | ||
| 1049 | 23x |
OUT <- vector("list", length(type))
|
| 1050 | 23x |
names(OUT) <- type |
| 1051 | ||
| 1052 | 23x |
for (typ in seq_len(length(type))) {
|
| 1053 | 69x |
if (type[typ] == "rmr") {
|
| 1054 | 23x |
rmsList.g <- rmrList[[g]] |
| 1055 | 23x |
if (se || unbiased) {
|
| 1056 | ! |
rmsList.se.g <- rmrList.se[[g]] |
| 1057 |
} |
|
| 1058 | 46x |
} else if (type[typ] == "srmr") {
|
| 1059 | 23x |
rmsList.g <- srmrList[[g]] |
| 1060 | 23x |
if (se || unbiased) {
|
| 1061 | ! |
rmsList.se.g <- srmrList.se[[g]] |
| 1062 |
} |
|
| 1063 | 23x |
} else if (type[typ] == "crmr") {
|
| 1064 | 23x |
rmsList.g <- crmrList[[g]] |
| 1065 | 23x |
if (se || unbiased) {
|
| 1066 | ! |
rmsList.se.g <- crmrList.se[[g]] |
| 1067 |
} |
|
| 1068 |
} |
|
| 1069 | ||
| 1070 |
# COV |
|
| 1071 | 69x |
if (conditional.x) {
|
| 1072 | ! |
STATS <- lav_matrix_vech(rmsList.g[["res.cov"]]) |
| 1073 |
} else {
|
|
| 1074 | 69x |
STATS <- lav_matrix_vech(rmsList.g[["cov"]]) |
| 1075 |
} |
|
| 1076 |
# pstar <- ( length(STATS) - pstar.x ) |
|
| 1077 | 69x |
pstar <- length(STATS) |
| 1078 | 69x |
if (type[typ] == "crmr") {
|
| 1079 |
# pstar <- pstar - ( nvar - nvar.x ) |
|
| 1080 | 23x |
if (conditional.x) {
|
| 1081 | ! |
pstar <- pstar - nrow(rmsList.g[["res.cov"]]) |
| 1082 |
} else {
|
|
| 1083 | 23x |
pstar <- pstar - nvar |
| 1084 |
} |
|
| 1085 |
} |
|
| 1086 | ||
| 1087 | 69x |
ACOV <- NULL |
| 1088 | 69x |
if (se || unbiased) {
|
| 1089 | ! |
ACOV <- if (lavmodel@meanstructure) {
|
| 1090 | ! |
rmsList.se.g[-seq_len(nvar), |
| 1091 | ! |
-seq_len(nvar), |
| 1092 | ! |
drop = FALSE |
| 1093 |
] |
|
| 1094 |
} else {
|
|
| 1095 | ! |
rmsList.se.g |
| 1096 |
} |
|
| 1097 |
} |
|
| 1098 | 69x |
RMS.COV <- lav_residuals_summary_rms( |
| 1099 | 69x |
STATS = STATS, |
| 1100 | 69x |
ACOV = ACOV, se = se, zstat = zstat, pvalue = pvalue, |
| 1101 | 69x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 1102 | 69x |
unbiased.ci = unbiased.ci, |
| 1103 | 69x |
unbiased.ci.level = unbiased.ci.level, |
| 1104 | 69x |
unbiased.zstat = unbiased.zstat, |
| 1105 | 69x |
unbiased.test.val = unbiased.test.val, |
| 1106 | 69x |
unbiased.pvalue = unbiased.pvalue, |
| 1107 | 69x |
pstar = pstar, type = type[typ] |
| 1108 |
) |
|
| 1109 | ||
| 1110 |
# MEAN |
|
| 1111 | 69x |
if (lavmodel@meanstructure) {
|
| 1112 | 30x |
if (conditional.x) {
|
| 1113 | ! |
STATS <- rmsList.g[["res.int"]] |
| 1114 |
} else {
|
|
| 1115 | 30x |
STATS <- rmsList.g[["mean"]] |
| 1116 |
} |
|
| 1117 |
# pstar <- ( length(STATS) - nvar.x ) |
|
| 1118 | 30x |
pstar <- length(STATS) |
| 1119 | 30x |
ACOV <- NULL |
| 1120 | 30x |
if (se || unbiased) {
|
| 1121 | ! |
ACOV <- rmsList.se.g[seq_len(nvar), |
| 1122 | ! |
seq_len(nvar), |
| 1123 | ! |
drop = FALSE |
| 1124 |
] |
|
| 1125 |
} |
|
| 1126 | 30x |
RMS.MEAN <- lav_residuals_summary_rms( |
| 1127 | 30x |
STATS = STATS, |
| 1128 | 30x |
ACOV = ACOV, |
| 1129 | 30x |
se = se, zstat = zstat, pvalue = pvalue, |
| 1130 | 30x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 1131 | 30x |
unbiased.ci = unbiased.ci, |
| 1132 | 30x |
unbiased.ci.level = unbiased.ci.level, |
| 1133 | 30x |
unbiased.zstat = unbiased.zstat, |
| 1134 | 30x |
unbiased.test.val = unbiased.test.val, |
| 1135 | 30x |
unbiased.pvalue = unbiased.pvalue, |
| 1136 | 30x |
pstar = pstar, type = type[typ] |
| 1137 |
) |
|
| 1138 |
} |
|
| 1139 | ||
| 1140 |
# TOTAL |
|
| 1141 | 69x |
if (lavmodel@meanstructure) {
|
| 1142 | 30x |
if (conditional.x) {
|
| 1143 | ! |
STATS <- c( |
| 1144 | ! |
rmsList.g[["res.int"]], |
| 1145 | ! |
lav_matrix_vech(rmsList.g[["res.cov"]]) |
| 1146 |
) |
|
| 1147 |
} else {
|
|
| 1148 | 30x |
STATS <- c( |
| 1149 | 30x |
rmsList.g[["mean"]], |
| 1150 | 30x |
lav_matrix_vech(rmsList.g[["cov"]]) |
| 1151 |
) |
|
| 1152 |
} |
|
| 1153 |
# pstar <- ( length(STATS) - ( pstar.x + nvar.x) ) |
|
| 1154 | 30x |
pstar <- length(STATS) |
| 1155 | 30x |
if (type[typ] == "crmr") {
|
| 1156 |
# pstar <- pstar - ( nvar - nvar.x ) |
|
| 1157 | 10x |
pstar <- pstar - nvar |
| 1158 |
} |
|
| 1159 | 30x |
ACOV <- NULL |
| 1160 | 30x |
if (se || unbiased) {
|
| 1161 | ! |
ACOV <- rmsList.se.g |
| 1162 |
} |
|
| 1163 | 30x |
RMS.TOTAL <- lav_residuals_summary_rms( |
| 1164 | 30x |
STATS = STATS, |
| 1165 | 30x |
ACOV = ACOV, |
| 1166 | 30x |
se = se, zstat = zstat, pvalue = pvalue, |
| 1167 | 30x |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 1168 | 30x |
unbiased.ci = unbiased.ci, |
| 1169 | 30x |
unbiased.ci.level = unbiased.ci.level, |
| 1170 | 30x |
unbiased.zstat = unbiased.zstat, |
| 1171 | 30x |
unbiased.test.val = unbiased.test.val, |
| 1172 | 30x |
unbiased.pvalue = unbiased.pvalue, |
| 1173 | 30x |
pstar = pstar, type = type[typ] |
| 1174 |
) |
|
| 1175 |
} |
|
| 1176 | ||
| 1177 |
# CUSTOM |
|
| 1178 | 69x |
if (length(custom.rmr)) {
|
| 1179 | ! |
if (lavmodel@fixed.x && !lavmodel@conditional.x) {
|
| 1180 |
## save exogenous-variable indices, use to remove or set |
|
| 1181 |
## FALSE any moments that cannot have nonzero residuals |
|
| 1182 | ! |
x.idx <- which(rownames(rmsList.g$cov) %in% object@Data@ov.names.x[[g]]) |
| 1183 |
} |
|
| 1184 | ||
| 1185 | ! |
RMS.CUSTOM.LIST <- vector("list", length(customNAMES))
|
| 1186 | ||
| 1187 | ! |
for (cus in customNAMES) {
|
| 1188 |
## in case there is no meanstructure |
|
| 1189 | ! |
STATS <- NULL |
| 1190 | ! |
ACOV.idx <- NULL |
| 1191 | ||
| 1192 |
# MEANS? |
|
| 1193 | ! |
if (lavmodel@meanstructure) {
|
| 1194 | ! |
if ("mean" %in% names(custom.rmr[[cus]])) {
|
| 1195 |
## if logical, save numeric indices |
|
| 1196 | ! |
if (is.logical(custom.rmr[[cus]]$mean)) {
|
| 1197 |
## check length |
|
| 1198 | ! |
if (length(custom.rmr[[cus]]$mean) != length(rmsList.g[["mean"]])) {
|
| 1199 | ! |
lav_msg_stop(gettextf("length(custom.rmr$%s$mean) must
|
| 1200 | ! |
match length(lavResiduals(fit)$mean)", cus)) |
| 1201 |
} |
|
| 1202 | ! |
ACOV.idx <- which(custom.rmr[[cus]]$mean) |
| 1203 | ! |
if (lavmodel@fixed.x && !lavmodel@conditional.x) {
|
| 1204 | ! |
ACOV.idx[x.idx] <- FALSE |
| 1205 |
} |
|
| 1206 | ! |
} else if (!is.numeric(custom.rmr[[cus]]$mean)) {
|
| 1207 | ! |
lav_msg_stop(gettextf("custom.rmr$%s$mean must contain
|
| 1208 | ! |
logical or numeric indices.", cus)) |
| 1209 |
} else {
|
|
| 1210 | ! |
ACOV.idx <- custom.rmr[[cus]]$mean |
| 1211 | ! |
if (lavmodel@fixed.x && !lavmodel@conditional.x) {
|
| 1212 | ! |
ACOV.idx <- setdiff(ACOV.idx, x.idx) |
| 1213 |
} |
|
| 1214 | ! |
ACOV.idx <- ACOV.idx[!is.na(ACOV.idx)] # necessary? |
| 1215 | ! |
if (max(ACOV.idx) > length(rmsList.g[["mean"]])) {
|
| 1216 | ! |
lav_msg_stop(gettextf( |
| 1217 | ! |
"custom.rmr$%1$s$mean[%2$s] is an out-of-bounds index", |
| 1218 | ! |
cus, which.max(ACOV.idx)) |
| 1219 |
) |
|
| 1220 |
} |
|
| 1221 |
} |
|
| 1222 | ! |
STATS <- rmsList.g[["mean"]][ACOV.idx] |
| 1223 |
} |
|
| 1224 |
} |
|
| 1225 |
# (CO)VARIANCES? |
|
| 1226 | ! |
if ("cov" %in% names(custom.rmr[[cus]])) {
|
| 1227 |
## if numeric, create a logical matrix to obtain |
|
| 1228 |
## ACOV.idx and check for x.idx |
|
| 1229 | ! |
if (is.numeric(custom.rmr[[cus]]$cov)) {
|
| 1230 | ! |
cusCOV <- rmsList.g[["cov"]] == "start with all FALSE" |
| 1231 |
## matrix of row/column indices? |
|
| 1232 | ! |
if (length(dim(custom.rmr[[cus]]$cov))) {
|
| 1233 | ! |
if (max(custom.rmr[[cus]]$cov[, 1:2] > nrow(rmsList.g[["cov"]]))) {
|
| 1234 | ! |
lav_msg_stop(gettextf( |
| 1235 | ! |
"numeric indices in custom.rmr$%1$s$cov cannot |
| 1236 | ! |
exceed %2$s", cus, nrow(rmsList.g[["cov"]]))) |
| 1237 |
} |
|
| 1238 | ! |
for (RR in 1:nrow(custom.rmr[[cus]]$cov)) {
|
| 1239 | ! |
cusCOV[ |
| 1240 | ! |
custom.rmr[[cus]]$cov[RR, 1], |
| 1241 | ! |
custom.rmr[[cus]]$cov[RR, 2] |
| 1242 | ! |
] <- TRUE |
| 1243 |
} |
|
| 1244 |
} else {
|
|
| 1245 |
## numeric-vector indices |
|
| 1246 | ! |
if (max(custom.rmr[[cus]]$cov > length(rmsList.g[["cov"]]))) {
|
| 1247 | ! |
lav_msg_stop(gettextf( |
| 1248 | ! |
"numeric indices in custom.rmr$%1$s$cov cannot |
| 1249 | ! |
exceed %2$s", cus, length(rmsList.g[["cov"]]))) |
| 1250 |
} |
|
| 1251 | ! |
cusCOV[custom.rmr[[cus]]$cov] <- TRUE |
| 1252 |
} |
|
| 1253 | ||
| 1254 |
## numeric indices no longer needed, use logical |
|
| 1255 | ! |
custom.rmr[[cus]]$cov <- cusCOV |
| 1256 | ! |
} else if (!is.logical(custom.rmr[[cus]]$cov)) {
|
| 1257 | ! |
lav_msg_stop(gettextf( |
| 1258 | ! |
"custom.rmr$%s$cov must be a logical square matrix or a |
| 1259 | ! |
numeric matrix of (row/column) indices.", cus)) |
| 1260 |
} |
|
| 1261 | ||
| 1262 |
## check dimensions |
|
| 1263 | ! |
if (!all(dim(custom.rmr[[cus]]$cov) == dim(rmsList.g[["cov"]]))) {
|
| 1264 | ! |
lav_msg_stop(gettextf( |
| 1265 | ! |
"dim(custom.rmr$%s$cov) must match |
| 1266 | ! |
dim(lavResiduals(fit)$cov)", cus)) |
| 1267 |
} |
|
| 1268 |
## users can specify upper.tri or lower.tri indices |
|
| 1269 | ! |
custom.rmr[[cus]]$cov <- custom.rmr[[cus]]$cov | t(custom.rmr[[cus]]$cov) |
| 1270 |
## but ACOV refers to lower.tri indices |
|
| 1271 | ! |
custom.rmr[[cus]]$cov[upper.tri(custom.rmr[[cus]]$cov)] <- FALSE |
| 1272 |
## diagonal relevant? |
|
| 1273 | ! |
if (type[typ] == "crmr") diag(custom.rmr[[cus]]$cov) <- FALSE |
| 1274 |
## extract lower.tri indices |
|
| 1275 | ! |
vech.idx <- which(lav_matrix_vech(custom.rmr[[cus]]$cov)) |
| 1276 | ||
| 1277 |
## add residuals to STATS, indices to ACOV.idx |
|
| 1278 | ! |
STATS <- c(STATS, lav_matrix_vech(rmsList.g[["cov"]])[vech.idx]) |
| 1279 | ! |
ACOV.idx <- c(ACOV.idx, vech.idx) |
| 1280 |
} |
|
| 1281 | ||
| 1282 | ||
| 1283 |
## count residuals in summary (x.idx already removed) |
|
| 1284 | ! |
pstar <- length(STATS) |
| 1285 | ||
| 1286 | ! |
ACOV <- NULL |
| 1287 | ! |
if (se || unbiased) {
|
| 1288 | ! |
ACOV <- rmsList.se.g[ACOV.idx, ACOV.idx, drop = FALSE] |
| 1289 |
} |
|
| 1290 | ! |
RMS.CUSTOM.LIST[[cus]] <- lav_residuals_summary_rms( |
| 1291 | ! |
STATS = STATS, |
| 1292 | ! |
ACOV = ACOV, |
| 1293 | ! |
se = se, zstat = zstat, pvalue = pvalue, |
| 1294 | ! |
unbiased = unbiased, unbiased.se = unbiased.se, |
| 1295 | ! |
unbiased.ci = unbiased.ci, |
| 1296 | ! |
unbiased.ci.level = unbiased.ci.level, |
| 1297 | ! |
unbiased.zstat = unbiased.zstat, |
| 1298 | ! |
unbiased.test.val = unbiased.test.val, |
| 1299 | ! |
unbiased.pvalue = unbiased.pvalue, |
| 1300 | ! |
pstar = pstar, type = type[typ] |
| 1301 |
) |
|
| 1302 | ||
| 1303 |
# FIXME: update for categorical |
|
| 1304 |
} # cus |
|
| 1305 | ! |
RMS.CUSTOM <- do.call(rbind, RMS.CUSTOM.LIST) |
| 1306 |
} else {
|
|
| 1307 | 69x |
RMS.CUSTOM <- NULL |
| 1308 |
} |
|
| 1309 | ||
| 1310 | ||
| 1311 | 69x |
if (lavmodel@meanstructure) {
|
| 1312 | 30x |
TABLE <- as.data.frame(cbind( |
| 1313 | 30x |
RMS.COV, |
| 1314 | 30x |
RMS.MEAN, |
| 1315 | 30x |
RMS.TOTAL, |
| 1316 | 30x |
RMS.CUSTOM |
| 1317 |
)) |
|
| 1318 | 30x |
colnames(TABLE) <- c( |
| 1319 | 30x |
"cov", "mean", "total", |
| 1320 | 30x |
customNAMES |
| 1321 |
) |
|
| 1322 |
} else {
|
|
| 1323 | 39x |
TABLE <- as.data.frame(cbind(RMS.COV, RMS.CUSTOM)) |
| 1324 | 39x |
colnames(TABLE) <- c("cov", customNAMES)
|
| 1325 |
} |
|
| 1326 | 69x |
if (add.class) {
|
| 1327 | ! |
class(TABLE) <- c("lavaan.data.frame", "data.frame")
|
| 1328 |
} |
|
| 1329 | 69x |
OUT[[typ]] <- TABLE |
| 1330 |
} # type |
|
| 1331 |
} # continuous, single-level, unconditional |
|
| 1332 | ||
| 1333 |
# continuous -- multilevel |
|
| 1334 | ! |
} else if (lavdata@nlevels > 1L) {
|
| 1335 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 1336 |
} |
|
| 1337 | ||
| 1338 | 24x |
sumStat[[g]] <- OUT |
| 1339 |
} # g |
|
| 1340 | ||
| 1341 | 23x |
sumStat |
| 1342 |
} |
|
| 1343 | ||
| 1344 | ||
| 1345 |
lav_residuals_summary_rms <- function(STATS = NULL, ACOV = NULL, |
|
| 1346 |
se = FALSE, |
|
| 1347 |
level = 0.90, |
|
| 1348 |
zstat = FALSE, pvalue = FALSE, |
|
| 1349 |
unbiased = FALSE, |
|
| 1350 |
unbiased.se = FALSE, |
|
| 1351 |
unbiased.ci = FALSE, |
|
| 1352 |
unbiased.ci.level = 0.90, |
|
| 1353 |
unbiased.zstat = FALSE, |
|
| 1354 |
unbiased.test.val = 0.05, |
|
| 1355 |
unbiased.pvalue = FALSE, |
|
| 1356 |
pstar = 0, type = "rms") {
|
|
| 1357 | 144x |
OUT <- vector("list", length = 0L)
|
| 1358 | ||
| 1359 | ||
| 1360 |
# covariance matrix |
|
| 1361 | 144x |
if (length(STATS) > 0L) {
|
| 1362 | 138x |
rms <- sqrt(sum(STATS * STATS) / pstar) |
| 1363 |
} else {
|
|
| 1364 | 6x |
rms <- 0 |
| 1365 | 6x |
se <- unbiased <- zstat <- FALSE |
| 1366 |
} |
|
| 1367 | ||
| 1368 |
# default is NULL |
|
| 1369 | 144x |
rms.se <- rms.z <- rms.pvalue <- NULL |
| 1370 | 144x |
urms <- urms.se <- urms.z <- urms.pvalue <- NULL |
| 1371 | 144x |
urms.ci.lower <- urms.ci.upper <- NULL |
| 1372 | 144x |
if (!unbiased.zstat) {
|
| 1373 | 144x |
unbiased.test.val <- NULL |
| 1374 |
} |
|
| 1375 | ||
| 1376 | 144x |
if (se || unbiased) {
|
| 1377 | ! |
TR2 <- sum(diag(ACOV %*% ACOV)) |
| 1378 | ! |
TR1 <- sum(diag(ACOV)) |
| 1379 | ! |
if (se) {
|
| 1380 | ! |
rms.avar <- TR2 / (TR1 * 2 * pstar) |
| 1381 | ! |
if (!is.finite(rms.avar) || rms.avar < .Machine$double.eps) {
|
| 1382 | ! |
rms.se <- as.numeric(NA) |
| 1383 |
} else {
|
|
| 1384 | ! |
rms.se <- sqrt(rms.avar) |
| 1385 |
} |
|
| 1386 |
} |
|
| 1387 |
} |
|
| 1388 | ||
| 1389 | 144x |
if (zstat) {
|
| 1390 | ! |
E.rms <- (sqrt(TR1 / pstar) * (4 * TR1 * TR1 - TR2) / (4 * TR1 * TR1)) |
| 1391 | ! |
rms.z <- max((rms - E.rms), 0) / rms.se |
| 1392 | ! |
if (pvalue) {
|
| 1393 | ! |
rms.pvalue <- 1 - pnorm(rms.z) |
| 1394 |
} |
|
| 1395 |
} |
|
| 1396 | ||
| 1397 | 144x |
if (unbiased) {
|
| 1398 | ! |
T.cov <- as.numeric(crossprod(STATS)) |
| 1399 | ! |
eVe <- as.numeric(t(STATS) %*% ACOV %*% STATS) |
| 1400 | ! |
k.cov <- 1 - (TR2 + 2 * eVe) / (4 * T.cov * T.cov) |
| 1401 | ! |
urms <- (1 / k.cov * sqrt(max((T.cov - TR1), 0) / pstar)) |
| 1402 | ! |
if (unbiased.se) {
|
| 1403 | ! |
urms.avar <- (1 / (k.cov * k.cov) * (TR2 + 2 * eVe) / (2 * pstar * T.cov)) |
| 1404 | ! |
if (!is.finite(urms.avar) || urms.avar < .Machine$double.eps) {
|
| 1405 | ! |
urms.se <- as.numeric(NA) |
| 1406 |
} else {
|
|
| 1407 | ! |
urms.se <- sqrt(urms.avar) |
| 1408 |
} |
|
| 1409 | ! |
if (unbiased.ci) {
|
| 1410 | ! |
a <- (1 - unbiased.ci.level) / 2 |
| 1411 | ! |
a <- c(a, 1 - a) |
| 1412 | ! |
fac <- stats::qnorm(a) |
| 1413 | ! |
urms.ci.lower <- urms + urms.se * fac[1] |
| 1414 | ! |
urms.ci.upper <- urms + urms.se * fac[2] |
| 1415 |
} |
|
| 1416 | ! |
if (unbiased.zstat) {
|
| 1417 | ! |
urms.z <- (urms - unbiased.test.val) / urms.se |
| 1418 | ! |
if (unbiased.pvalue) {
|
| 1419 | ! |
urms.pvalue <- 1 - pnorm(urms.z) |
| 1420 |
} |
|
| 1421 |
} |
|
| 1422 |
} |
|
| 1423 |
} |
|
| 1424 | ||
| 1425 |
# labels |
|
| 1426 | 144x |
if (type == "rmr") {
|
| 1427 | 48x |
OUT <- list( |
| 1428 | 48x |
rmr = rms, rmr.se = rms.se, |
| 1429 | 48x |
rmr.exactfit.z = rms.z, rmr.exactfit.pvalue = rms.pvalue, |
| 1430 | 48x |
urmr = urms, urmr.se = urms.se, |
| 1431 | 48x |
urmr.ci.lower = urms.ci.lower, |
| 1432 | 48x |
urmr.ci.upper = urms.ci.upper, |
| 1433 | 48x |
urmr.closefit.h0.value = unbiased.test.val, |
| 1434 | 48x |
urmr.closefit.z = urms.z, |
| 1435 | 48x |
urmr.closefit.pvalue = urms.pvalue |
| 1436 |
) |
|
| 1437 | 96x |
} else if (type == "srmr") {
|
| 1438 | 48x |
OUT <- list( |
| 1439 | 48x |
srmr = rms, srmr.se = rms.se, |
| 1440 | 48x |
srmr.exactfit.z = rms.z, srmr.exactfit.pvalue = rms.pvalue, |
| 1441 | 48x |
usrmr = urms, usrmr.se = urms.se, |
| 1442 | 48x |
usrmr.ci.lower = urms.ci.lower, |
| 1443 | 48x |
usrmr.ci.upper = urms.ci.upper, |
| 1444 | 48x |
usrmr.closefit.h0.value = unbiased.test.val, |
| 1445 | 48x |
usrmr.closefit.z = urms.z, |
| 1446 | 48x |
usrmr.closefit.pvalue = urms.pvalue |
| 1447 |
) |
|
| 1448 | 48x |
} else if (type == "crmr") {
|
| 1449 | 48x |
OUT <- list( |
| 1450 | 48x |
crmr = rms, crmr.se = rms.se, |
| 1451 | 48x |
crmr.exactfit.z = rms.z, crmr.exactfit.pvalue = rms.pvalue, |
| 1452 | 48x |
ucrmr = urms, ucrmr.se = urms.se, |
| 1453 | 48x |
ucrmr.ci.lower = urms.ci.lower, |
| 1454 | 48x |
ucrmr.ci.upper = urms.ci.upper, |
| 1455 | 48x |
ucrmr.closefit.h0.value = unbiased.test.val, |
| 1456 | 48x |
ucrmr.closefit.z = urms.z, |
| 1457 | 48x |
ucrmr.closefit.pvalue = urms.pvalue |
| 1458 |
) |
|
| 1459 |
} |
|
| 1460 | ||
| 1461 | 144x |
unlist(OUT) |
| 1462 |
} |
|
| 1463 | ||
| 1464 |
# generate summary statistics for the residuals |
|
| 1465 |
lav_residuals_summary_old <- function(resList = NULL, |
|
| 1466 |
add.class = FALSE, add.labels = FALSE) {
|
|
| 1467 |
# per block |
|
| 1468 | ! |
nblocks <- length(resList) |
| 1469 | ||
| 1470 | ! |
for (b in seq_len(nblocks)) {
|
| 1471 |
# create new list, including with summary statistics interleaved |
|
| 1472 | ! |
x <- vector("list", length = 0L)
|
| 1473 | ! |
nel <- length(resList[[b]]) |
| 1474 | ! |
NAMES <- names(resList[[b]]) |
| 1475 | ||
| 1476 | ! |
for (el in seq_len(nel)) {
|
| 1477 | ! |
EL <- resList[[b]][[el]] |
| 1478 | ! |
if (!is.null(NAMES)) {
|
| 1479 | ! |
NAME <- NAMES[el] |
| 1480 |
} |
|
| 1481 | ||
| 1482 | ! |
if (is.character(EL)) {
|
| 1483 | ! |
new.x <- list(EL) |
| 1484 | ! |
if (add.labels) {
|
| 1485 | ! |
names(new.x) <- "type" |
| 1486 |
} |
|
| 1487 | ! |
x <- c(x, new.x) |
| 1488 | ! |
} else if (is.matrix(EL) && isSymmetric(EL)) {
|
| 1489 | ! |
tmp <- na.omit(lav_matrix_vech(EL)) |
| 1490 | ! |
rms <- sqrt(sum(tmp * tmp) / length(tmp)) |
| 1491 | ! |
mabs <- mean(abs(tmp)) |
| 1492 | ! |
tmp2 <- na.omit(lav_matrix_vech(EL, diagonal = FALSE)) |
| 1493 | ! |
rms.nodiag <- sqrt(sum(tmp2 * tmp2) / length(tmp2)) |
| 1494 | ! |
mabs.nodiag <- mean(abs(tmp2)) |
| 1495 | ! |
cov.summary <- c(rms, rms.nodiag, mabs, mabs.nodiag) |
| 1496 | ! |
if (add.labels) {
|
| 1497 | ! |
names(cov.summary) <- |
| 1498 | ! |
c("rms", "rms.nodiag", "mabs", "mabs.nodiag")
|
| 1499 |
} |
|
| 1500 | ! |
if (add.class) {
|
| 1501 | ! |
class(cov.summary) <- c("lavaan.vector", "numeric")
|
| 1502 |
} |
|
| 1503 | ! |
new.x <- list(EL, cov.summary) |
| 1504 | ! |
if (add.labels && !is.null(NAMES)) {
|
| 1505 | ! |
names(new.x) <- c(NAME, paste0(NAME, ".summary")) |
| 1506 |
} |
|
| 1507 | ! |
x <- c(x, new.x) |
| 1508 |
} else {
|
|
| 1509 | ! |
tmp <- na.omit(EL) |
| 1510 | ! |
rms <- sqrt(sum(tmp * tmp) / length(tmp)) |
| 1511 | ! |
mabs <- mean(abs(tmp)) |
| 1512 | ! |
mean.summary <- c(rms, mabs) |
| 1513 | ! |
if (add.labels) {
|
| 1514 | ! |
names(mean.summary) <- c("rms", "mabs")
|
| 1515 |
} |
|
| 1516 | ! |
if (add.class) {
|
| 1517 | ! |
class(mean.summary) <- c("lavaan.vector", "numeric")
|
| 1518 |
} |
|
| 1519 | ! |
new.x <- list(EL, mean.summary) |
| 1520 | ! |
if (add.labels && !is.null(NAMES)) {
|
| 1521 | ! |
names(new.x) <- c(NAME, paste0(NAME, ".summary")) |
| 1522 |
} |
|
| 1523 | ! |
x <- c(x, new.x) |
| 1524 |
} |
|
| 1525 |
} # nel |
|
| 1526 | ||
| 1527 |
# fill in block including summary statistics |
|
| 1528 | ! |
resList[[b]] <- x |
| 1529 |
} # nblocks |
|
| 1530 | ||
| 1531 | ! |
resList |
| 1532 |
} |
|
| 1533 | ||
| 1534 | ||
| 1535 |
# x is a list with sample statistics (eg output of lavInspect(fit, "sampstat") |
|
| 1536 |
# y is another (possibly the same) list with sample statistics |
|
| 1537 |
# |
|
| 1538 |
# to avoid many 'NAs', we set the scale-factor to 1 |
|
| 1539 |
# if the to-be-scaled value is < 1e-05 (in absolute value) |
|
| 1540 |
lav_residuals_rescale <- function(x, diag.cov = NULL, diag.cov2 = NULL) {
|
|
| 1541 | 96x |
if (is.null(diag.cov2)) {
|
| 1542 | 72x |
diag.cov2 <- diag.cov |
| 1543 |
} |
|
| 1544 | ||
| 1545 |
# make sure we can take the sqrt and invert |
|
| 1546 | 96x |
diag.cov[!is.finite(diag.cov)] <- NA |
| 1547 | 96x |
diag.cov[diag.cov < .Machine$double.eps] <- NA |
| 1548 | 96x |
scale.cov <- tcrossprod(1 / sqrt(diag.cov)) |
| 1549 | ||
| 1550 |
# for the mean, we use diag.cov2 |
|
| 1551 | 96x |
diag.cov2[!is.finite(diag.cov2)] <- NA |
| 1552 | 96x |
diag.cov2[diag.cov2 < .Machine$double.eps] <- NA |
| 1553 | 96x |
scale.mean <- 1 / sqrt(diag.cov2) |
| 1554 | ||
| 1555 |
# rescale cov |
|
| 1556 | 96x |
if (!is.null(x[["cov"]])) {
|
| 1557 |
# catch (near) zero elements in x$cov |
|
| 1558 | 92x |
near.zero.idx <- which(abs(x[["cov"]]) < 1e-05) |
| 1559 | 92x |
scale.cov[near.zero.idx] <- 1 |
| 1560 | 92x |
x[["cov"]][] <- x[["cov"]] * scale.cov |
| 1561 |
} |
|
| 1562 | 96x |
if (!is.null(x[["res.cov"]])) {
|
| 1563 |
# catch (near) zero elements in x$res.cov |
|
| 1564 | 4x |
near.zero.idx <- which(abs(x[["res.cov"]]) < 1e-05) |
| 1565 | 4x |
scale.cov[near.zero.idx] <- 1 |
| 1566 | 4x |
x[["res.cov"]][] <- x[["res.cov"]] * scale.cov |
| 1567 |
} |
|
| 1568 | ||
| 1569 |
# rescale int/mean |
|
| 1570 | 96x |
if (!is.null(x[["res.int"]])) {
|
| 1571 |
# catch (near) zero elements in x$res.int |
|
| 1572 | 4x |
near.zero.idx <- which(abs(x[["res.int"]]) < 1e-05) |
| 1573 | 4x |
scale.mean[near.zero.idx] <- 1 |
| 1574 | 4x |
x[["res.int"]] <- x[["res.int"]] * scale.mean |
| 1575 |
} |
|
| 1576 | ||
| 1577 | 96x |
if (!is.null(x[["mean"]])) {
|
| 1578 |
# catch (near) zero elements in x$mean |
|
| 1579 | 40x |
near.zero.idx <- which(abs(x[["mean"]]) < 1e-05) |
| 1580 | 40x |
scale.mean[near.zero.idx] <- 1 |
| 1581 | 40x |
x[["mean"]] <- x[["mean"]] * scale.mean |
| 1582 |
} |
|
| 1583 | ||
| 1584 |
# FIXME: do something sensible for th, slopes, ... |
|
| 1585 | ||
| 1586 | 96x |
x |
| 1587 |
} |
| 1 |
lav_partable_flat <- function(FLAT = NULL, # nolint |
|
| 2 |
blocks = "group", |
|
| 3 |
block.id = NULL, |
|
| 4 |
meanstructure = FALSE, |
|
| 5 |
int.ov.free = FALSE, |
|
| 6 |
int.lv.free = FALSE, |
|
| 7 |
orthogonal = FALSE, |
|
| 8 |
orthogonal.y = FALSE, |
|
| 9 |
orthogonal.x = FALSE, |
|
| 10 |
orthogonal.efa = FALSE, |
|
| 11 |
std.lv = FALSE, |
|
| 12 |
correlation = FALSE, |
|
| 13 |
composites = TRUE, |
|
| 14 |
conditional.x = FALSE, |
|
| 15 |
fixed.x = TRUE, |
|
| 16 |
parameterization = "delta", |
|
| 17 |
auto.fix.first = FALSE, |
|
| 18 |
auto.fix.single = FALSE, |
|
| 19 |
auto.var = FALSE, |
|
| 20 |
auto.cov.lv.x = FALSE, |
|
| 21 |
auto.cov.y = FALSE, |
|
| 22 |
auto.th = FALSE, |
|
| 23 |
auto.delta = FALSE, |
|
| 24 |
auto.efa = FALSE, |
|
| 25 |
varTable = NULL, # nolint |
|
| 26 |
group.equal = NULL, |
|
| 27 |
group.w.free = FALSE, |
|
| 28 |
ngroups = 1L, |
|
| 29 |
nthresholds = NULL, |
|
| 30 |
ov.names.x.block = NULL) {
|
|
| 31 | 69x |
categorical <- FALSE |
| 32 | ||
| 33 |
### tmp.default elements: parameters that are typically not specified by |
|
| 34 |
### users, but should typically be considered, |
|
| 35 |
### either free or fixed |
|
| 36 | ||
| 37 |
# extract `names' of various types of variables: |
|
| 38 | 69x |
lv.names <- lav_partable_vnames(FLAT, type = "lv") # latent variables |
| 39 |
# lv.names.r <- lav_partable_vnames(FLAT, type="lv.regular") |
|
| 40 |
# regular latent variables |
|
| 41 | 69x |
if (composites) {
|
| 42 | 69x |
lv.names.f <- character(0L) |
| 43 | 69x |
lv.names.c <- lav_partable_vnames(FLAT, type = "lv.composite") |
| 44 | 69x |
ov.ind.c <- lav_partable_vnames(FLAT, type = "ov.cind") |
| 45 | 69x |
lv.names.noc <- lv.names[!lv.names %in% lv.names.c] |
| 46 |
} else {
|
|
| 47 | ! |
lv.names.c <- character(0L) |
| 48 | ! |
ov.ind.c <- character(0L) |
| 49 | ! |
lv.names.f <- lav_partable_vnames(FLAT, type = "lv.formative") |
| 50 | ! |
lv.names.noc <- lv.names |
| 51 |
} |
|
| 52 | ||
| 53 |
# formative latent variables |
|
| 54 | 69x |
ov.names <- lav_partable_vnames(FLAT, type = "ov") |
| 55 |
# observed variables |
|
| 56 | 69x |
ov.names.x <- lav_partable_vnames(FLAT, type = "ov.x") |
| 57 |
# exogenous x covariates |
|
| 58 | 69x |
lv.names.int <- lav_partable_vnames(FLAT, type = "lv.interaction") |
| 59 |
# lv interactions |
|
| 60 | ||
| 61 | 69x |
if (is.null(ov.names.x.block)) {
|
| 62 | 69x |
ov.names.x.block <- ov.names.x |
| 63 |
} |
|
| 64 | 69x |
ov.names.nox <- lav_partable_vnames(FLAT, type = "ov.nox") |
| 65 | 69x |
lv.names.x <- lav_partable_vnames(FLAT, type = "lv.x") # exogenous lv |
| 66 | 69x |
ov.names.y <- lav_partable_vnames(FLAT, type = "ov.y") # dependent ov |
| 67 | 69x |
lv.names.y <- lav_partable_vnames(FLAT, type = "lv.y") # dependent lv |
| 68 | 69x |
lv.names.efa <- lav_partable_vnames(FLAT, type = "lv.efa") |
| 69 |
# lvov.names.y <- c(ov.names.y, lv.names.y) |
|
| 70 | 69x |
lvov.names.y <- c(lv.names.y, ov.names.y) |
| 71 | ||
| 72 |
# get 'ordered' variables, either from FLAT or varTable |
|
| 73 | 69x |
ov.names.ord1 <- lav_partable_vnames(FLAT, type = "ov.ord") |
| 74 |
# check if we have "|" for exogenous variables |
|
| 75 | 69x |
if (length(ov.names.ord1) > 0L) {
|
| 76 | ! |
idx <- which(ov.names.ord1 %in% ov.names.x) |
| 77 | ! |
if (length(idx) > 0L) {
|
| 78 | ! |
lav_msg_warn(gettext("thresholds are defined for exogenous variables:"),
|
| 79 | ! |
lav_msg_view(ov.names.ord1[idx], "none")) |
| 80 |
} |
|
| 81 |
} |
|
| 82 | ||
| 83 |
# check data |
|
| 84 | 69x |
if (!is.null(varTable)) {
|
| 85 | 51x |
ov.names.ord2 <- |
| 86 | 51x |
as.character(varTable$name[varTable$type == "ordered"]) |
| 87 |
# remove fixed.x variables |
|
| 88 | 51x |
idx <- which(ov.names.ord2 %in% ov.names.x) |
| 89 | 51x |
if (length(idx) > 0L) {
|
| 90 | ! |
ov.names.ord2 <- ov.names.ord2[-idx] |
| 91 |
} |
|
| 92 | ||
| 93 |
# remove those that do appear in the model syntax |
|
| 94 | 51x |
idx <- which(!ov.names.ord2 %in% ov.names) |
| 95 | 51x |
if (length(idx) > 0L) {
|
| 96 | ! |
ov.names.ord2 <- ov.names.ord2[-idx] |
| 97 |
} |
|
| 98 |
} else {
|
|
| 99 | 18x |
ov.names.ord2 <- character(0L) |
| 100 |
} |
|
| 101 | ||
| 102 |
# check nthresholds, if it is a named vector |
|
| 103 | 69x |
ov.names.ord3 <- character(0L) |
| 104 | 69x |
if (!is.null(nthresholds)) {
|
| 105 | ! |
if (!is.null(varTable)) {
|
| 106 | ! |
lav_msg_stop(gettext( |
| 107 | ! |
"the varTable and nthresholds arguments should not be used together.")) |
| 108 |
} |
|
| 109 | ! |
if (!is.numeric(nthresholds)) {
|
| 110 | ! |
lav_msg_stop(gettext("nthresholds should be a named vector of integers."))
|
| 111 |
} |
|
| 112 | ! |
nth.names <- names(nthresholds) |
| 113 | ! |
if (!is.null(nth.names)) {
|
| 114 | ! |
ov.names.ord3 <- nth.names |
| 115 |
} else {
|
|
| 116 |
# if nthresholds is just a number, all is good; otherwise it |
|
| 117 |
# should be a names vector |
|
| 118 | ! |
if (length(nthresholds) > 1L) {
|
| 119 | ! |
lav_msg_warn(gettext("nthresholds must be a named vector of integers."))
|
| 120 |
} |
|
| 121 |
# just a single number -> assume ALL y variables are ordered |
|
| 122 | ! |
ov.names.ord3 <- ov.names.nox |
| 123 |
} |
|
| 124 |
} |
|
| 125 | ||
| 126 |
# final ov.names.ord |
|
| 127 | 69x |
tmp <- unique(c(ov.names.ord1, ov.names.ord2, ov.names.ord3)) |
| 128 | 69x |
ov.names.ord <- ov.names[ov.names %in% tmp] |
| 129 | ||
| 130 |
# if we have the "|" in the model syntax, check the number of thresholds |
|
| 131 |
# if(!is.null(varTable) && length(ov.names.ord1) > 0L) {
|
|
| 132 |
# for(o in ov.names.ord1) {
|
|
| 133 |
# nth <- varTable$nlev[ varTable$name == o ] - 1L |
|
| 134 |
# nth.in.partable <- sum(FLAT$op == "|" & FLAT$lhs == o) |
|
| 135 |
# if(nth != nth.in.partable) {
|
|
| 136 |
# stop("lavaan ERROR: expected ", max(0,nth),
|
|
| 137 |
# " threshold(s) for variable ", |
|
| 138 |
# sQuote(o), "; syntax contains ", nth.in.partable, "\n") |
|
| 139 |
# } |
|
| 140 |
# } |
|
| 141 |
# } |
|
| 142 | ||
| 143 | 69x |
if (length(ov.names.ord) > 0L) {
|
| 144 | 2x |
categorical <- TRUE |
| 145 |
} |
|
| 146 | ||
| 147 |
# do we have any EFA lv's? they need special treatment if auto.efa = TRUE |
|
| 148 | 69x |
if (!is.null(FLAT$efa) && auto.efa) {
|
| 149 | 53x |
lv.names.efa <- unique(FLAT$lhs[FLAT$op == "=~" & |
| 150 | 53x |
nchar(FLAT$efa) > 0L]) |
| 151 |
# remove them from lv.names.x |
|
| 152 |
# if(length(lv.names.x) > 0L) {
|
|
| 153 |
# both.idx <- which(lv.names.x %in% lv.names.efa) |
|
| 154 |
# if(length(both.idx) > 0L) {
|
|
| 155 |
# lv.names.x <- lv.names.x[ -both.idx ] |
|
| 156 |
# } |
|
| 157 |
# } |
|
| 158 | ||
| 159 |
# remove them from lvov.names.y |
|
| 160 |
# if(length(lvov.names.y) > 0L) {
|
|
| 161 |
# both.idx <- which(lvov.names.y %in% lv.names.efa) |
|
| 162 |
# if(length(both.idx) > 0L) {
|
|
| 163 |
# lvov.names.y <- lvov.names.y[ -both.idx ] |
|
| 164 |
# } |
|
| 165 |
# } |
|
| 166 |
} else {
|
|
| 167 | 16x |
lv.names.efa <- character(0) |
| 168 |
} |
|
| 169 | ||
| 170 | 69x |
lhs <- rhs <- character(0) |
| 171 | ||
| 172 |
# 1. THRESHOLDS (based on varTable) |
|
| 173 |
# NOTE: - new in 0.5-18: ALWAYS include threshold parameters in partable, |
|
| 174 |
# but only free them if auto.th = TRUE |
|
| 175 |
# - [only ov.names.ord2, because ov.names.ord1 are already |
|
| 176 |
# in tmp.user and we only need to add 'default' parameters here] |
|
| 177 |
# (not any longer: we create them for ALL ordered var (0.6-12) |
|
| 178 | 69x |
nth <- 0L |
| 179 |
# if(auto.th && length(ov.names.ord2) > 0L) {
|
|
| 180 |
# if(length(ov.names.ord2) > 0L) {
|
|
| 181 | 69x |
if (length(ov.names.ord) > 0L) {
|
| 182 |
# for(o in ov.names.ord2) {
|
|
| 183 | 2x |
for (o in ov.names.ord) {
|
| 184 | 8x |
if (!is.null(varTable)) {
|
| 185 | 8x |
nth <- varTable$nlev[varTable$name == o] - 1L |
| 186 | ! |
} else if (!is.null(nthresholds)) {
|
| 187 | ! |
if (length(nthresholds) == 1L && is.null(nth.names)) {
|
| 188 | ! |
nth <- nthresholds |
| 189 |
} else {
|
|
| 190 |
# we can assume nthresholds is a named vector |
|
| 191 | ! |
nth <- unname(nthresholds[o]) |
| 192 | ! |
if (is.na(nth)) {
|
| 193 | ! |
lav_msg_stop(gettextf("ordered variable %s not found in the
|
| 194 | ! |
named vector nthresholds.", o)) |
| 195 |
} |
|
| 196 |
} |
|
| 197 |
} |
|
| 198 | ! |
if (nth < 1L) next |
| 199 | 8x |
lhs <- c(lhs, rep(o, nth)) |
| 200 | 8x |
rhs <- c(rhs, paste("t", seq_len(nth), sep = ""))
|
| 201 |
} |
|
| 202 | 2x |
nth <- length(lhs) |
| 203 |
} |
|
| 204 | ||
| 205 |
# 2. default (residual) variances and covariances |
|
| 206 | ||
| 207 |
# a) (residual) VARIANCES (all ov's except exo, and all lv's) |
|
| 208 |
# NOTE: change since 0.5-17: we ALWAYS include the vars in the |
|
| 209 |
# parameter table; but only if auto.var = TRUE, we set them free |
|
| 210 |
# if(auto.var) {
|
|
| 211 | 69x |
ov.var <- ov.names.nox |
| 212 |
# auto-remove ordinal variables |
|
| 213 |
# idx <- match(ov.names.ord, ov.var) |
|
| 214 |
# if(length(idx)) ov.var <- ov.var[-idx] |
|
| 215 | 69x |
lhs <- c(lhs, ov.var, lv.names) |
| 216 | 69x |
rhs <- c(rhs, ov.var, lv.names) |
| 217 |
# } |
|
| 218 | ||
| 219 |
# b) `independent` latent variable COVARIANCES (lv.names.x) |
|
| 220 | 69x |
if (auto.cov.lv.x && length(lv.names.x) > 1L) {
|
| 221 | 16x |
tmp <- utils::combn(lv.names.x, 2) |
| 222 | 16x |
lhs <- c(lhs, tmp[1, ]) # to fill upper.tri |
| 223 | 16x |
rhs <- c(rhs, tmp[2, ]) |
| 224 |
} |
|
| 225 | ||
| 226 |
# c) `dependent` latent variables COVARIANCES (lv.y.idx + ov.y.lv.idx) |
|
| 227 | 69x |
if (auto.cov.y && length(lvov.names.y) > 1L) {
|
| 228 | 2x |
tmp <- utils::combn(lvov.names.y, 2L) |
| 229 | 2x |
lhs <- c(lhs, tmp[1, ]) # to fill upper.tri |
| 230 | 2x |
rhs <- c(rhs, tmp[2, ]) |
| 231 |
} |
|
| 232 | ||
| 233 |
# d) exogenous x covariates: VARIANCES + COVARIANCES |
|
| 234 | 69x |
if ((nx <- length(ov.names.x)) > 0L) {
|
| 235 | 16x |
if (conditional.x) {
|
| 236 |
# new in 0.6-12: we make a distinction between ov.names.x and |
|
| 237 |
# ov.names.x.block: we treat them 'separately' (with no covariances |
|
| 238 |
# among them) |
|
| 239 |
# but we add 'regressions' instead (see below) |
|
| 240 | 2x |
ov.names.x1 <- ov.names.x[!ov.names.x %in% ov.names.x.block] |
| 241 | 2x |
ov.names.x2 <- ov.names.x.block |
| 242 | 2x |
nx1 <- length(ov.names.x1) # splitted x |
| 243 | 2x |
nx2 <- length(ov.names.x2) # regular x |
| 244 | 2x |
if (nx1 > 0L) {
|
| 245 | ! |
idx <- lower.tri(matrix(0, nx1, nx1), diag = TRUE) |
| 246 | ! |
lhs <- c(lhs, rep(ov.names.x1, each = nx1)[idx]) # fill upper.tri |
| 247 | ! |
rhs <- c(rhs, rep(ov.names.x1, times = nx1)[idx]) |
| 248 |
} |
|
| 249 | 2x |
if (nx2 > 0L) {
|
| 250 | 2x |
idx <- lower.tri(matrix(0, nx2, nx2), diag = TRUE) |
| 251 | 2x |
lhs <- c(lhs, rep(ov.names.x2, each = nx2)[idx]) # fill upper.tri |
| 252 | 2x |
rhs <- c(rhs, rep(ov.names.x2, times = nx2)[idx]) |
| 253 |
} |
|
| 254 |
} else {
|
|
| 255 | 14x |
idx <- lower.tri(matrix(0, nx, nx), diag = TRUE) |
| 256 | 14x |
lhs <- c(lhs, rep(ov.names.x, each = nx)[idx]) # fill upper.tri |
| 257 | 14x |
rhs <- c(rhs, rep(ov.names.x, times = nx)[idx]) |
| 258 |
} |
|
| 259 |
} |
|
| 260 | ||
| 261 |
# e) indicators of composites: COVARIANCES |
|
| 262 |
# but only within/intra blocks |
|
| 263 | 69x |
if ((ncx <- length(ov.ind.c)) > 0L) {
|
| 264 |
# create W1 |
|
| 265 | ! |
W1 <- matrix(0, length(ov.ind.c), length(lv.names.c)) |
| 266 | ! |
c.idx <- which(FLAT$op == "<~") |
| 267 | ! |
W1[cbind(match(FLAT$rhs[c.idx], ov.ind.c), |
| 268 | ! |
match(FLAT$lhs[c.idx], lv.names.c))] <- 1 |
| 269 | ! |
W1W1 <- tcrossprod(W1) |
| 270 | ! |
W1W1[upper.tri(W1W1, diag = TRUE)] <- 0 # keep lower.tri only |
| 271 | ! |
if (ncx > 1L) {
|
| 272 | ! |
lhs <- c(lhs, ov.ind.c[col(W1W1)[as.logical(W1W1)]]) |
| 273 | ! |
rhs <- c(rhs, ov.ind.c[row(W1W1)[as.logical(W1W1)]]) |
| 274 |
} |
|
| 275 |
} |
|
| 276 | ||
| 277 |
# f) efa latent variables COVARIANCES; only needed for 'mediators' |
|
| 278 |
# (not in lv.names.x, not in lv.names.y) -- added in 0.6-18 |
|
| 279 | 69x |
if (auto.efa && length(lv.names.efa) > 1L) {
|
| 280 | 3x |
efa.values <- lav_partable_efa_values(FLAT) |
| 281 | 3x |
for (set in efa.values) {
|
| 282 |
# correlated factors within each set |
|
| 283 | 3x |
this.set.lv <- unique(FLAT$lhs[FLAT$op == "=~" & |
| 284 | 3x |
!FLAT$lhs %in% lv.names.x & |
| 285 | 3x |
!FLAT$lhs %in% lv.names.y & |
| 286 | 3x |
FLAT$efa == set]) |
| 287 | 3x |
if (length(this.set.lv) > 0L) {
|
| 288 | ! |
tmp <- utils::combn(this.set.lv, 2) |
| 289 | ! |
lhs <- c(lhs, tmp[1, ]) # to fill upper.tri |
| 290 | ! |
rhs <- c(rhs, tmp[2, ]) |
| 291 |
} |
|
| 292 |
} |
|
| 293 |
} |
|
| 294 | ||
| 295 |
# create 'op' (thresholds come first, then variances) |
|
| 296 | 69x |
op <- rep("~~", length(lhs))
|
| 297 | 69x |
op[seq_len(nth)] <- "|" |
| 298 | ||
| 299 |
# LATENT RESPONSE SCALES (DELTA) |
|
| 300 |
# NOTE: - new in 0.5-19: ALWAYS include scaling parameters in partable, |
|
| 301 |
# but only free them if auto.delta = TRUE (and parameterization |
|
| 302 |
# is "delta" |
|
| 303 |
# if(auto.delta && auto.th && length(ov.names.ord) > 0L && |
|
| 304 |
# # length(lv.names) > 0L && |
|
| 305 |
# (ngroups > 1L || any(FLAT$op == "~*~") || parameterization == "theta")) {
|
|
| 306 | 69x |
if (length(ov.names.ord) > 0L) {
|
| 307 | 2x |
lhs <- c(lhs, ov.names.ord) |
| 308 | 2x |
rhs <- c(rhs, ov.names.ord) |
| 309 | 2x |
op <- c(op, rep("~*~", length(ov.names.ord)))
|
| 310 |
} |
|
| 311 | ||
| 312 |
# same for correlation structures, but now for ALL variables |
|
| 313 | 69x |
if (!categorical && correlation) {
|
| 314 | ! |
lhs <- c(lhs, ov.names) |
| 315 | ! |
rhs <- c(rhs, ov.names) |
| 316 | ! |
op <- c(op, rep("~*~", length(ov.names)))
|
| 317 |
} |
|
| 318 | ||
| 319 |
# 3. INTERCEPTS |
|
| 320 | 69x |
if (meanstructure) {
|
| 321 |
# if(conditional.x) {
|
|
| 322 |
# ov.int <- ov.names.nox |
|
| 323 |
# } else {
|
|
| 324 | 29x |
ov.int <- ov.names |
| 325 |
# } |
|
| 326 |
# auto-remove ordinal variables |
|
| 327 |
# idx <- which(ov.int %in% ov.names.ord) |
|
| 328 |
# if(length(idx)) ov.int <- ov.int[-idx] |
|
| 329 | ||
| 330 | 29x |
int.lhs <- c(ov.int, lv.names) |
| 331 | 29x |
lhs <- c(lhs, int.lhs) |
| 332 | 29x |
rhs <- c(rhs, rep("", length(int.lhs)))
|
| 333 | 29x |
op <- c(op, rep("~1", length(int.lhs)))
|
| 334 |
} |
|
| 335 | ||
| 336 |
# 4. REGRESSIONS |
|
| 337 | 69x |
if (conditional.x) {
|
| 338 |
# new in 0.6-12: we make a distinction between ov.names.x and |
|
| 339 |
# ov.names.x.block: we treat them 'separately' (with no covariances |
|
| 340 |
# among them) |
|
| 341 |
# but we add 'regressions' instead! |
|
| 342 | 2x |
ov.names.x1 <- ov.names.x[!ov.names.x %in% ov.names.x.block] |
| 343 | 2x |
ov.names.x2 <- ov.names.x.block |
| 344 | 2x |
nx1 <- length(ov.names.x1) # splitted x |
| 345 | 2x |
nx2 <- length(ov.names.x2) # regular x |
| 346 | 2x |
if (nx1 > 0L && nx2 > 0L) {
|
| 347 |
# add regressions for splitted-x ~ regular-x |
|
| 348 | ! |
lhs <- c(lhs, rep(ov.names.x1, times = nx2)) |
| 349 | ! |
op <- c(op, rep("~", nx2 * nx1))
|
| 350 | ! |
rhs <- c(rhs, rep(ov.names.x2, each = nx1)) |
| 351 |
} |
|
| 352 |
} |
|
| 353 | ||
| 354 |
# free group weights |
|
| 355 | 69x |
if (group.w.free) {
|
| 356 | ! |
lhs <- c(lhs, "group") |
| 357 | ! |
rhs <- c(rhs, "w") |
| 358 | ! |
op <- c(op, "%") |
| 359 |
} |
|
| 360 | ||
| 361 | 69x |
tmp.default <- data.frame( |
| 362 | 69x |
lhs = lhs, op = op, rhs = rhs, |
| 363 | 69x |
mod.idx = rep(0L, length(lhs)), |
| 364 | 69x |
stringsAsFactors = FALSE |
| 365 |
) |
|
| 366 | ||
| 367 | ||
| 368 |
# 4. USER: user-specified elements |
|
| 369 | 69x |
lhs <- FLAT$lhs |
| 370 | 69x |
op <- FLAT$op |
| 371 | 69x |
rhs <- FLAT$rhs |
| 372 | 69x |
mod.idx <- FLAT$mod.idx |
| 373 | ||
| 374 | 69x |
lv.names <- lav_partable_vnames(FLAT, type = "lv") # latent variables |
| 375 | 69x |
ov.names <- lav_partable_vnames(FLAT, type = "ov") # observed variables |
| 376 | 69x |
tmp.user <- data.frame( |
| 377 | 69x |
lhs = lhs, op = op, rhs = rhs, mod.idx = mod.idx, |
| 378 | 69x |
stringsAsFactors = FALSE |
| 379 |
) |
|
| 380 | ||
| 381 |
# check for duplicated elements in tmp.user |
|
| 382 | 69x |
tmp.tmp <- tmp.user[, 1:3] |
| 383 | 69x |
idx <- which(duplicated(tmp.tmp)) |
| 384 | 69x |
if (length(idx) > 0L) {
|
| 385 | ! |
txt <- sapply(seq_along(idx), function(i) {
|
| 386 | ! |
paste( |
| 387 | ! |
" ", tmp.tmp[idx[i], "lhs"], |
| 388 | ! |
tmp.tmp[idx[i], "op"], |
| 389 | ! |
tmp.tmp[idx[i], "rhs"] |
| 390 |
) |
|
| 391 |
}) |
|
| 392 | ! |
lav_msg_warn(gettext( |
| 393 | ! |
"duplicated elements in model syntax have been ignored:"), |
| 394 | ! |
lav_msg_view(txt, "none")) |
| 395 | ! |
tmp.user <- tmp.user[-idx, ] |
| 396 |
} |
|
| 397 | ||
| 398 |
# check for duplicated elements in tmp.default |
|
| 399 |
# - FIXME: can we not avoid this somehow?? |
|
| 400 |
# - for example, if the user model includes 'x1 ~~ x1' |
|
| 401 |
# or 'x1 ~ 1' |
|
| 402 |
# - remove them from tmp.default |
|
| 403 | 69x |
tmp.tmp <- rbind(tmp.default[, 1:3], tmp.user[, 1:3]) |
| 404 | 69x |
idx <- which(duplicated(tmp.tmp, fromLast = TRUE)) |
| 405 |
# idx should be in tmp.default |
|
| 406 | 69x |
if (length(idx)) {
|
| 407 | 8x |
for (i in idx) {
|
| 408 | 122x |
flat.idx <- which(tmp.user$lhs == tmp.default$lhs[i] & |
| 409 | 122x |
tmp.user$op == tmp.default$op[i] & |
| 410 | 122x |
tmp.user$rhs == tmp.default$rhs[i]) |
| 411 | 122x |
if (length(flat.idx) != 1L) {
|
| 412 | ! |
cat("[lavaan DEBUG] idx in tmp.tmp: i = ", i, "\n")
|
| 413 | ! |
print(tmp.tmp[i, ]) |
| 414 | ! |
cat("[lavaan DEBUG] idx in tmp.default: i = ", i, "\n")
|
| 415 | ! |
print(tmp.default[i, ]) |
| 416 | ! |
cat("[lavaan DEBUG] flat.idx:")
|
| 417 | ! |
print(flat.idx) |
| 418 |
} |
|
| 419 |
} |
|
| 420 | 8x |
tmp.default <- tmp.default[-idx, ] |
| 421 |
} |
|
| 422 | ||
| 423 |
# now that we have removed all duplicated elements, we can construct |
|
| 424 |
# the tmp.list for a single group/block |
|
| 425 | 69x |
lhs <- c(tmp.user$lhs, tmp.default$lhs) |
| 426 | 69x |
op <- c(tmp.user$op, tmp.default$op) |
| 427 | 69x |
rhs <- c(tmp.user$rhs, tmp.default$rhs) |
| 428 | 69x |
user <- c( |
| 429 | 69x |
rep(1L, length(tmp.user$lhs)), |
| 430 | 69x |
rep(0L, length(tmp.default$lhs)) |
| 431 |
) |
|
| 432 | 69x |
mod.idx <- c(tmp.user$mod.idx, tmp.default$mod.idx) |
| 433 | ||
| 434 |
# by default: everyting is free! |
|
| 435 | 69x |
free <- rep(1L, length(lhs)) |
| 436 | 69x |
ustart <- rep(as.numeric(NA), length(lhs)) |
| 437 |
# label <- paste(lhs, op, rhs, sep="") |
|
| 438 | 69x |
label <- rep(character(1), length(lhs)) |
| 439 | 69x |
exo <- rep(0L, length(lhs)) |
| 440 | ||
| 441 |
# 0a. if auto.th = FALSE, set fix the thresholds |
|
| 442 | 69x |
if (!auto.th) {
|
| 443 | 16x |
th.idx <- which(op == "|" & user == 0L) |
| 444 | 16x |
free[th.idx] <- 0L |
| 445 |
} |
|
| 446 | ||
| 447 |
# 0b. if auto.var = FALSE, set the unspecified variances to zero |
|
| 448 | 69x |
if (!auto.var) {
|
| 449 | 16x |
var.idx <- which(op == "~~" & |
| 450 | 16x |
lhs == rhs & |
| 451 | 16x |
!lhs %in% ov.ind.c & |
| 452 | 16x |
user == 0L) |
| 453 | 16x |
ustart[var.idx] <- 0.0 |
| 454 | 16x |
free[var.idx] <- 0L |
| 455 | 53x |
} else if (length(lv.names.f) > 0L) {
|
| 456 |
# 'formative' (residual) variances are set to zero by default |
|
| 457 | ! |
var.idx <- which(op == "~~" & |
| 458 | ! |
lhs == rhs & |
| 459 | ! |
lhs %in% lv.names.f & |
| 460 | ! |
user == 0L) |
| 461 | ! |
ustart[var.idx] <- 0.0 |
| 462 | ! |
free[var.idx] <- 0L |
| 463 |
} |
|
| 464 | ||
| 465 |
# 0c. for the ~~ for composite indicators: currently ALWAYS fixed |
|
| 466 |
# todo: create an option to free them anyway |
|
| 467 | 69x |
if (length(ov.ind.c) > 0) {
|
| 468 | ! |
var.idx <- which(op == "~~" & lhs %in% ov.ind.c) |
| 469 | ! |
ustart[var.idx] <- as.numeric(NA) |
| 470 | ! |
free[var.idx] <- 0L |
| 471 |
} |
|
| 472 | ||
| 473 |
# 0d. variances for composites: ALWAYS fixed (should be set later |
|
| 474 |
# by lav_lisrel_composites_variances |
|
| 475 | 69x |
if (length(lv.names.c) > 0) {
|
| 476 | ! |
var.idx <- which(op == "~~" & lhs %in% lv.names.c & lhs == rhs) |
| 477 | ! |
ustart[var.idx] <- as.numeric(NA) |
| 478 | ! |
free[var.idx] <- 0L |
| 479 |
} |
|
| 480 | ||
| 481 | ||
| 482 |
# 1. fix metric of regular latent variables |
|
| 483 | 69x |
if (std.lv) {
|
| 484 |
# fix metric by fixing the variance of the latent variable |
|
| 485 | ! |
lv.var.idx <- which(op == "~~" & |
| 486 | ! |
lhs %in% lv.names & lhs == rhs) |
| 487 | ! |
ustart[lv.var.idx] <- 1.0 |
| 488 | ! |
free[lv.var.idx] <- 0L |
| 489 |
} |
|
| 490 | 69x |
if (auto.efa && length(lv.names.efa) > 0L) {
|
| 491 |
# fix lv variances of efa blocks to unity |
|
| 492 | 4x |
lv.var.idx <- which(op == "~~" & |
| 493 | 4x |
lhs %in% lv.names.efa & lhs == rhs) |
| 494 | 4x |
ustart[lv.var.idx] <- 1.0 |
| 495 | 4x |
free[lv.var.idx] <- 0L |
| 496 |
} |
|
| 497 | 69x |
if (auto.fix.first) {
|
| 498 |
# fix metric by fixing the loading of the first indicator |
|
| 499 |
# (but not for efa factors) |
|
| 500 | 53x |
mm.idx <- which(op == "=~" & !(lhs %in% lv.names.efa)) |
| 501 | 53x |
first.idx <- mm.idx[which(!duplicated(lhs[mm.idx]))] |
| 502 | 53x |
ustart[first.idx] <- 1.0 |
| 503 | 53x |
free[first.idx] <- 0L |
| 504 | 53x |
if (composites && length(lv.names.c) > 0L) {
|
| 505 | ! |
mm.idx <- which(op == "<~") |
| 506 | ! |
first.idx <- mm.idx[which(!duplicated(lhs[mm.idx]))] |
| 507 | ! |
ustart[first.idx] <- 1.0 |
| 508 | ! |
free[first.idx] <- 0L |
| 509 |
} |
|
| 510 |
} |
|
| 511 | ||
| 512 |
# 2. fix residual variance of single indicators to zero |
|
| 513 | 69x |
if (auto.var && auto.fix.single) {
|
| 514 | 53x |
mm.idx <- which(op == "=~") |
| 515 | 53x |
tmp.t <- table(lhs[mm.idx]) |
| 516 | 53x |
if (any(tmp.t == 1L)) {
|
| 517 |
# ok, we have a LV with only a single indicator |
|
| 518 | 2x |
lv.names.single <- names(tmp.t)[tmp.t == 1L] |
| 519 |
# get corresponding indicator if unique |
|
| 520 | 2x |
lhs.mm <- lhs[mm.idx] |
| 521 | 2x |
rhs.mm <- rhs[mm.idx] |
| 522 | 2x |
single.ind <- rhs.mm[which(lhs.mm %in% lv.names.single & |
| 523 | 2x |
lhs.mm != rhs.mm & # exclude phantom |
| 524 | 2x |
!(duplicated(rhs.mm) | |
| 525 | 2x |
duplicated(rhs.mm, fromLast = TRUE)))] |
| 526 |
# is the indicator unique? |
|
| 527 | 2x |
if (length(single.ind) > 0L) {
|
| 528 | 2x |
var.idx <- which(op == "~~" & lhs %in% single.ind & |
| 529 | 2x |
rhs %in% single.ind & |
| 530 | 2x |
lhs == rhs & |
| 531 | 2x |
user == 0L) |
| 532 | 2x |
ustart[var.idx] <- 0.0 |
| 533 | 2x |
free[var.idx] <- 0L |
| 534 |
} |
|
| 535 |
} |
|
| 536 |
} |
|
| 537 | ||
| 538 |
# 3. orthogonal = TRUE? |
|
| 539 | 69x |
if (orthogonal) {
|
| 540 | 23x |
lv.cov.idx <- which(op == "~~" & |
| 541 | 23x |
lhs %in% lv.names & |
| 542 | 23x |
rhs %in% lv.names & |
| 543 | 23x |
lhs != rhs & |
| 544 | 23x |
user == 0L) |
| 545 | 23x |
ustart[lv.cov.idx] <- 0.0 |
| 546 | 23x |
free[lv.cov.idx] <- 0L |
| 547 |
} |
|
| 548 |
# 3b. orthogonal.y = TRUE? |
|
| 549 | 69x |
if (orthogonal.y) {
|
| 550 | ! |
lv.cov.idx <- which(op == "~~" & |
| 551 | ! |
lhs %in% lv.names.y & |
| 552 | ! |
rhs %in% lv.names.y & |
| 553 | ! |
lhs != rhs & |
| 554 | ! |
user == 0L) |
| 555 | ! |
ustart[lv.cov.idx] <- 0.0 |
| 556 | ! |
free[lv.cov.idx] <- 0L |
| 557 |
} |
|
| 558 |
# 3c. orthogonal.x = TRUE? |
|
| 559 | 69x |
if (orthogonal.x) {
|
| 560 | ! |
lv.cov.idx <- which(op == "~~" & |
| 561 | ! |
lhs %in% lv.names.x & |
| 562 | ! |
rhs %in% lv.names.x & |
| 563 | ! |
lhs != rhs & |
| 564 | ! |
user == 0L) |
| 565 | ! |
ustart[lv.cov.idx] <- 0.0 |
| 566 | ! |
free[lv.cov.idx] <- 0L |
| 567 |
} |
|
| 568 |
# 3d. orthogonal.efa = TRUE? |
|
| 569 | 69x |
if (orthogonal.efa) {
|
| 570 | ! |
lv.cov.idx <- which(op == "~~" & |
| 571 | ! |
lhs %in% lv.names.efa & |
| 572 | ! |
rhs %in% lv.names.efa & |
| 573 | ! |
lhs != rhs & |
| 574 | ! |
user == 0L) |
| 575 | ! |
ustart[lv.cov.idx] <- 0.0 |
| 576 | ! |
free[lv.cov.idx] <- 0L |
| 577 |
} |
|
| 578 | ||
| 579 |
# 4. intercepts |
|
| 580 | 69x |
if (meanstructure) {
|
| 581 | 29x |
if (categorical) {
|
| 582 |
# zero intercepts/means ordinal variables |
|
| 583 | 2x |
ov.int.idx <- which(op == "~1" & |
| 584 | 2x |
lhs %in% ov.names.ord & |
| 585 | 2x |
user == 0L) |
| 586 | 2x |
ustart[ov.int.idx] <- 0.0 |
| 587 | 2x |
free[ov.int.idx] <- 0L |
| 588 |
} |
|
| 589 | 29x |
if (int.ov.free == FALSE) {
|
| 590 |
# zero intercepts/means observed variables |
|
| 591 | 2x |
ov.int.idx <- which(op == "~1" & |
| 592 | 2x |
lhs %in% ov.names & |
| 593 | 2x |
user == 0L) |
| 594 | 2x |
ustart[ov.int.idx] <- 0.0 |
| 595 | 2x |
free[ov.int.idx] <- 0L |
| 596 |
} |
|
| 597 | 29x |
if (int.lv.free == FALSE) {
|
| 598 |
# zero intercepts/means latent variables |
|
| 599 | 27x |
lv.int.idx <- which(op == "~1" & |
| 600 | 27x |
lhs %in% lv.names & |
| 601 | 27x |
user == 0L) |
| 602 | 27x |
ustart[lv.int.idx] <- 0.0 |
| 603 | 27x |
free[lv.int.idx] <- 0L |
| 604 |
} |
|
| 605 |
# 4b. fixed effect (only if we have random slopes) |
|
| 606 | 29x |
if (!is.null(FLAT$rv) && any(nchar(FLAT$rv) > 0L)) {
|
| 607 | ! |
lv.names.rv <- lav_partable_vnames(FLAT, "lv.rv") |
| 608 | ! |
lv.rv.idx <- which(op == "~1" & |
| 609 | ! |
lhs %in% lv.names.rv & |
| 610 | ! |
user == 0L) |
| 611 | ! |
ustart[lv.rv.idx] <- as.numeric(NA) |
| 612 | ! |
free[lv.rv.idx] <- 1L |
| 613 |
} |
|
| 614 | 29x |
if (length(lv.names.int) > 0L) {
|
| 615 | ! |
lv.int.idx <- which(op == "~1" & |
| 616 | ! |
lhs %in% lv.names.int & |
| 617 | ! |
user == 0L) |
| 618 | ! |
ustart[lv.int.idx] <- as.numeric(NA) |
| 619 | ! |
free[lv.int.idx] <- 1L |
| 620 |
} |
|
| 621 |
# composites: always non-free, but with ustart = NA; value should be |
|
| 622 |
# filled in later as a function of the other parameters |
|
| 623 | 29x |
if (length(lv.names.c) > 0L) {
|
| 624 | ! |
c.int.idx <- which(op == "~1" & lhs %in% lv.names.c & user == 0L) |
| 625 | ! |
ustart[c.int.idx] <- as.numeric(NA) |
| 626 | ! |
free[c.int.idx] <- 0L |
| 627 |
} |
|
| 628 |
} |
|
| 629 | ||
| 630 |
# 4b. fixed effect (only if we have random slopes) |
|
| 631 |
# if(!is.null(FLAT$rv)) {
|
|
| 632 |
# } |
|
| 633 | ||
| 634 |
# 5. handle exogenous `x' covariates |
|
| 635 |
# usually, ov.names.x.block == ov.names.x |
|
| 636 |
# except if multilevel, where 'splitted' ov.x are treated as endogenous |
|
| 637 | ||
| 638 |
# 5a conditional.x = FALSE |
|
| 639 | 69x |
if (!conditional.x && fixed.x && length(ov.names.x.block) > 0) {
|
| 640 |
# 1. variances/covariances |
|
| 641 | 12x |
exo.var.idx <- which(op == "~~" & |
| 642 | 12x |
rhs %in% ov.names.x.block & |
| 643 | 12x |
lhs %in% ov.names.x.block & |
| 644 | 12x |
user == 0L) |
| 645 | 12x |
ustart[exo.var.idx] <- as.numeric(NA) # should be overriden later! |
| 646 | 12x |
free[exo.var.idx] <- 0L |
| 647 | 12x |
exo[exo.var.idx] <- 1L |
| 648 | ||
| 649 |
# 2. intercepts |
|
| 650 | 12x |
exo.int.idx <- which(op == "~1" & |
| 651 | 12x |
lhs %in% ov.names.x.block & |
| 652 | 12x |
user == 0L) |
| 653 | 12x |
ustart[exo.int.idx] <- as.numeric(NA) # should be overriden later! |
| 654 | 12x |
free[exo.int.idx] <- 0L |
| 655 | 12x |
exo[exo.int.idx] <- 1L |
| 656 |
} |
|
| 657 | ||
| 658 |
# 5a-bis. conditional.x = TRUE |
|
| 659 | 69x |
if (conditional.x && length(ov.names.x) > 0L) {
|
| 660 |
# 1. variances/covariances |
|
| 661 | 2x |
exo.var.idx <- which(op == "~~" & |
| 662 | 2x |
rhs %in% ov.names.x & |
| 663 | 2x |
lhs %in% ov.names.x & |
| 664 | 2x |
user == 0L) |
| 665 | 2x |
if (fixed.x) {
|
| 666 | 2x |
ustart[exo.var.idx] <- as.numeric(NA) # should be overriden later! |
| 667 | 2x |
free[exo.var.idx] <- 0L |
| 668 |
} |
|
| 669 | 2x |
exo[exo.var.idx] <- 1L |
| 670 | ||
| 671 |
# 2. intercepts |
|
| 672 | 2x |
exo.int.idx <- which(op == "~1" & |
| 673 | 2x |
lhs %in% ov.names.x & |
| 674 | 2x |
user == 0L) |
| 675 | 2x |
if (fixed.x) {
|
| 676 | 2x |
ustart[exo.int.idx] <- as.numeric(NA) # should be overriden later! |
| 677 | 2x |
free[exo.int.idx] <- 0L |
| 678 |
} |
|
| 679 | 2x |
exo[exo.int.idx] <- 1L |
| 680 | ||
| 681 |
# 3. regressions ov + lv |
|
| 682 | 2x |
exo.reg.idx <- which(op %in% c("~", "<~") &
|
| 683 | 2x |
lhs %in% c(lv.names, ov.names.nox) & |
| 684 | 2x |
rhs %in% ov.names.x) |
| 685 | 2x |
exo[exo.reg.idx] <- 1L |
| 686 | ||
| 687 |
# 3b regression splitted.x ~ regular.x |
|
| 688 | 2x |
exo.reg2.idx <- which(op %in% c("~", "<~") &
|
| 689 | 2x |
lhs %in% ov.names.x & |
| 690 | 2x |
rhs %in% ov.names.x) |
| 691 | 2x |
if (fixed.x) {
|
| 692 | 2x |
ustart[exo.reg2.idx] <- as.numeric(NA) # should be overriden later! |
| 693 | 2x |
free[exo.reg2.idx] <- 0L |
| 694 |
} |
|
| 695 | 2x |
exo[exo.reg2.idx] <- 1L |
| 696 |
} |
|
| 697 | ||
| 698 |
# 5b. residual variances of ordinal variables? |
|
| 699 | 69x |
if (length(ov.names.ord) > 0L) {
|
| 700 | 2x |
ord.idx <- which(lhs %in% ov.names.ord & |
| 701 | 2x |
op == "~~" & |
| 702 | 2x |
user == 0L & ## New in 0.6-1 |
| 703 | 2x |
lhs == rhs) |
| 704 | 2x |
ustart[ord.idx] <- 1L ## FIXME!! or 0?? (0 breaks ex3.12) |
| 705 | 2x |
free[ord.idx] <- 0L |
| 706 |
} |
|
| 707 | ||
| 708 |
# 5c latent response scales of ordinal variables? |
|
| 709 |
# by default, all fixed to 1.0 |
|
| 710 | 69x |
if (length(ov.names.ord) > 0L) {
|
| 711 | 2x |
delta.idx <- which(op == "~*~" & |
| 712 | 2x |
user == 0L) ## New in 0.6-1 |
| 713 | 2x |
ustart[delta.idx] <- 1.0 |
| 714 | 2x |
free[delta.idx] <- 0L |
| 715 |
} |
|
| 716 | ||
| 717 |
# correlation structure (new in 0.6-13) |
|
| 718 | 69x |
if (correlation) {
|
| 719 | ! |
var.idx <- which(lhs %in% ov.names & |
| 720 | ! |
op == "~~" & |
| 721 | ! |
user == 0L & |
| 722 | ! |
lhs == rhs) |
| 723 | ! |
ustart[var.idx] <- 1L |
| 724 | ! |
free[var.idx] <- 0L |
| 725 | ||
| 726 | ! |
delta.idx <- which(op == "~*~" & |
| 727 | ! |
user == 0L) |
| 728 | ! |
ustart[delta.idx] <- 1.0 |
| 729 | ! |
free[delta.idx] <- 0L |
| 730 |
} |
|
| 731 | ||
| 732 |
# group proportions (group 1L) |
|
| 733 | 69x |
if (group.w.free) {
|
| 734 | ! |
group.idx <- which(lhs == "group" & op == "%") |
| 735 |
# if(ngroups > 1L) {
|
|
| 736 | ! |
free[group.idx] <- 1L |
| 737 | ! |
ustart[group.idx] <- as.numeric(NA) |
| 738 |
# } else {
|
|
| 739 |
# free[ group.idx ] <- 0L |
|
| 740 |
# ustart[ group.idx ] <- 0.0 # last group |
|
| 741 |
# } |
|
| 742 |
} |
|
| 743 | ||
| 744 |
# 6. multiple groups? |
|
| 745 | 69x |
group <- rep(1L, length(lhs)) |
| 746 | 69x |
if (ngroups > 1) {
|
| 747 | ||
| 748 |
# only if "loadings" in group.equal and !std.lv: |
|
| 749 |
# construct tempory tmp.list to obtain lv.marker |
|
| 750 | 3x |
if (!std.lv & "loadings" %in% group.equal) {
|
| 751 | ! |
tmp.list <- list( |
| 752 | ! |
id = seq_along(lhs), |
| 753 | ! |
lhs = lhs, |
| 754 | ! |
op = op, |
| 755 | ! |
rhs = rhs, |
| 756 | ! |
free = free, |
| 757 | ! |
ustart = ustart, |
| 758 | ! |
block = rep(1, length(rhs))) |
| 759 | ! |
lv.marker <- lav_partable_vnames(tmp.list, "lv.marker") |
| 760 |
} |
|
| 761 | ||
| 762 | ||
| 763 | 3x |
group <- rep(1:ngroups, each = length(lhs)) |
| 764 | 3x |
user <- rep(user, times = ngroups) |
| 765 | 3x |
lhs <- rep(lhs, times = ngroups) |
| 766 | 3x |
op <- rep(op, times = ngroups) |
| 767 | 3x |
rhs <- rep(rhs, times = ngroups) |
| 768 | 3x |
free <- rep(free, times = ngroups) |
| 769 | 3x |
ustart <- rep(ustart, times = ngroups) |
| 770 | 3x |
mod.idx <- rep(mod.idx, times = ngroups) |
| 771 | 3x |
label <- rep(label, times = ngroups) |
| 772 | 3x |
exo <- rep(exo, times = ngroups) |
| 773 | ||
| 774 |
# specific changes per group |
|
| 775 | 3x |
for (g in 2:ngroups) {
|
| 776 |
# free/fix intercepts latent variables |
|
| 777 | 3x |
if (meanstructure) {
|
| 778 | 2x |
int.idx <- which(op == "~1" & |
| 779 | 2x |
lhs %in% lv.names.noc & |
| 780 | 2x |
user == 0L & |
| 781 | 2x |
group == g) |
| 782 | 2x |
if (int.lv.free == FALSE && g > 1 && |
| 783 | 2x |
("intercepts" %in% group.equal) &&
|
| 784 | 2x |
!("means" %in% group.equal)) {
|
| 785 | ! |
free[int.idx] <- 1L |
| 786 | ! |
ustart[int.idx] <- as.numeric(NA) |
| 787 |
} |
|
| 788 |
} |
|
| 789 | ||
| 790 |
# free intercept indicators if equal thresholds (new in 0.6-20) |
|
| 791 | 3x |
if (meanstructure && length(ov.names.ord) > 0L) {
|
| 792 | ! |
ord.idx <- which(op == "~1" & |
| 793 | ! |
lhs %in% ov.names.ord & |
| 794 | ! |
user == 0L & |
| 795 | ! |
group == g) |
| 796 | ! |
if (int.lv.free == FALSE && g > 1 && |
| 797 | ! |
"thresholds" %in% group.equal) {
|
| 798 | ! |
free[ord.idx] <- 1L |
| 799 | ! |
ustart[ord.idx] <- as.numeric(NA) |
| 800 |
} |
|
| 801 |
} |
|
| 802 | ||
| 803 |
# latent variances if std.lv = TRUE (new in 0.6-4) |
|
| 804 | 3x |
if (std.lv && "loadings" %in% group.equal && |
| 805 | 3x |
!"lv.variances" %in% group.equal) {
|
| 806 | ! |
lv.var.idx <- which(op == "~~" & |
| 807 | ! |
lhs %in% lv.names & |
| 808 | ! |
!lhs %in% lv.names.efa & |
| 809 | ! |
lhs == rhs & |
| 810 | ! |
user == 0L & |
| 811 | ! |
group == g) |
| 812 | ! |
if (length(lv.var.idx) > 0L) {
|
| 813 | ! |
free[lv.var.idx] <- 1L |
| 814 | ! |
ustart[lv.var.idx] <- as.numeric(NA) |
| 815 |
} |
|
| 816 |
# marker indicator if std.lv = FALSE (new in 0.6-20) |
|
| 817 | 3x |
} else if(!std.lv && "loadings" %in% group.equal) {
|
| 818 | ! |
marker.idx <- which(op == "=~" & |
| 819 | ! |
rhs %in% lv.marker & |
| 820 | ! |
free == 0L & |
| 821 | ! |
ustart == 1L & |
| 822 | ! |
group == g) |
| 823 | ! |
if (length(marker.idx) > 0L) {
|
| 824 | ! |
free[marker.idx] <- 1L |
| 825 | ! |
ustart[marker.idx] <- as.numeric(NA) |
| 826 |
} |
|
| 827 |
} |
|
| 828 | ||
| 829 |
# latent variances if efa = TRUE (new in 0.6-5) |
|
| 830 | 3x |
if (length(lv.names.efa) > 0L && |
| 831 | 3x |
auto.efa && "loadings" %in% group.equal && |
| 832 | 3x |
!"lv.variances" %in% group.equal) {
|
| 833 | ! |
lv.var.idx <- which(op == "~~" & |
| 834 | ! |
lhs %in% lv.names.efa & |
| 835 | ! |
lhs == rhs & |
| 836 | ! |
user == 0L & |
| 837 | ! |
group == g) |
| 838 | ! |
if (length(lv.var.idx) > 0L) {
|
| 839 | ! |
free[lv.var.idx] <- 1L |
| 840 | ! |
ustart[lv.var.idx] <- as.numeric(NA) |
| 841 |
} |
|
| 842 |
} |
|
| 843 | ||
| 844 |
# latent response scaling -- categorical only |
|
| 845 |
# - if thresholds are equal -> free scalings/residual variances |
|
| 846 |
# - but not for binary indicators! |
|
| 847 | 3x |
if (length(ov.names.ord) > 0L) {
|
| 848 | ! |
nth <- sapply(ov.names.ord, |
| 849 | ! |
function(x) sum(lhs == x & op == "|" & group == 1L)) |
| 850 | ! |
ov.names.ord.notbinary <- ov.names.ord[nth > 1L] |
| 851 | ! |
if (auto.delta && parameterization == "delta") {
|
| 852 | ! |
if (any(op == "~*~" & group == g) && |
| 853 | ! |
("thresholds" %in% group.equal)) {
|
| 854 | ! |
delta.idx <- which(op == "~*~" & group == g & |
| 855 | ! |
lhs %in% ov.names.ord.notbinary) |
| 856 | ! |
free[delta.idx] <- 1L |
| 857 | ! |
ustart[delta.idx] <- as.numeric(NA) |
| 858 |
} |
|
| 859 | ! |
} else if (parameterization == "theta") {
|
| 860 | ! |
if (any(op == "~*~" & group == g) && |
| 861 | ! |
("thresholds" %in% group.equal)) {
|
| 862 | ! |
var.ord.idx <- which(op == "~~" & group == g & |
| 863 | ! |
lhs %in% ov.names.ord.notbinary & lhs == rhs) |
| 864 | ! |
free[var.ord.idx] <- 1L |
| 865 | ! |
ustart[var.ord.idx] <- as.numeric(NA) |
| 866 |
} |
|
| 867 |
} |
|
| 868 |
} |
|
| 869 | ||
| 870 |
# group proportions |
|
| 871 | 3x |
if (group.w.free) {
|
| 872 | ! |
group.idx <- which(lhs == "group" & op == "%" & group == g) |
| 873 |
# if(g == ngroups) {
|
|
| 874 |
# free[ group.idx ] <- 0L |
|
| 875 |
# ustart[ group.idx ] <- 0.0 # last group |
|
| 876 |
# } else {
|
|
| 877 | ! |
free[group.idx] <- 1L |
| 878 | ! |
ustart[group.idx] <- as.numeric(NA) |
| 879 |
# } |
|
| 880 |
} |
|
| 881 |
} # g |
|
| 882 |
} # ngroups |
|
| 883 | ||
| 884 |
# construct tmp.list |
|
| 885 | 69x |
tmp.list <- list( |
| 886 | 69x |
id = seq_along(lhs), |
| 887 | 69x |
lhs = lhs, |
| 888 | 69x |
op = op, |
| 889 | 69x |
rhs = rhs, |
| 890 | 69x |
user = user |
| 891 |
) |
|
| 892 | ||
| 893 |
# add block column (before group/level columns) |
|
| 894 | 69x |
if (!is.null(block.id)) {
|
| 895 |
# only one block |
|
| 896 | 24x |
tmp.list$block <- rep(block.id, length(lhs)) |
| 897 |
} else {
|
|
| 898 |
# block is a combination of at least group, level, ... |
|
| 899 |
# for now, only group |
|
| 900 | 45x |
tmp.list$block <- group |
| 901 |
} |
|
| 902 | ||
| 903 |
# block columns (typically only group) |
|
| 904 | 69x |
for (block in blocks) {
|
| 905 | 93x |
if (block == "group") {
|
| 906 | 69x |
tmp.list[[block]] <- group |
| 907 |
} else {
|
|
| 908 | 24x |
tmp.list[[block]] <- rep(0L, length(lhs)) |
| 909 |
} |
|
| 910 |
} |
|
| 911 | ||
| 912 |
# other columns |
|
| 913 | 69x |
tmp.list2 <- list( |
| 914 | 69x |
mod.idx = mod.idx, |
| 915 | 69x |
free = free, |
| 916 | 69x |
ustart = ustart, |
| 917 | 69x |
exo = exo, |
| 918 | 69x |
label = label |
| 919 |
) |
|
| 920 | ||
| 921 | 69x |
tmp.list <- c(tmp.list, tmp.list2) |
| 922 |
} |
| 1 |
# univariate modification indices |
|
| 2 |
# |
|
| 3 | ||
| 4 |
modindices <- function(object, |
|
| 5 |
standardized = TRUE, |
|
| 6 |
cov.std = TRUE, |
|
| 7 |
information = "expected", |
|
| 8 |
# power statistics? |
|
| 9 |
power = FALSE, |
|
| 10 |
delta = 0.1, |
|
| 11 |
alpha = 0.05, |
|
| 12 |
high.power = 0.75, |
|
| 13 |
# customize output |
|
| 14 |
sort. = FALSE, |
|
| 15 |
minimum.value = 0.0, |
|
| 16 |
maximum.number = nrow(LIST), |
|
| 17 |
free.remove = TRUE, |
|
| 18 |
na.remove = TRUE, |
|
| 19 |
op = NULL) {
|
|
| 20 |
# check object |
|
| 21 | ! |
object <- lav_object_check_version(object) |
| 22 | ||
| 23 |
# check if model has converged |
|
| 24 | ! |
if (object@optim$npar > 0L && !object@optim$converged) {
|
| 25 | ! |
lav_msg_warn(gettext("model did not converge"))
|
| 26 |
} |
|
| 27 | ||
| 28 |
# not ready for estimator = "PML" |
|
| 29 | ! |
if (object@Options$estimator == "PML") {
|
| 30 | ! |
lav_msg_stop(gettext( |
| 31 | ! |
"modification indices for estimator PML are not implemented yet.")) |
| 32 |
} |
|
| 33 | ||
| 34 |
# new in 0.6-17: check if the model contains equality constraints |
|
| 35 | ! |
if (object@Model@eq.constraints) {
|
| 36 | ! |
lav_msg_warn( |
| 37 | ! |
gettext("the modindices() function ignores equality constraints;
|
| 38 | ! |
use lavTestScore() to assess the impact of releasing one or |
| 39 | ! |
multiple constraints.") |
| 40 |
) |
|
| 41 |
} |
|
| 42 | ||
| 43 |
# sanity check |
|
| 44 | ! |
if (power) {
|
| 45 | ! |
standardized <- TRUE |
| 46 |
} |
|
| 47 | ||
| 48 |
# extended list (fixed-to-zero parameters) |
|
| 49 | ! |
strict.exo <- FALSE |
| 50 | ! |
if (object@Model@conditional.x) {
|
| 51 | ! |
strict.exo <- TRUE |
| 52 |
} |
|
| 53 | ! |
FULL <- lav_partable_full( |
| 54 | ! |
partable = lav_partable_set_cache(object@ParTable, object@pta), |
| 55 | ! |
free = TRUE, start = TRUE, |
| 56 | ! |
strict.exo = strict.exo |
| 57 |
) |
|
| 58 | ! |
FULL$free <- rep(1L, nrow(FULL)) |
| 59 | ! |
FULL$user <- rep(10L, nrow(FULL)) |
| 60 | ||
| 61 | ! |
FIT <- lav_object_extended(object, add = FULL, all.free = TRUE) |
| 62 | ! |
LIST <- FIT@ParTable |
| 63 | ||
| 64 | ||
| 65 |
# compute information matrix 'extended model' |
|
| 66 |
# ALWAYS use *expected* information (for now) |
|
| 67 | ! |
Information <- lavTech(FIT, paste("information", information, sep = "."))
|
| 68 | ||
| 69 |
# compute gradient 'extended model' |
|
| 70 | ! |
score <- lavTech(FIT, "gradient.logl") |
| 71 | ||
| 72 |
# Saris, Satorra & Sorbom 1987 |
|
| 73 |
# partition Q into Q_11, Q_22 and Q_12/Q_21 |
|
| 74 |
# which elements of Q correspond with 'free' and 'nonfree' parameters? |
|
| 75 | ! |
model.idx <- LIST$free[LIST$free > 0L & LIST$user != 10L] |
| 76 | ! |
extra.idx <- LIST$free[LIST$free > 0L & LIST$user == 10L] |
| 77 | ||
| 78 |
# catch empty extra.idx (no modification indices!) |
|
| 79 | ! |
if (length(extra.idx) == 0L) {
|
| 80 |
# 2 possibilities: either model is saturated, or we have constraints |
|
| 81 | ! |
if (object@test[[1]]$df == 0) {
|
| 82 | ! |
lav_msg_warn(gettext( |
| 83 | ! |
"list with extra parameters is empty; model is saturated")) |
| 84 |
} else {
|
|
| 85 | ! |
lav_msg_warn(gettext( |
| 86 | ! |
"list with extra parameters is empty; to release equality |
| 87 | ! |
constraints, use lavTestScore()")) |
| 88 |
} |
|
| 89 | ! |
LIST <- data.frame( |
| 90 | ! |
lhs = character(0), op = character(0), |
| 91 | ! |
rhs = character(0), group = integer(0), |
| 92 | ! |
mi = numeric(0), epc = numeric(0), |
| 93 | ! |
sepc.lv = numeric(0), sepc.all = numeric(0), |
| 94 | ! |
sepc.nox = numeric(0) |
| 95 |
) |
|
| 96 | ! |
return(LIST) |
| 97 |
} |
|
| 98 | ||
| 99 |
# partition |
|
| 100 | ! |
I11 <- Information[extra.idx, extra.idx, drop = FALSE] |
| 101 | ! |
I12 <- Information[extra.idx, model.idx, drop = FALSE] |
| 102 | ! |
I21 <- Information[model.idx, extra.idx, drop = FALSE] |
| 103 | ! |
I22 <- Information[model.idx, model.idx, drop = FALSE] |
| 104 | ||
| 105 |
# ALWAYS use *expected* information (for now) |
|
| 106 | ! |
I22.inv <- try( |
| 107 | ! |
lavTech(object, paste("inverted.information",
|
| 108 | ! |
information, |
| 109 | ! |
sep = "." |
| 110 |
)), |
|
| 111 | ! |
silent = TRUE |
| 112 |
) |
|
| 113 |
# just in case... |
|
| 114 | ! |
if (inherits(I22.inv, "try-error")) {
|
| 115 | ! |
lav_msg_stop(gettext( |
| 116 | ! |
"could not compute modification indices; information matrix is singular")) |
| 117 |
} |
|
| 118 | ||
| 119 | ! |
V <- I11 - I12 %*% I22.inv %*% I21 |
| 120 | ! |
V.diag <- diag(V) |
| 121 |
# dirty hack: catch very small or negative values in diag(V) |
|
| 122 |
# this is needed eg when parameters are not identified if freed-up; |
|
| 123 | ! |
idx <- which(V.diag < .Machine$double.eps^(1 / 3)) # was 1/2 <0.6-14 |
| 124 | ! |
if (length(idx) > 0L) {
|
| 125 | ! |
V.diag[idx] <- as.numeric(NA) |
| 126 |
} |
|
| 127 | ||
| 128 |
# create and fill in mi |
|
| 129 | ! |
if (object@Data@nlevels == 1L) {
|
| 130 | ! |
N <- object@SampleStats@ntotal |
| 131 |
#if (object@Model@estimator %in% ("ML")) {
|
|
| 132 | ! |
score <- -1 * score # due to gradient.logl |
| 133 |
#} |
|
| 134 |
} else {
|
|
| 135 |
# total number of clusters (over groups) |
|
| 136 | ! |
N <- 0 |
| 137 | ! |
for (g in 1:object@SampleStats@ngroups) {
|
| 138 | ! |
N <- N + object@Data@Lp[[g]]$nclusters[[2]] |
| 139 |
} |
|
| 140 |
# score <- score * (2 * object@SampleStats@ntotal) / N |
|
| 141 | ! |
score <- score / 2 # -2 * LRT |
| 142 |
} |
|
| 143 | ! |
mi <- numeric(length(score)) |
| 144 | ! |
mi[extra.idx] <- N * (score[extra.idx] * score[extra.idx]) / V.diag |
| 145 | ! |
if (length(model.idx) > 0L) {
|
| 146 | ! |
mi[model.idx] <- N * (score[model.idx] * score[model.idx]) / diag(I22) |
| 147 |
} |
|
| 148 | ||
| 149 | ! |
LIST$mi <- rep(as.numeric(NA), length(LIST$lhs)) |
| 150 | ! |
LIST$mi[LIST$free > 0] <- mi |
| 151 | ||
| 152 |
# handle equality constraints (if any) |
|
| 153 |
# eq.idx <- which(LIST$op == "==") |
|
| 154 |
# if(length(eq.idx) > 0L) {
|
|
| 155 |
# OUT <- lavTestScore(object, warn = FALSE) |
|
| 156 |
# LIST$mi[ eq.idx ] <- OUT$uni$X2 |
|
| 157 |
# } |
|
| 158 | ||
| 159 |
# scaled? |
|
| 160 |
# if(length(object@test) > 1L) {
|
|
| 161 |
# LIST$mi.scaled <- LIST$mi / object@test[[2]]$scaling.factor |
|
| 162 |
# } |
|
| 163 | ||
| 164 |
# EPC |
|
| 165 | ! |
d <- (-1 * N) * score |
| 166 |
# needed? probably not; just in case |
|
| 167 | ! |
d[which(abs(d) < 1e-15)] <- 1.0 |
| 168 | ! |
LIST$epc[LIST$free > 0] <- mi / d |
| 169 | ||
| 170 | ||
| 171 |
# standardize? |
|
| 172 | ! |
if (standardized) {
|
| 173 | ! |
EPC <- LIST$epc |
| 174 | ||
| 175 | ! |
if (cov.std) {
|
| 176 |
# replace epc values for variances by est values |
|
| 177 | ! |
var.idx <- which(LIST$op == "~~" & LIST$lhs == LIST$rhs & |
| 178 | ! |
LIST$exo == 0L) |
| 179 | ! |
EPC[var.idx] <- LIST$est[var.idx] |
| 180 |
} |
|
| 181 | ||
| 182 |
# two problems: |
|
| 183 |
# - EPC of variances can be negative, and that is |
|
| 184 |
# perfectly legal |
|
| 185 |
# - EPC (of variances) can be tiny (near-zero), and we should |
|
| 186 |
# not divide by tiny variables |
|
| 187 | ! |
small.idx <- which(LIST$op == "~~" & |
| 188 | ! |
LIST$lhs == LIST$rhs & |
| 189 | ! |
abs(EPC) < sqrt(.Machine$double.eps)) |
| 190 | ! |
if (length(small.idx) > 0L) {
|
| 191 | ! |
EPC[small.idx] <- as.numeric(NA) |
| 192 |
} |
|
| 193 | ||
| 194 |
# get the sign |
|
| 195 | ! |
EPC.sign <- sign(LIST$epc) |
| 196 | ||
| 197 | ! |
LIST$sepc.lv <- EPC.sign * lav_standardize_lv(object, |
| 198 | ! |
partable = LIST, |
| 199 | ! |
est = abs(EPC), |
| 200 | ! |
cov.std = cov.std |
| 201 |
) |
|
| 202 | ! |
if (length(small.idx) > 0L) {
|
| 203 | ! |
LIST$sepc.lv[small.idx] <- 0 |
| 204 |
} |
|
| 205 | ! |
LIST$sepc.all <- EPC.sign * lav_standardize_all(object, |
| 206 | ! |
partable = LIST, |
| 207 | ! |
est = abs(EPC), |
| 208 | ! |
cov.std = cov.std |
| 209 |
) |
|
| 210 | ! |
if (length(small.idx) > 0L) {
|
| 211 | ! |
LIST$sepc.all[small.idx] <- 0 |
| 212 |
} |
|
| 213 | ! |
LIST$sepc.nox <- EPC.sign * lav_standardize_all_nox(object, |
| 214 | ! |
partable = LIST, |
| 215 | ! |
est = abs(EPC), |
| 216 | ! |
cov.std = cov.std |
| 217 |
) |
|
| 218 | ! |
if (length(small.idx) > 0L) {
|
| 219 | ! |
LIST$sepc.nox[small.idx] <- 0 |
| 220 |
} |
|
| 221 |
} |
|
| 222 | ||
| 223 |
# power? |
|
| 224 | ! |
if (power) {
|
| 225 | ! |
LIST$delta <- delta |
| 226 |
# FIXME: this is using epc in unstandardized metric |
|
| 227 |
# this would be much more useful in standardized metric |
|
| 228 |
# we need a lav_standardize_all.reverse function... |
|
| 229 | ! |
LIST$ncp <- (LIST$mi / (LIST$epc * LIST$epc)) * (delta * delta) |
| 230 | ! |
LIST$power <- 1 - pchisq(qchisq((1.0 - alpha), df = 1), |
| 231 | ! |
df = 1, ncp = LIST$ncp |
| 232 |
) |
|
| 233 | ! |
LIST$decision <- character(length(LIST$power)) |
| 234 | ||
| 235 |
# five possibilities (Table 6 in Saris, Satorra, van der Veld, 2009) |
|
| 236 | ! |
mi.significant <- ifelse(1 - pchisq(LIST$mi, df = 1) < alpha, |
| 237 | ! |
TRUE, FALSE |
| 238 |
) |
|
| 239 | ! |
high.power <- LIST$power > high.power |
| 240 |
# FIXME: sepc.all or epc?? |
|
| 241 |
# epc.high <- abs(LIST$sepc.all) > LIST$delta |
|
| 242 | ! |
epc.high <- abs(LIST$epc) > LIST$delta |
| 243 | ||
| 244 | ! |
LIST$decision[which(!mi.significant & !high.power)] <- "(i)" |
| 245 | ! |
LIST$decision[which(mi.significant & !high.power)] <- "**(m)**" |
| 246 | ! |
LIST$decision[which(!mi.significant & high.power)] <- "(nm)" |
| 247 | ! |
LIST$decision[which(mi.significant & high.power & |
| 248 | ! |
!epc.high)] <- "epc:nm" |
| 249 | ! |
LIST$decision[which(mi.significant & high.power & |
| 250 | ! |
epc.high)] <- "*epc:m*" |
| 251 | ||
| 252 |
# LIST$decision[ which(mi.significant & high.power) ] <- "epc" |
|
| 253 |
# LIST$decision[ which(mi.significant & !high.power) ] <- "***" |
|
| 254 |
# LIST$decision[ which(!mi.significant & !high.power) ] <- "(i)" |
|
| 255 |
} |
|
| 256 | ||
| 257 |
# remove rows corresponding to 'fixed.x' exogenous parameters |
|
| 258 |
# exo.idx <- which(LIST$exo == 1L & nchar(LIST$plabel) > 0L) |
|
| 259 |
# if(length(exo.idx) > 0L) {
|
|
| 260 |
# LIST <- LIST[-exo.idx,] |
|
| 261 |
# } |
|
| 262 | ||
| 263 |
# remove some columns |
|
| 264 | ! |
LIST$id <- LIST$ustart <- LIST$exo <- LIST$label <- LIST$plabel <- NULL |
| 265 | ! |
LIST$start <- LIST$free <- LIST$est <- LIST$se <- LIST$prior <- NULL |
| 266 | ! |
LIST$upper <- LIST$lower <- NULL |
| 267 | ||
| 268 | ! |
if (power) {
|
| 269 | ! |
LIST$sepc.lv <- LIST$sepc.nox <- NULL |
| 270 |
} |
|
| 271 | ||
| 272 |
# create data.frame |
|
| 273 | ! |
LIST <- as.data.frame(LIST, stringsAsFactors = FALSE) |
| 274 | ! |
class(LIST) <- c("lavaan.data.frame", "data.frame")
|
| 275 | ||
| 276 |
# remove rows corresponding to 'old' free parameters |
|
| 277 | ! |
if (free.remove) {
|
| 278 | ! |
old.idx <- which(LIST$user != 10L) |
| 279 | ! |
if (length(old.idx) > 0L) {
|
| 280 | ! |
LIST <- LIST[-old.idx, ] |
| 281 |
} |
|
| 282 |
} |
|
| 283 | ||
| 284 |
# remove rows corresponding to 'equality' constraints |
|
| 285 | ! |
eq.idx <- which(LIST$op == "==") |
| 286 | ! |
if (length(eq.idx) > 0L) {
|
| 287 | ! |
LIST <- LIST[-eq.idx, ] |
| 288 |
} |
|
| 289 | ||
| 290 |
# remove even more columns |
|
| 291 | ! |
LIST$user <- NULL |
| 292 | ||
| 293 |
# remove block/group/level is only single block |
|
| 294 | ! |
if (lav_partable_nblocks(LIST) == 1L) {
|
| 295 | ! |
LIST$block <- NULL |
| 296 | ! |
LIST$group <- NULL |
| 297 | ! |
LIST$level <- NULL |
| 298 |
} |
|
| 299 | ||
| 300 |
# sort? |
|
| 301 | ! |
if (sort.) {
|
| 302 | ! |
LIST <- LIST[order(LIST$mi, decreasing = TRUE), ] |
| 303 |
} |
|
| 304 | ! |
if (minimum.value > 0.0) {
|
| 305 | ! |
LIST <- LIST[!is.na(LIST$mi) & LIST$mi > minimum.value, ] |
| 306 |
} |
|
| 307 | ! |
if (maximum.number < nrow(LIST)) {
|
| 308 | ! |
LIST <- LIST[seq_len(maximum.number), ] |
| 309 |
} |
|
| 310 | ! |
if (na.remove) {
|
| 311 | ! |
idx <- which(is.na(LIST$mi)) |
| 312 | ! |
if (length(idx) > 0) {
|
| 313 | ! |
LIST <- LIST[-idx, ] |
| 314 |
} |
|
| 315 |
} |
|
| 316 | ! |
if (!is.null(op)) {
|
| 317 | ! |
idx <- LIST$op %in% op |
| 318 | ! |
if (length(idx) > 0) {
|
| 319 | ! |
LIST <- LIST[idx, ] |
| 320 |
} |
|
| 321 |
} |
|
| 322 | ||
| 323 |
# add header |
|
| 324 |
# TODO: small explanation of the columns in the header? |
|
| 325 |
# attr(LIST, "header") <- |
|
| 326 |
# c("modification indices for newly added parameters only; to\n",
|
|
| 327 |
# "see the effects of releasing equality constraints, use the\n", |
|
| 328 |
# "lavTestScore() function") |
|
| 329 | ||
| 330 | ! |
LIST |
| 331 |
} |
|
| 332 | ||
| 333 |
# aliases |
|
| 334 |
modificationIndices <- modificationindices <- modindices |
| 1 |
# IV/MIIV estimation |
|
| 2 | ||
| 3 |
# internal function to be used inside lav_optim_noniter |
|
| 4 |
# return 'x', the estimated vector of free parameters |
|
| 5 |
lav_sem_miiv_internal <- function(lavmodel = NULL, lavh1 = NULL, |
|
| 6 |
lavsamplestats = NULL, |
|
| 7 |
lavpartable = NULL, |
|
| 8 |
lavdata = NULL, lavoptions = NULL) {
|
|
| 9 |
# IV options |
|
| 10 | ! |
iv.method <- toupper(lavoptions$estimator.args$iv.method) |
| 11 | ! |
stopifnot(iv.method %in% "2SLS") |
| 12 | ! |
iv.varcov.method <- toupper(lavoptions$estimator.args$iv.varcov.method) |
| 13 | ! |
iv.samplestats <- lavoptions$estimator.args$iv.samplestats |
| 14 |
# just in case |
|
| 15 | ! |
if (lavmodel@categorical) {
|
| 16 | ! |
iv.samplestats <- TRUE |
| 17 |
} |
|
| 18 | ! |
stopifnot(iv.varcov.method %in% c("ULS", "GLS", "2RLS", "RLS"))
|
| 19 | ||
| 20 |
# get lavpta |
|
| 21 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 22 | ||
| 23 |
# we assume the blocks are independent groups for now |
|
| 24 | ! |
stopifnot(lavdata@nlevels == 1L) |
| 25 | ||
| 26 |
# directed versus undirected (free) parameters |
|
| 27 | ! |
undirected.idx <- which(lavpartable$free > 0L & |
| 28 | ! |
!duplicated(lavpartable$free) & # if ceq.simple |
| 29 | ! |
lavpartable$op == "~~") |
| 30 | ! |
directed.idx <- which(lavpartable$free > 0L & |
| 31 | ! |
!duplicated(lavpartable$free) & # if ceq.simple |
| 32 | ! |
!lavpartable$op %in% c("~~", "~*~"))
|
| 33 | ! |
free.directed.idx <- unique(lavpartable$free[directed.idx]) |
| 34 | ! |
free.undirected.idx <- unique(lavpartable$free[undirected.idx]) |
| 35 | ||
| 36 |
# find ALL model-implied instrumental variables (miivs) per equation |
|
| 37 | ! |
eqs <- lav_model_find_iv(lavmodel = lavmodel, lavpta = lavpta) |
| 38 | ||
| 39 |
# parameter vector -> all NA (for the free parameters) |
|
| 40 | ! |
x <- lav_model_get_parameters(lavmodel) * as.numeric(NA) |
| 41 | ||
| 42 |
######################################## |
|
| 43 |
# first stage: directed parameter only # |
|
| 44 |
######################################## |
|
| 45 | ! |
theta1 <- numeric(0L) |
| 46 | ! |
if (length(free.directed.idx) > 0L) {
|
| 47 | ! |
if (iv.samplestats) {
|
| 48 | ! |
theta1 <- lav_sem_miiv_2sls_samplestats( |
| 49 | ! |
eqs = eqs, |
| 50 | ! |
lavmodel = lavmodel, lavpartable = lavpartable, |
| 51 | ! |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 52 | ! |
lavh1 = lavh1, free.directed.idx = free.directed.idx |
| 53 |
) |
|
| 54 |
} else {
|
|
| 55 | ! |
theta1 <- lav_sem_miiv_2sls( |
| 56 | ! |
eqs = eqs, |
| 57 | ! |
lavmodel = lavmodel, lavpartable = lavpartable, |
| 58 | ! |
lavdata = lavdata, free.directed.idx = free.directed.idx |
| 59 |
) |
|
| 60 |
} |
|
| 61 |
# update equations |
|
| 62 | ! |
eqs <- attr(theta1, "eqs") |
| 63 | ! |
theta1 <- as.numeric(theta1) # drop attributes |
| 64 |
# store theta1 elements in x |
|
| 65 | ! |
x[free.directed.idx] <- theta1 |
| 66 |
} |
|
| 67 | ||
| 68 |
####################################### |
|
| 69 |
# second stage: undirected parameters # |
|
| 70 |
####################################### |
|
| 71 | ||
| 72 |
# compute theta2 using ULS/GLS/RLS/2RLS |
|
| 73 | ! |
theta2 <- numeric(0L) |
| 74 | ! |
if (length(free.undirected.idx) > 0L) {
|
| 75 | ! |
theta2 <- lav_sem_miiv_varcov( |
| 76 | ! |
x = theta1, |
| 77 | ! |
lavmodel = lavmodel, lavpartable = lavpartable, |
| 78 | ! |
lavh1 = lavh1, free.directed.idx = free.directed.idx, |
| 79 | ! |
free.undirected.idx = free.undirected.idx, |
| 80 | ! |
iv.varcov.method = iv.varcov.method |
| 81 |
) |
|
| 82 |
# store theta2 elements in x |
|
| 83 | ! |
x[free.undirected.idx] <- theta2 |
| 84 |
} |
|
| 85 | ||
| 86 | ! |
attr(x, "eqs") <- eqs |
| 87 | ! |
x |
| 88 |
} |
|
| 89 | ||
| 90 | ||
| 91 |
# stage 1: use 2SLS to find the regression coefficients of all |
|
| 92 |
# directed effects in the model -- continous/raw-data version |
|
| 93 |
lav_sem_miiv_2sls <- function(eqs = NULL, lavmodel = NULL, lavpartable = NULL, |
|
| 94 |
lavdata = NULL, free.directed.idx = NULL) {
|
|
| 95 |
# this function is for continuous/raw-data only |
|
| 96 | ! |
stopifnot(lavdata@data.type == "full") |
| 97 | ! |
stopifnot(!lavmodel@categorical) |
| 98 | ||
| 99 |
# get lavpta |
|
| 100 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 101 | ||
| 102 | ! |
if (is.null(eqs)) {
|
| 103 |
# find ALL model-implied instrumental variables (miivs) per equation |
|
| 104 | ! |
eqs <- lav_model_find_iv(lavmodel = lavmodel, lavpta = lavpta) |
| 105 |
} |
|
| 106 | ||
| 107 |
# number of blocks |
|
| 108 | ! |
nblocks <- lavmodel@nblocks |
| 109 | ||
| 110 |
# parameter vector -> all NA (for the free parameters) |
|
| 111 | ! |
x <- lav_model_get_parameters(lavmodel) * as.numeric(NA) |
| 112 | ||
| 113 |
# 2SLS per equation |
|
| 114 |
# for now: - no equality constraints (yet) |
|
| 115 |
# - only OLS (not robust, no lasso, ...) |
|
| 116 | ! |
for (b in seq_len(nblocks)) {
|
| 117 |
# ov.names for this block |
|
| 118 | ! |
ov.names <- lavpta$vnames$ov[[b]] |
| 119 | ||
| 120 |
# raw data for this block |
|
| 121 | ! |
XY <- lavdata@X[[b]] |
| 122 | ||
| 123 |
# estimation per equation |
|
| 124 | ! |
for (j in seq_along(eqs[[b]])) {
|
| 125 |
# this equation |
|
| 126 | ! |
eq <- eqs[[b]][[j]] |
| 127 | ||
| 128 |
# iv_flag? |
|
| 129 | ! |
iv_flag <- TRUE |
| 130 | ! |
if (!is.null(eq$iv_flag)) {
|
| 131 | ! |
iv_flag <- eq$iv_flag |
| 132 |
} else {
|
|
| 133 |
# if rhs_new matches miiv, iv_flag is FALSE |
|
| 134 | ! |
if (identical(eq$rhs_new, eq$miiv)) {
|
| 135 | ! |
iv_flag <- FALSE |
| 136 |
} |
|
| 137 |
} |
|
| 138 | ||
| 139 |
# Y: there is always an y variable |
|
| 140 | ! |
y.idx <- match(eq$lhs_new, ov.names) |
| 141 | ! |
yvec <- XY[, y.idx, drop = TRUE] # y-variable (always scalar) |
| 142 | ||
| 143 |
# X: usually, there are x variables (apart from the "1") |
|
| 144 | ! |
if (identical(eq$rhs_new, "1")) {
|
| 145 | ! |
x.idx <- integer(0L) |
| 146 | ! |
xmat <- matrix(0, nrow = nrow(XY), ncol = 0L) |
| 147 |
} else {
|
|
| 148 | ! |
x.idx <- match(eq$rhs_new, ov.names) |
| 149 | ! |
xmat <- XY[, x.idx, drop = FALSE] |
| 150 |
} |
|
| 151 | ||
| 152 |
# Z: instruments |
|
| 153 | ! |
if (iv_flag) {
|
| 154 | ! |
i.idx <- match(eq$miiv, ov.names) |
| 155 | ! |
imat <- cbind(1, XY[, i.idx, drop = FALSE]) # instruments |
| 156 |
} |
|
| 157 | ||
| 158 |
# weights |
|
| 159 | ! |
weights <- lavdata@weights[[b]] |
| 160 | ||
| 161 |
# sargan vector |
|
| 162 | ! |
sargan <- rep(as.numeric(NA), 3L) |
| 163 | ! |
names(sargan) <- c("stat", "df", "pvalue")
|
| 164 | ||
| 165 |
# 0. check |
|
| 166 | ! |
if (iv_flag && length(eq$miiv) < length(eq$rhs)) {
|
| 167 |
# what to do? skip, or proceed anyway? |
|
| 168 | ! |
eqs[[b]][[j]]$coef <- numeric(0L) |
| 169 | ! |
eqs[[b]][[j]]$nobs <- nrow(xmat) |
| 170 | ! |
eqs[[b]][[j]]$df_res <- as.integer(NA) |
| 171 | ! |
eqs[[b]][[j]]$resvar <- as.numeric(NA) |
| 172 | ! |
eqs[[b]][[j]]$resvar_df_res <- as.numeric(NA) |
| 173 | ! |
eqs[[b]][[j]]$XX <- crossprod(cbind(1, xmat)) |
| 174 | ! |
eqs[[b]][[j]]$vcov <- matrix(0, 0L, 0L) |
| 175 | ! |
eqs[[b]][[j]]$sargan <- sargan |
| 176 | ! |
next |
| 177 |
} |
|
| 178 | ||
| 179 |
# 1. regress x on instruments |
|
| 180 | ! |
if (iv_flag) {
|
| 181 | ! |
if (is.null(weights)) {
|
| 182 | ! |
fit_x_on_z <- lm.fit(x = imat, y = xmat) |
| 183 |
} else {
|
|
| 184 | ! |
fit_x_on_z <- lm.wfit(x = imat, y = xmat, weights = weights) |
| 185 |
} |
|
| 186 |
# check for NA's |
|
| 187 | ! |
if (anyNA(fit_x_on_z$coefficients)) {
|
| 188 | ! |
lav_msg_warn(gettextf( |
| 189 | ! |
"regression %s on %s failed (NAs); |
| 190 | ! |
redundant instruments?", |
| 191 | ! |
paste(ov.names[x.idx], collapse = " + "), |
| 192 | ! |
paste(ov.names[i.idx], collapse = " + ") |
| 193 |
)) |
|
| 194 |
} |
|
| 195 | ! |
xhat <- as.matrix(fit_x_on_z$fitted.values) |
| 196 |
} else {
|
|
| 197 |
# just plain regression: x == xhat |
|
| 198 | ! |
xhat <- xmat |
| 199 |
} |
|
| 200 | ||
| 201 |
# 2. regress y on xhat |
|
| 202 | ! |
if (is.null(weights)) {
|
| 203 | ! |
fit_y_on_xhat <- lm.fit(x = cbind(1, xhat), y = yvec) |
| 204 |
} else {
|
|
| 205 | ! |
fit_y_on_xhat <- lm.wfit( |
| 206 | ! |
x = cbind(1, xhat), y = yvec, |
| 207 | ! |
weights = weights |
| 208 |
) |
|
| 209 |
} |
|
| 210 | ||
| 211 |
# 3. fill estimates in x |
|
| 212 |
# - eq$pt contains partable/user rows |
|
| 213 |
# - lavpartable$free[eq$pt] should give the free idx |
|
| 214 | ! |
free.idx <- lavpartable$free[eq$pt] |
| 215 | ! |
if (length(x.idx) > 0L) {
|
| 216 | ! |
if (all(free.idx > 0L)) {
|
| 217 | ! |
x[free.idx] <- fit_y_on_xhat$coefficients[-1] |
| 218 |
} else {
|
|
| 219 |
# remove non-free elements |
|
| 220 | ! |
zero.idx <- which(free.idx == 0L) |
| 221 | ! |
free.idx <- free.idx[-zero.idx] |
| 222 | ! |
if (length(free.idx) > 0) {
|
| 223 | ! |
x[free.idx] <- fit_y_on_xhat$coefficients[-1][-zero.idx] |
| 224 |
} |
|
| 225 |
} |
|
| 226 |
} |
|
| 227 | ! |
if (lavmodel@meanstructure) {
|
| 228 | ! |
free.int.idx <- lavpartable$free[eq$ptint] |
| 229 | ! |
if (free.int.idx > 0L) {
|
| 230 | ! |
x[free.int.idx] <- fit_y_on_xhat$coefficients[1] |
| 231 |
} |
|
| 232 |
} |
|
| 233 | ||
| 234 |
# 4. resvar |
|
| 235 | ! |
notna.idx <- unname(which(!is.na(fit_y_on_xhat$coefficients))) |
| 236 | ! |
ycoef <- fit_y_on_xhat$coefficients[notna.idx] |
| 237 | ! |
res <- yvec - drop(cbind(1, xmat)[, notna.idx, drop = FALSE] %*% ycoef) |
| 238 | ! |
df_res <- fit_y_on_xhat$df.residual |
| 239 | ! |
if (is.null(weights)) {
|
| 240 | ! |
sse <- sum(res * res) |
| 241 |
} else {
|
|
| 242 | ! |
sse <- sum(weights * res * res) |
| 243 |
} |
|
| 244 | ! |
resvar_df_res <- sse / df_res # what we should do... |
| 245 | ! |
resvar <- sse / length(res) |
| 246 | ||
| 247 |
# 5. naive cov (for standard errors) (see summary.lm in base R) |
|
| 248 | ! |
p1 <- 1L:fit_y_on_xhat$rank |
| 249 | ! |
R <- chol2inv(fit_y_on_xhat$qr$qr[p1, p1, drop = FALSE]) |
| 250 | ! |
vcov <- R * resvar # scaled (for now) |
| 251 | ||
| 252 |
# 6. Sargan test (see summary.ivreg.R 363--371) |
|
| 253 | ! |
if (iv_flag) {
|
| 254 | ! |
sargan["df"] <- length(i.idx) - length(x.idx) |
| 255 | ! |
if (sargan["df"] > 0L) {
|
| 256 | ! |
if (is.null(weights)) {
|
| 257 | ! |
fit_yres_on_z <- lm.fit(x = imat, y = res) |
| 258 | ! |
rssr <- sum((res - mean(res))^2) |
| 259 | ! |
sse2 <- sum(fit_yres_on_z$residuals * fit_yres_on_z$residuals) |
| 260 |
} else {
|
|
| 261 | ! |
fit_yres_on_z <- lm.wfit(x = imat, y = res, weights = weights) |
| 262 | ! |
rssr <- sum(weights * (res - weighted.mean(res, weights))^2) |
| 263 | ! |
sse2 <- sum(weights * fit_yres_on_z$residuals * |
| 264 | ! |
fit_yres_on_z$residuals) |
| 265 |
} |
|
| 266 | ! |
sargan["stat"] <- length(res) * (1 - sse2 / rssr) |
| 267 | ! |
sargan["pvalue"] <- pchisq(sargan["stat"], sargan["df"], |
| 268 | ! |
lower.tail = FALSE |
| 269 |
) |
|
| 270 |
} |
|
| 271 |
} |
|
| 272 | ||
| 273 |
# add info to eqs list |
|
| 274 | ! |
eqs[[b]][[j]]$coef <- unname(fit_y_on_xhat$coefficients) |
| 275 | ! |
eqs[[b]][[j]]$nobs <- nrow(xmat) |
| 276 | ! |
eqs[[b]][[j]]$df_res <- df_res |
| 277 | ! |
eqs[[b]][[j]]$resvar <- resvar |
| 278 | ! |
eqs[[b]][[j]]$resvar_df_res <- resvar_df_res |
| 279 | ! |
eqs[[b]][[j]]$XX <- crossprod(cbind(1, xmat)) # needed? or only vcov? |
| 280 | ! |
eqs[[b]][[j]]$vcov <- vcov |
| 281 | ! |
eqs[[b]][[j]]$sargan <- sargan |
| 282 |
} # eqs |
|
| 283 |
} # nblocks |
|
| 284 | ||
| 285 |
# return theta1 |
|
| 286 | ! |
theta1 <- x[free.directed.idx] |
| 287 | ||
| 288 |
# add equations as an attribute |
|
| 289 | ! |
attr(theta1, "eqs") <- eqs |
| 290 | ||
| 291 | ! |
theta1 |
| 292 |
} |
|
| 293 | ||
| 294 |
# stage 1: use 2SLS to find the regression coefficients of all |
|
| 295 |
# directed effects in the model -- samplestats version |
|
| 296 |
lav_sem_miiv_2sls_samplestats <- function(eqs = NULL, lavmodel = NULL, |
|
| 297 |
lavpartable = NULL, lavdata = NULL, |
|
| 298 |
lavsamplestats = NULL, lavh1 = NULL, |
|
| 299 |
free.directed.idx = NULL) {
|
|
| 300 |
# helper function: first chol, then eigen if chol fails |
|
| 301 | ! |
solve_spd <- function(A, B, tol = 1e-10) {
|
| 302 | ! |
cholA <- try(chol(A), silent = TRUE) |
| 303 | ! |
if (!inherits(cholA, "try-error")) {
|
| 304 |
# Cholesky solve |
|
| 305 | ! |
return(backsolve(cholA, forwardsolve(t(cholA), B))) |
| 306 |
} else {
|
|
| 307 |
# Eigen fallback (pseudo-inverse) |
|
| 308 | ! |
eig <- eigen(A, symmetric = TRUE) |
| 309 | ! |
keep <- eig$values > tol * max(eig$values) |
| 310 | ! |
Ainv <- eig$vectors[, keep, drop = FALSE] %*% |
| 311 | ! |
diag(1 / eig$values[keep], length(eig$values[keep])) %*% |
| 312 | ! |
t(eig$vectors[, keep, drop = FALSE]) |
| 313 | ! |
return(Ainv %*% B) |
| 314 |
} |
|
| 315 |
} |
|
| 316 | ||
| 317 |
# no conditional.x for now! |
|
| 318 | ! |
stopifnot(!lavmodel@conditional.x) |
| 319 | ||
| 320 |
# get lavpta |
|
| 321 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 322 | ||
| 323 | ! |
if (is.null(eqs)) {
|
| 324 |
# find ALL model-implied instrumental variables (miivs) per equation |
|
| 325 | ! |
eqs <- lav_model_find_iv(lavmodel = lavmodel, lavpta = lavpta) |
| 326 |
} |
|
| 327 | ||
| 328 |
# number of blocks |
|
| 329 | ! |
nblocks <- lavmodel@nblocks |
| 330 | ||
| 331 |
# parameter vector -> all NA (for the free parameters) |
|
| 332 | ! |
x <- lav_model_get_parameters(lavmodel) * as.numeric(NA) |
| 333 | ||
| 334 |
# 2SLS per equation |
|
| 335 |
# for now: - no equality constraints (yet) |
|
| 336 |
# - only OLS (not robust, no lasso, ...) |
|
| 337 | ! |
for (b in seq_len(nblocks)) {
|
| 338 |
# ov.names for this block |
|
| 339 | ! |
ov.names <- lavpta$vnames$ov[[b]] |
| 340 | ||
| 341 |
# sample statistics for this block |
|
| 342 | ! |
sample.cov <- lavh1$implied$cov[[b]] |
| 343 | ! |
sample.mean <- lavh1$implied$mean[[b]] |
| 344 | ||
| 345 |
# nobs for this 'block' |
|
| 346 | ! |
nobs <- lavsamplestats@nobs[[b]] |
| 347 | ||
| 348 |
# estimation per equation |
|
| 349 | ! |
for (j in seq_along(eqs[[b]])) {
|
| 350 |
# this equation |
|
| 351 | ! |
eq <- eqs[[b]][[j]] |
| 352 | ||
| 353 |
# iv_flag? |
|
| 354 | ! |
iv_flag <- TRUE |
| 355 | ! |
if (!is.null(eq$iv_flag)) {
|
| 356 | ! |
iv_flag <- eq$iv_flag |
| 357 |
} else {
|
|
| 358 |
# if rhs_new matches miiv, iv_flag is FALSE |
|
| 359 | ! |
if (identical(eq$rhs_new, eq$miiv)) {
|
| 360 | ! |
iv_flag <- FALSE |
| 361 |
} |
|
| 362 |
} |
|
| 363 | ||
| 364 |
# Y: there is always an y variable |
|
| 365 | ! |
y.idx <- match(eq$lhs_new, ov.names) |
| 366 | ! |
y.bar <- sample.mean[y.idx] |
| 367 | ||
| 368 |
# X: usually, there are x variables (apart from the "1") |
|
| 369 | ! |
if (identical(eq$rhs_new, "1")) {
|
| 370 | ! |
x.idx <- integer(0L) |
| 371 |
} else {
|
|
| 372 | ! |
x.idx <- match(eq$rhs_new, ov.names) |
| 373 | ! |
x.bar <- sample.mean[x.idx] |
| 374 |
} |
|
| 375 | ||
| 376 |
# Z: instruments |
|
| 377 | ! |
S_Xy <- sample.cov[x.idx, y.idx, drop = FALSE] |
| 378 | ! |
S_XX <- sample.cov[x.idx, x.idx, drop = FALSE] |
| 379 | ! |
s_yy <- sample.cov[y.idx, y.idx, drop = FALSE] |
| 380 | ! |
if (iv_flag) {
|
| 381 | ! |
i.idx <- match(eq$miiv, ov.names) |
| 382 | ! |
S_XZ <- sample.cov[x.idx, i.idx, drop = FALSE] |
| 383 | ! |
S_ZX <- sample.cov[i.idx, x.idx, drop = FALSE] |
| 384 | ! |
S_ZZ <- sample.cov[i.idx, i.idx, drop = FALSE] |
| 385 | ! |
S_Zy <- sample.cov[i.idx, y.idx, drop = FALSE] |
| 386 |
} |
|
| 387 | ||
| 388 |
# sargan vector |
|
| 389 | ! |
sargan <- rep(as.numeric(NA), 3L) |
| 390 | ! |
names(sargan) <- c("stat", "df", "pvalue")
|
| 391 | ||
| 392 |
# 0. check |
|
| 393 | ! |
if (iv_flag && length(eq$miiv) < length(eq$rhs)) {
|
| 394 |
# what to do? skip, or proceed anyway? |
|
| 395 | ! |
eqs[[b]][[j]]$coef <- numeric(0L) |
| 396 | ! |
eqs[[b]][[j]]$nobs <- nobs |
| 397 | ! |
eqs[[b]][[j]]$df_res <- as.integer(NA) |
| 398 | ! |
eqs[[b]][[j]]$resvar <- as.numeric(NA) |
| 399 | ! |
eqs[[b]][[j]]$resvar_df_res <- as.numeric(NA) |
| 400 | ! |
eqs[[b]][[j]]$XX <- matrix(0, 0L, 0L) |
| 401 | ! |
eqs[[b]][[j]]$vcov <- matrix(0, 0L, 0L) |
| 402 | ! |
eqs[[b]][[j]]$sargan <- sargan |
| 403 | ! |
next |
| 404 |
} |
|
| 405 | ||
| 406 | ! |
fit_y_on_xhat <- list() |
| 407 | ! |
if (iv_flag) {
|
| 408 |
# Step 1: compute S_ZZ^{-1} S_ZX and S_ZZ^{-1} S_Zy
|
|
| 409 | ! |
W <- solve_spd(S_ZZ, S_ZX) |
| 410 | ! |
v <- solve_spd(S_ZZ, S_Zy) |
| 411 |
# Step 2: build reduced system |
|
| 412 | ! |
Amat <- S_XZ %*% W |
| 413 | ! |
bvec <- S_XZ %*% v |
| 414 | ! |
beta_slopes <- drop(solve_spd(Amat, bvec)) |
| 415 | ! |
beta0 <- as.vector(y.bar - t(x.bar) %*% beta_slopes) |
| 416 |
} else {
|
|
| 417 | ! |
if (length(x.idx) > 0L) {
|
| 418 | ! |
Amat <- S_XX |
| 419 | ! |
bvec <- S_Xy |
| 420 | ! |
beta_slopes <- drop(solve_spd(Amat, bvec)) |
| 421 | ! |
beta0 <- as.vector(y.bar - t(x.bar) %*% beta_slopes) |
| 422 |
} else {
|
|
| 423 | ! |
beta_slopes <- numeric(0L) |
| 424 | ! |
beta0 <- y.bar |
| 425 |
} |
|
| 426 |
} |
|
| 427 | ! |
fit_y_on_xhat$coefficients <- c(beta0, beta_slopes) |
| 428 | ||
| 429 |
# 3. fill estimates in x |
|
| 430 |
# - eq$pt contains partable/user rows |
|
| 431 |
# - lavpartable$free[eq$pt] should give the free idx |
|
| 432 | ! |
free.idx <- lavpartable$free[eq$pt] |
| 433 | ! |
if (length(x.idx) > 0L) {
|
| 434 | ! |
if (all(free.idx > 0L)) {
|
| 435 | ! |
x[free.idx] <- fit_y_on_xhat$coefficients[-1] |
| 436 |
} else {
|
|
| 437 |
# remove non-free elements |
|
| 438 | ! |
zero.idx <- which(free.idx == 0L) |
| 439 | ! |
free.idx <- free.idx[-zero.idx] |
| 440 | ! |
if (length(free.idx) > 0) {
|
| 441 | ! |
x[free.idx] <- fit_y_on_xhat$coefficients[-1][-zero.idx] |
| 442 |
} |
|
| 443 |
} |
|
| 444 |
} |
|
| 445 | ! |
if (lavmodel@meanstructure) {
|
| 446 | ! |
free.int.idx <- lavpartable$free[eq$ptint] |
| 447 | ! |
if (free.int.idx > 0L) {
|
| 448 | ! |
x[free.int.idx] <- fit_y_on_xhat$coefficients[1] |
| 449 |
} |
|
| 450 |
} |
|
| 451 | ||
| 452 |
# 4. resvar |
|
| 453 | ! |
if (length(x.idx) > 0L) {
|
| 454 | ! |
tmp <- S_XX %*% beta_slopes |
| 455 | ! |
resvar <- as.numeric(s_yy - 2 * t(beta_slopes) %*% S_Xy + |
| 456 | ! |
t(beta_slopes) %*% tmp) |
| 457 |
} else {
|
|
| 458 | ! |
resvar <- drop(s_yy) |
| 459 |
} |
|
| 460 | ! |
df_res <- nobs - (length(x.idx) + 1L) |
| 461 | ! |
resvar_df_res <- resvar * nobs / df_res |
| 462 | ||
| 463 |
# 5. naive cov (for standard errors) (see summary.lm in base R) |
|
| 464 | ! |
if (length(x.idx) > 0L) {
|
| 465 | ! |
Ainv <- solve_spd(Amat, diag(x = 1, nrow = nrow(Amat))) |
| 466 | ! |
vcov.slopes <- (resvar / nobs) * Ainv |
| 467 | ! |
vcov.beta0 <- (resvar / nobs) + t(x.bar) %*% vcov.slopes %*% x.bar |
| 468 | ! |
cov.beta0.slopes <- -vcov.slopes %*% x.bar |
| 469 | ! |
vcov <- matrix(0, length(x.idx) + 1L, length(x.idx) + 1L) |
| 470 | ! |
vcov[1, 1] <- vcov.beta0 |
| 471 | ! |
vcov[1, -1] <- t(cov.beta0.slopes) |
| 472 | ! |
vcov[-1, 1] <- cov.beta0.slopes |
| 473 | ! |
vcov[-1, -1] <- vcov.slopes |
| 474 |
} else {
|
|
| 475 |
# only intercept |
|
| 476 | ! |
vcov <- matrix(resvar / nobs, 1L, 1L) |
| 477 |
} |
|
| 478 | ||
| 479 |
# 6. Sargan test (see summary.ivreg.R 363--371) |
|
| 480 | ! |
if (iv_flag) {
|
| 481 | ! |
sargan["df"] <- length(i.idx) - length(x.idx) |
| 482 | ! |
if (sargan["df"] > 0L) {
|
| 483 | ! |
g <- S_Zy - S_ZX %*% beta_slopes |
| 484 | ! |
w <- solve_spd(S_ZZ, g) |
| 485 | ! |
sargan["stat"] <- as.numeric(nobs * t(g) %*% w / resvar) |
| 486 | ! |
sargan["pvalue"] <- pchisq(sargan["stat"], sargan["df"], |
| 487 | ! |
lower.tail = FALSE |
| 488 |
) |
|
| 489 |
} |
|
| 490 |
} |
|
| 491 | ||
| 492 |
# XX (needed?) |
|
| 493 | ! |
if (length(x.idx) > 0L) {
|
| 494 | ! |
XX <- tcrossprod(c(1, x.bar)) * nobs |
| 495 | ! |
XX[-1, -1] <- (S_XX + tcrossprod(x.bar)) * nobs |
| 496 |
} else {
|
|
| 497 | ! |
XX <- matrix(nobs, 1L, 1L) |
| 498 |
} |
|
| 499 | ||
| 500 |
# add info to eqs list |
|
| 501 | ! |
eqs[[b]][[j]]$coef <- unname(fit_y_on_xhat$coefficients) |
| 502 | ! |
eqs[[b]][[j]]$nobs <- nobs |
| 503 | ! |
eqs[[b]][[j]]$df_res <- df_res |
| 504 | ! |
eqs[[b]][[j]]$resvar <- resvar |
| 505 | ! |
eqs[[b]][[j]]$resvar_df_res <- resvar_df_res |
| 506 | ! |
eqs[[b]][[j]]$XX <- XX |
| 507 | ! |
eqs[[b]][[j]]$vcov <- vcov |
| 508 | ! |
eqs[[b]][[j]]$sargan <- sargan |
| 509 |
} # eqs |
|
| 510 |
} # nblocks |
|
| 511 | ||
| 512 |
# return theta1 |
|
| 513 | ! |
theta1 <- x[free.directed.idx] |
| 514 | ||
| 515 |
# add equations as an attribute |
|
| 516 | ! |
attr(theta1, "eqs") <- eqs |
| 517 | ||
| 518 | ! |
theta1 |
| 519 |
} |
|
| 520 | ||
| 521 | ||
| 522 |
# by default: input (x) is theta1 (only) |
|
| 523 |
# BUT if impliedvec is TRUE, then x contains the sample statisics |
|
| 524 |
# this allows us to compute the jacobian wrt theta1 elements (keeping |
|
| 525 |
# sample statistics fixed, or the jacobian wrt the sample statistics |
|
| 526 |
# (keeping theta1 fixed) |
|
| 527 |
lav_sem_miiv_varcov <- function(x = NULL, impliedvec = FALSE, |
|
| 528 |
lavmodel = NULL, lavpartable = NULL, |
|
| 529 |
lavh1 = NULL, free.directed.idx = NULL, |
|
| 530 |
free.undirected.idx = NULL, |
|
| 531 |
iv.varcov.method = "RLS") {
|
|
| 532 | ! |
if (impliedvec) {
|
| 533 | ! |
implied <- lav_vec_to_implied(x, lavmodel = lavmodel) |
| 534 | ! |
x <- lav_model_get_parameters(lavmodel) |
| 535 | ! |
theta1 <- x[free.directed.idx] |
| 536 |
} else {
|
|
| 537 | ! |
theta1 <- x |
| 538 | ! |
x <- lav_model_get_parameters(lavmodel) |
| 539 | ! |
x[free.directed.idx] <- theta1 |
| 540 | ! |
implied <- lavh1$implied |
| 541 |
} |
|
| 542 | ||
| 543 |
# number of blocks |
|
| 544 | ! |
nblocks <- lavmodel@nblocks |
| 545 | ||
| 546 |
# preparations |
|
| 547 | ! |
lavmodel.tmp <- lav_model_set_parameters(lavmodel = lavmodel, x = x) |
| 548 | ! |
delta_block <- lav_model_delta( |
| 549 | ! |
lavmodel = lavmodel.tmp, |
| 550 | ! |
ceq.simple = lavmodel@ceq.simple.only |
| 551 |
) |
|
| 552 | ||
| 553 |
# create block-diagonal W_2 and s |
|
| 554 | ! |
w2_block <- vector("list", length = nblocks)
|
| 555 | ! |
s_block <- vector("list", length = nblocks)
|
| 556 | ! |
delta2_block <- vector("list", length = nblocks)
|
| 557 | ! |
for (b in seq_len(nblocks)) {
|
| 558 | ! |
sample_cov <- implied$cov[[b]] |
| 559 | ! |
sample_mean <- implied$mean[[b]] |
| 560 | ||
| 561 |
# delta2 |
|
| 562 | ! |
delta2_block[[b]] <- delta_block[[b]][, free.undirected.idx, drop = FALSE] |
| 563 | ! |
if (iv.varcov.method == "GLS") {
|
| 564 | ! |
s.inv <- solve(sample_cov) |
| 565 |
} else { # ULS, or starting point for 2RLS/RLS
|
|
| 566 | ! |
s.inv <- diag(1, nrow = nrow(sample_cov)) |
| 567 |
} |
|
| 568 | ! |
w2_22 <- 0.5 * lav_matrix_duplication_pre_post(s.inv %x% s.inv) |
| 569 | ! |
if (lavmodel@meanstructure) {
|
| 570 | ! |
w2_11 <- s.inv |
| 571 | ! |
w2_block[[b]] <- lav_matrix_bdiag(w2_11, w2_22) |
| 572 | ! |
s_block[[b]] <- c(sample_mean, lav_matrix_vech(sample_cov)) |
| 573 |
} else {
|
|
| 574 | ! |
w2_block[[b]] <- w2_22 |
| 575 | ! |
s_block[[b]] <- lav_matrix_vech(sample_cov) |
| 576 |
} |
|
| 577 |
} |
|
| 578 | ! |
Delta2 <- do.call("rbind", delta2_block)
|
| 579 | ! |
W2 <- lav_matrix_bdiag(w2_block) |
| 580 | ! |
svech <- unlist(s_block) |
| 581 | ||
| 582 |
# initial estimate for theta.2 |
|
| 583 |
# TODO: if any constraints are needed, we need to augment the information |
|
| 584 | ! |
theta2 <- drop(solve( |
| 585 | ! |
t(Delta2) %*% W2 %*% Delta2, |
| 586 | ! |
t(Delta2) %*% W2 %*% svech |
| 587 |
)) |
|
| 588 | ||
| 589 |
# again, but now with Sigma |
|
| 590 | ! |
if (iv.varcov.method == "2RLS") {
|
| 591 | ! |
x[free.undirected.idx] <- theta2 |
| 592 | ! |
lavmodel.tmp <- lav_model_set_parameters(lavmodel = lavmodel, x = x) |
| 593 | ! |
sigma <- lav_model_sigma(lavmodel = lavmodel.tmp, extra = FALSE) |
| 594 | ! |
w2_block <- vector("list", length = nblocks)
|
| 595 | ! |
for (b in seq_len(nblocks)) {
|
| 596 |
# delta2 |
|
| 597 | ! |
s.inv <- solve(sigma[[b]]) |
| 598 | ! |
w2_22 <- 0.5 * lav_matrix_duplication_pre_post(s.inv %x% s.inv) |
| 599 | ! |
if (lavmodel@meanstructure) {
|
| 600 | ! |
w2_11 <- s.inv |
| 601 | ! |
w2_block[[b]] <- lav_matrix_bdiag(w2_11, w2_22) |
| 602 |
} else {
|
|
| 603 | ! |
w2_block[[b]] <- w2_22 |
| 604 |
} |
|
| 605 |
} |
|
| 606 | ! |
W2 <- lav_matrix_bdiag(w2_block) |
| 607 |
# final estimate for theta.2 |
|
| 608 |
# TODO: if any constraints are needed, we need to augment the information |
|
| 609 | ! |
theta2 <- drop(solve( |
| 610 | ! |
t(Delta2) %*% W2 %*% Delta2, |
| 611 | ! |
t(Delta2) %*% W2 %*% svech |
| 612 |
)) |
|
| 613 | ! |
} else if (iv.varcov.method == "RLS") {
|
| 614 | ! |
for (i in 1:200) {
|
| 615 | ! |
old_x <- theta2 |
| 616 | ! |
x[free.undirected.idx] <- theta2 |
| 617 | ! |
lavmodel.tmp <- lav_model_set_parameters(lavmodel = lavmodel, x = x) |
| 618 | ! |
sigma <- lav_model_sigma(lavmodel = lavmodel.tmp, extra = FALSE) |
| 619 | ! |
w2_block <- vector("list", length = nblocks)
|
| 620 | ! |
for (b in seq_len(nblocks)) {
|
| 621 |
# delta2 |
|
| 622 | ! |
s.inv <- solve(sigma[[b]]) |
| 623 | ! |
w2_22 <- 0.5 * lav_matrix_duplication_pre_post(s.inv %x% s.inv) |
| 624 | ! |
if (lavmodel@meanstructure) {
|
| 625 | ! |
w2_11 <- s.inv |
| 626 | ! |
w2_block[[b]] <- lav_matrix_bdiag(w2_11, w2_22) |
| 627 |
} else {
|
|
| 628 | ! |
w2_block[[b]] <- w2_22 |
| 629 |
} |
|
| 630 |
} |
|
| 631 | ! |
W2 <- lav_matrix_bdiag(w2_block) |
| 632 |
# final estimate for theta.2 |
|
| 633 |
# TODO: if any constraints are needed, we need to augment the information |
|
| 634 | ! |
theta2 <- drop(solve( |
| 635 | ! |
t(Delta2) %*% W2 %*% Delta2, |
| 636 | ! |
t(Delta2) %*% W2 %*% svech |
| 637 |
)) |
|
| 638 | ! |
sse <- sum((old_x - theta2)^2) |
| 639 |
# cat("i = ", i, "sse = ", sse, "\n")
|
|
| 640 | ! |
if (sse < 1e-05) {
|
| 641 | ! |
break |
| 642 | ! |
} else if (i == 200L) {
|
| 643 | ! |
lav_msg_warn(gettext("RLS for variances/covariances did not converge
|
| 644 | ! |
after 200 iterations.")) |
| 645 |
} |
|
| 646 |
} |
|
| 647 |
} |
|
| 648 | ||
| 649 | ! |
theta2 |
| 650 |
} |
|
| 651 | ||
| 652 | ||
| 653 |
# VCOV for free parameters |
|
| 654 |
lav_sem_miiv_vcov <- function(lavmodel = NULL, lavsamplestats = NULL, |
|
| 655 |
lavoptions = NULL, lavpartable = NULL, |
|
| 656 |
lavimplied = NULL, |
|
| 657 |
lavh1 = NULL, eqs = NULL) {
|
|
| 658 |
# iv options |
|
| 659 | ! |
iv.varcov.se <- lavoptions$estimator.args$iv.varcov.se |
| 660 | ! |
iv.varcov.modelbased <- lavoptions$estimator.args$iv.varcov.modelbased |
| 661 | ! |
iv.varcov.method <- toupper(lavoptions$estimator.args$iv.varcov.method) |
| 662 | ||
| 663 |
# empty vcov |
|
| 664 | ! |
vcov <- matrix(0, lavmodel@nx.free, lavmodel@nx.free) |
| 665 | ||
| 666 |
# nblocks |
|
| 667 | ! |
nblocks <- lavmodel@nblocks |
| 668 | ||
| 669 |
# FIXME: what about scaling parameters (~*~)? (ignored for now) |
|
| 670 | ||
| 671 | ! |
undirected.idx <- which(lavpartable$free > 0L & |
| 672 | ! |
!duplicated(lavpartable$free) & # if ceq.simple |
| 673 | ! |
lavpartable$op == "~~") |
| 674 | ! |
directed.idx <- which(lavpartable$free > 0L & |
| 675 | ! |
!duplicated(lavpartable$free) & # if ceq.simple |
| 676 | ! |
!lavpartable$op %in% c("~~", "~*~"))
|
| 677 | ! |
free.directed.idx <- unique(lavpartable$free[directed.idx]) |
| 678 | ! |
free.undirected.idx <- unique(lavpartable$free[undirected.idx]) |
| 679 | ||
| 680 |
# directed free parameters only |
|
| 681 | ! |
x <- lav_model_get_parameters(lavmodel, type = "free") |
| 682 | ! |
theta1 <- x[free.directed.idx] |
| 683 | ||
| 684 | ||
| 685 |
# stage 1: directed effects |
|
| 686 | ! |
for (b in seq_len(nblocks)) {
|
| 687 | ! |
neqs <- length(eqs[[b]]) |
| 688 | ! |
for (j in seq_len(neqs)) {
|
| 689 | ! |
eq <- eqs[[b]][[j]] |
| 690 | ||
| 691 | ! |
if (!is.null(eq$vcov) && nrow(eq$vcov) > 0L) {
|
| 692 | ! |
eq_vcov <- eq$vcov # always includes intercept |
| 693 | ! |
} else if (!is.null(eq$XX) && !is.null(eq$resvar)) {
|
| 694 |
# reconstruct using XX and resvar (less stable!) |
|
| 695 | ! |
eq_vcov <- solve(crossprod(eq$XX)) * eq$resvar # or resvar_df_res |
| 696 |
} |
|
| 697 | ||
| 698 |
# only keep free parameters |
|
| 699 | ! |
free.idx <- lavpartable$free[eq$pt] |
| 700 | ! |
if (length(eq$rhs) > 0L) {
|
| 701 | ! |
if (all(free.idx > 0L)) {
|
| 702 | ! |
vcov[free.idx, free.idx] <- eq_vcov[-1, -1] |
| 703 |
} else {
|
|
| 704 |
# remove non-free elements |
|
| 705 | ! |
zero.idx <- which(free.idx == 0L) |
| 706 | ! |
free.idx <- free.idx[-zero.idx] |
| 707 | ! |
if (length(free.idx) > 0L) {
|
| 708 | ! |
vcov[free.idx, free.idx] <- |
| 709 | ! |
eq_vcov[-1, -1][-zero.idx, -zero.idx, drop = FALSE] |
| 710 |
} |
|
| 711 |
} |
|
| 712 |
} |
|
| 713 | ! |
if (lavmodel@meanstructure) {
|
| 714 | ! |
free.int.idx <- lavpartable$free[eq$ptint] |
| 715 | ! |
if (free.int.idx > 0L) {
|
| 716 | ! |
vcov[free.int.idx, free.int.idx] <- eq_vcov[1, 1] |
| 717 |
} |
|
| 718 |
} |
|
| 719 |
} # neqs |
|
| 720 |
} # nblocks |
|
| 721 | ||
| 722 |
# stage 2: undirected effects (note: intercepts have no effect!) |
|
| 723 | ||
| 724 | ! |
if (iv.varcov.se) {
|
| 725 |
# part a: effect of theta1 |
|
| 726 | ! |
jac_a <- try(lav_func_jacobian_complex( |
| 727 | ! |
func = lav_sem_miiv_varcov, |
| 728 | ! |
x = theta1, impliedvec = FALSE, lavmodel = lavmodel, |
| 729 | ! |
lavpartable = lavpartable, lavh1 = lavh1, |
| 730 | ! |
free.directed.idx = free.directed.idx, |
| 731 | ! |
free.undirected.idx = free.undirected.idx, |
| 732 | ! |
iv.varcov.method = iv.varcov.method |
| 733 | ! |
), silent = TRUE) |
| 734 | ! |
if (inherits(jac_a, "try-error")) {
|
| 735 | ! |
jac_a <- numDeriv::jacobian( |
| 736 | ! |
func = lav_sem_miiv_varcov, |
| 737 | ! |
x = theta1, impliedvec = FALSE, lavmodel = lavmodel, |
| 738 | ! |
lavpartable = lavpartable, lavh1 = lavh1, |
| 739 | ! |
free.directed.idx = free.directed.idx, |
| 740 | ! |
free.undirected.idx = free.undirected.idx, |
| 741 | ! |
iv.varcov.method = iv.varcov.method |
| 742 |
) |
|
| 743 |
} |
|
| 744 | ! |
vcov_directed <- vcov[free.directed.idx, free.directed.idx, drop = FALSE] |
| 745 | ! |
vcov_a <- jac_a %*% vcov_directed %*% t(jac_a) |
| 746 | ||
| 747 |
# part b: effect of sample statistics |
|
| 748 |
# - get jacobian lav_sem_miiv_varcov wrt implied_vec |
|
| 749 |
# - get Gamma (NT or ADF) |
|
| 750 |
# - vcov_undirected_b <- jac_b %*% gamma_mat %*% t(jac_b) |
|
| 751 | ! |
vec <- lav_implied_to_vec( |
| 752 | ! |
implied = lavh1$implied, lavmodel = lavmodel, |
| 753 | ! |
drop.list = TRUE |
| 754 |
) |
|
| 755 | ! |
jac_b <- try(lav_func_jacobian_complex( |
| 756 | ! |
func = lav_sem_miiv_varcov, |
| 757 | ! |
x = vec, impliedvec = TRUE, lavmodel = lavmodel, |
| 758 | ! |
lavpartable = lavpartable, lavh1 = lavh1, |
| 759 | ! |
free.directed.idx = free.directed.idx, |
| 760 | ! |
free.undirected.idx = free.undirected.idx, |
| 761 | ! |
iv.varcov.method = iv.varcov.method |
| 762 | ! |
), silent = TRUE) |
| 763 | ! |
if (inherits(jac_b, "try-error")) {
|
| 764 | ! |
jac_b <- numDeriv::jacobian( |
| 765 | ! |
func = lav_sem_miiv_varcov, |
| 766 | ! |
x = vec, impliedvec = TRUE, lavmodel = lavmodel, |
| 767 | ! |
lavpartable = lavpartable, lavh1 = lavh1, |
| 768 | ! |
free.directed.idx = free.directed.idx, |
| 769 | ! |
free.undirected.idx = free.undirected.idx, |
| 770 | ! |
iv.varcov.method = iv.varcov.method |
| 771 |
) |
|
| 772 |
} |
|
| 773 | ||
| 774 |
# Gamma matrix per group |
|
| 775 | ! |
gamma_g <- vector("list", lavmodel@ngroups)
|
| 776 | ! |
for (g in seq_len(lavmodel@ngroups)) {
|
| 777 | ! |
if (!is.null(lavsamplestats@NACOV[[g]])) {
|
| 778 | ! |
gamma_g <- lavsamplestats@NACOV[[g]] |
| 779 |
} else {
|
|
| 780 | ! |
if (iv.varcov.modelbased) {
|
| 781 | ! |
mean_g <- lavimplied$mean[[g]] |
| 782 | ! |
cov_g <- lavimplied$cov[[g]] |
| 783 |
} else {
|
|
| 784 | ! |
mean_g <- lavh1$implied$mean[[g]] |
| 785 | ! |
cov_g <- lavh1$implied$cov[[g]] |
| 786 |
} |
|
| 787 |
# NT version (for now), model-based |
|
| 788 | ! |
gamma_g <- lav_samplestats_Gamma_NT( |
| 789 | ! |
COV = cov_g, |
| 790 | ! |
MEAN = mean_g, |
| 791 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 792 | ! |
fixed.x = lavmodel@fixed.x, |
| 793 | ! |
conditional.x = lavmodel@conditional.x, |
| 794 | ! |
meanstructure = lavmodel@meanstructure, |
| 795 | ! |
slopestructure = lavmodel@conditional.x |
| 796 |
) |
|
| 797 |
# divide by (group) sample size |
|
| 798 | ! |
gamma_g <- gamma_g / lavsamplestats@nobs[[g]] |
| 799 |
} |
|
| 800 |
} |
|
| 801 | ! |
gamma_big <- lav_matrix_bdiag(gamma_g) |
| 802 | ! |
vcov_b <- jac_b %*% gamma_big %*% t(jac_b) |
| 803 | ||
| 804 | ! |
vcov_ab <- vcov_a + vcov_b |
| 805 | ! |
vcov[free.undirected.idx, free.undirected.idx] <- vcov_ab |
| 806 |
} # iv.varcov.se = TRUE |
|
| 807 | ||
| 808 | ! |
vcov |
| 809 |
} |
| 1 |
lav_lavaan_step11_estoptim <- function(lavdata = NULL, # nolint |
|
| 2 |
lavmodel = NULL, |
|
| 3 |
lavcache = NULL, |
|
| 4 |
lavsamplestats = NULL, |
|
| 5 |
lavh1 = NULL, |
|
| 6 |
lavoptions = NULL, |
|
| 7 |
lavpartable = NULL) {
|
|
| 8 |
# # # # # # # # # # # # # # |
|
| 9 |
# # 11. est + lavoptim # # |
|
| 10 |
# # # # # # # # # # # # # # |
|
| 11 | ||
| 12 |
# if lavoptions$do.fit and lavoptions$estimator not "none" and |
|
| 13 |
# lavmodel$nx.free > 0 |
|
| 14 |
# select case lavoptions$optim.method |
|
| 15 |
# case "noniter" |
|
| 16 |
# try x <- lav_optim_noniter(...) |
|
| 17 |
# case "em" |
|
| 18 |
# if nlevels < 2L *** error *** |
|
| 19 |
# try x <- lav_mvnorm_cluster_em_h0(...) |
|
| 20 |
# case "gn" |
|
| 21 |
# try x <- lav_optim_gn(...) |
|
| 22 |
# case else |
|
| 23 |
# set 1 in lavoptions$optim.attempts is it wasn't specified |
|
| 24 |
# try x <- lav_model_estimate(...) |
|
| 25 |
# if not successfull and optim.attempts > 1L |
|
| 26 |
# try x <- lav_optim_estimate(...) with |
|
| 27 |
# options$optim.parscale = "standardized" |
|
| 28 |
# if not successfull and optim.attempts > 2L |
|
| 29 |
# try x <- lav_optim_estimate(...) with start = "simple" |
|
| 30 |
# if not successfull and optim.attempts > 3L |
|
| 31 |
# try x <- lav_optim_estimate(...) with |
|
| 32 |
# options$optim.parscale = "standardized" and start = "simple" |
|
| 33 |
# end select |
|
| 34 |
# if x not succesfully computed |
|
| 35 |
# ** warning ** |
|
| 36 |
# set starting values and appropriate attributes in x |
|
| 37 |
# in case of non-linear constraints: store final con.jac and |
|
| 38 |
# con.lambda in lavmodel |
|
| 39 |
# store parameters in lavmodel |
|
| 40 |
# store parameters in partable$est |
|
| 41 |
# else |
|
| 42 |
# initialize x and attributes (iterations, converged, warn.txt, |
|
| 43 |
# control, dx) of x |
|
| 44 |
# try fx <- lav_model_objective |
|
| 45 |
# if not successfull |
|
| 46 |
# fx = NA_real_ |
|
| 47 |
# attribute fx.group of fx = NA_real_ |
|
| 48 |
# store fx in attribute "fx" of x |
|
| 49 |
# set lavpartable$est to starting values |
|
| 50 |
# if lavoptions$optim.force.converged set attribute converged of x to TRUE |
|
| 51 |
# store optimization info in lavoptim |
|
| 52 | ||
| 53 | 140x |
x <- NULL |
| 54 | 140x |
if (lavoptions$do.fit && lavoptions$estimator != "none" && |
| 55 | 140x |
lavmodel@nx.free > 0L) {
|
| 56 | 138x |
if (lav_verbose()) {
|
| 57 | ! |
cat("lavoptim ... start:\n")
|
| 58 |
} |
|
| 59 | ||
| 60 |
# non-iterative methods (fabin, miiv, ...) |
|
| 61 | 138x |
if (lavoptions$optim.method == "noniter") {
|
| 62 | ! |
x <- try( |
| 63 | ! |
lav_optim_noniter( |
| 64 | ! |
lavmodel = lavmodel, |
| 65 | ! |
lavsamplestats = lavsamplestats, |
| 66 | ! |
lavh1 = lavh1, |
| 67 | ! |
lavdata = lavdata, |
| 68 | ! |
lavpartable = lavpartable, |
| 69 | ! |
lavoptions = lavoptions |
| 70 |
), |
|
| 71 | ! |
silent = FALSE |
| 72 |
) |
|
| 73 |
# EM for multilevel models |
|
| 74 | 138x |
} else if (lavoptions$optim.method == "em") {
|
| 75 |
# multilevel only for now |
|
| 76 | ! |
stopifnot(lavdata@nlevels > 1L) |
| 77 | ! |
x <- try( |
| 78 | ! |
lav_mvnorm_cluster_em_h0( |
| 79 | ! |
lavsamplestats = lavsamplestats, |
| 80 | ! |
lavdata = lavdata, |
| 81 | ! |
lavimplied = NULL, |
| 82 | ! |
lavpartable = lavpartable, |
| 83 | ! |
lavmodel = lavmodel, |
| 84 | ! |
lavoptions = lavoptions, |
| 85 | ! |
fx.tol = lavoptions$em.fx.tol, |
| 86 | ! |
dx.tol = lavoptions$em.dx.tol, |
| 87 | ! |
max.iter = lavoptions$em.iter.max |
| 88 |
), |
|
| 89 | ! |
silent = TRUE |
| 90 |
) |
|
| 91 |
# Gauss-Newton |
|
| 92 | 138x |
} else if (lavoptions$optim.method == "gn") {
|
| 93 |
# only tested for DLS (for now) |
|
| 94 | ! |
x <- try( |
| 95 | ! |
lav_optim_gn( |
| 96 | ! |
lavmodel = lavmodel, |
| 97 | ! |
lavsamplestats = lavsamplestats, |
| 98 | ! |
lavdata = lavdata, |
| 99 | ! |
lavpartable = lavpartable, |
| 100 | ! |
lavoptions = lavoptions |
| 101 |
), |
|
| 102 | ! |
silent = TRUE |
| 103 |
) |
|
| 104 | ||
| 105 |
# Quasi-Newton |
|
| 106 |
} else {
|
|
| 107 |
# for backwards compatibility (<0.6) |
|
| 108 | 138x |
if (is.null(lavoptions$optim.attempts)) {
|
| 109 | ! |
lavoptions$optim.attempts <- 1L |
| 110 |
} |
|
| 111 | ||
| 112 |
# try 1 |
|
| 113 | 138x |
if (lav_verbose()) {
|
| 114 | ! |
cat("attempt 1 -- default options\n")
|
| 115 |
} |
|
| 116 | 138x |
x <- try( |
| 117 | 138x |
lav_model_estimate( |
| 118 | 138x |
lavmodel = lavmodel, |
| 119 | 138x |
lavpartable = lavpartable, |
| 120 | 138x |
lavsamplestats = lavsamplestats, |
| 121 | 138x |
lavdata = lavdata, |
| 122 | 138x |
lavoptions = lavoptions, |
| 123 | 138x |
lavcache = lavcache |
| 124 |
), |
|
| 125 | 138x |
silent = TRUE |
| 126 |
) |
|
| 127 | ||
| 128 |
# try 2: optim.parscale = "standardize" (new in 0.6-7) |
|
| 129 | 138x |
if (lavoptions$optim.attempts > 1L && |
| 130 | 138x |
lavoptions$rstarts == 0L && |
| 131 | 138x |
(inherits(x, "try-error") || !attr(x, "converged"))) {
|
| 132 | 2x |
lavoptions2 <- lavoptions |
| 133 | 2x |
lavoptions2$optim.parscale <- "standardized" |
| 134 | 2x |
if (lav_verbose()) {
|
| 135 | ! |
str(x) |
| 136 | ! |
cat("attempt 2 -- optim.parscale = \"standardized\"\n")
|
| 137 |
} |
|
| 138 | 2x |
x <- try( |
| 139 | 2x |
lav_model_estimate( |
| 140 | 2x |
lavmodel = lavmodel, |
| 141 | 2x |
lavpartable = lavpartable, |
| 142 | 2x |
lavsamplestats = lavsamplestats, |
| 143 | 2x |
lavdata = lavdata, |
| 144 | 2x |
lavoptions = lavoptions2, |
| 145 | 2x |
lavcache = lavcache |
| 146 |
), |
|
| 147 | 2x |
silent = TRUE |
| 148 |
) |
|
| 149 |
} |
|
| 150 | ||
| 151 |
# try 3: start = "simple" |
|
| 152 | 138x |
if (lavoptions$optim.attempts > 2L && |
| 153 | 138x |
lavoptions$rstarts == 0L && |
| 154 | 138x |
(inherits(x, "try-error") || !attr(x, "converged"))) {
|
| 155 | 2x |
if (lav_verbose()) {
|
| 156 | ! |
str(x) |
| 157 | ! |
cat("attempt 3 -- start = \"simple\"\n")
|
| 158 |
} |
|
| 159 | 2x |
x <- try( |
| 160 | 2x |
lav_model_estimate( |
| 161 | 2x |
lavmodel = lavmodel, |
| 162 | 2x |
lavpartable = lavpartable, |
| 163 | 2x |
lavsamplestats = lavsamplestats, |
| 164 | 2x |
lavdata = lavdata, |
| 165 | 2x |
lavoptions = lavoptions, |
| 166 | 2x |
start = "simple", |
| 167 | 2x |
lavcache = lavcache |
| 168 |
), |
|
| 169 | 2x |
silent = TRUE |
| 170 |
) |
|
| 171 |
} |
|
| 172 | ||
| 173 |
# try 4: start = "simple" + optim.parscale = "standardize" |
|
| 174 | 138x |
if (lavoptions$optim.attempts > 3L && |
| 175 | 138x |
lavoptions$rstarts == 0L && |
| 176 | 138x |
(inherits(x, "try-error") || !attr(x, "converged"))) {
|
| 177 | ! |
lavoptions2 <- lavoptions |
| 178 | ! |
lavoptions2$optim.parscale <- "standardized" |
| 179 | ! |
if (lav_verbose()) {
|
| 180 | ! |
str(x) |
| 181 | ! |
cat( |
| 182 | ! |
"attempt 4 -- optim.parscale = \"standardized\" + ", |
| 183 | ! |
"start = \"simple\"\n" |
| 184 |
) |
|
| 185 |
} |
|
| 186 | ! |
x <- try( |
| 187 | ! |
lav_model_estimate( |
| 188 | ! |
lavmodel = lavmodel, |
| 189 | ! |
lavpartable = lavpartable, |
| 190 | ! |
lavsamplestats = lavsamplestats, |
| 191 | ! |
lavdata = lavdata, |
| 192 | ! |
lavoptions = lavoptions2, |
| 193 | ! |
start = "simple", |
| 194 | ! |
lavcache = lavcache |
| 195 |
), |
|
| 196 | ! |
silent = TRUE |
| 197 |
) |
|
| 198 |
} |
|
| 199 | ||
| 200 | ||
| 201 |
# random starts? -- new in 0.6-18 |
|
| 202 |
# run this even if we already have a converged solution |
|
| 203 |
# perhaps we find a better solution? |
|
| 204 | 138x |
if (lavoptions$rstarts > 0L) {
|
| 205 | ! |
x.rstarts <- vector("list", length = lavoptions$rstarts)
|
| 206 | ! |
if (lav_verbose()) {
|
| 207 | ! |
str(x) |
| 208 | ! |
cat("trying again with random starts (", lavoptions$rstarts,
|
| 209 | ! |
" in total):\n", |
| 210 | ! |
sep = "" |
| 211 |
) |
|
| 212 |
} |
|
| 213 | ! |
for (i in seq_len(lavoptions$rstarts)) {
|
| 214 | ! |
if (lav_verbose()) {
|
| 215 | ! |
cat("-- random start run: ", i, "\n")
|
| 216 |
} |
|
| 217 | ! |
x.rstarts[[i]] <- |
| 218 | ! |
try( |
| 219 | ! |
lav_model_estimate( |
| 220 | ! |
lavmodel = lavmodel, |
| 221 | ! |
lavpartable = lavpartable, |
| 222 | ! |
lavsamplestats = lavsamplestats, |
| 223 | ! |
lavdata = lavdata, |
| 224 | ! |
lavoptions = lavoptions, |
| 225 | ! |
start = "random", |
| 226 | ! |
lavcache = lavcache |
| 227 |
), |
|
| 228 | ! |
silent = TRUE |
| 229 |
) |
|
| 230 |
} |
|
| 231 | ||
| 232 |
# pick best solution (if any) |
|
| 233 | ! |
x.converged <- vector("list", length = 0L)
|
| 234 | ! |
fx.rstarts <- numeric(0L) |
| 235 | ! |
ok.flag <- sapply(x.rstarts, function(x) {
|
| 236 | ! |
if (inherits(x, "try-error")) {
|
| 237 | ! |
return(FALSE) |
| 238 |
} else {
|
|
| 239 | ! |
return(attr(x, "converged")) |
| 240 |
} |
|
| 241 |
}) |
|
| 242 | ! |
if (sum(ok.flag) > 0L) {
|
| 243 | ! |
x.converged <- x.rstarts[ok.flag] |
| 244 |
} |
|
| 245 | ! |
if (length(x.converged) > 0L) {
|
| 246 | ! |
fx.rstarts <- sapply(x.converged, "attr", "fx") |
| 247 | ! |
x.best <- x.converged[[which.min(fx.rstarts)]] |
| 248 | ! |
fx.best <- attr(x.best, "fx")[1] |
| 249 | ||
| 250 |
# if we did not find a converged solution, use x.best |
|
| 251 | ! |
if (inherits(x, "try-error") || !attr(x, "converged")) {
|
| 252 | ! |
x <- x.best |
| 253 | ||
| 254 | ||
| 255 |
# if we already had a converged solution, only replace |
|
| 256 |
# if fx.best is better than attr(x, "fx")[1] |
|
| 257 |
} else {
|
|
| 258 | ! |
if (fx.best < attr(x, "fx")[1]) {
|
| 259 | ! |
x <- x.best |
| 260 |
} |
|
| 261 |
} |
|
| 262 |
} |
|
| 263 | ||
| 264 | ! |
attr(x, "x.rstarts") <- x.rstarts |
| 265 |
} # random starts |
|
| 266 |
} |
|
| 267 | ||
| 268 |
# optimization failed with error |
|
| 269 | 138x |
if (inherits(x, "try-error")) {
|
| 270 | ! |
warn.txt <- gettext("Model estimation FAILED! Returning starting values.")
|
| 271 | ! |
x <- lav_model_get_parameters( |
| 272 | ! |
lavmodel = lavmodel, |
| 273 | ! |
type = "free" |
| 274 | ! |
) # starting values |
| 275 | ! |
attr(x, "iterations") <- 0L |
| 276 | ! |
attr(x, "converged") <- FALSE |
| 277 | ! |
attr(x, "warn.txt") <- warn.txt |
| 278 | ! |
attr(x, "control") <- lavoptions$control |
| 279 | ! |
attr(x, "dx") <- numeric(0L) |
| 280 | ! |
fx <- as.numeric(NA) |
| 281 | ! |
attr(fx, "fx.group") <- as.numeric(NA) |
| 282 | ! |
attr(x, "fx") <- fx |
| 283 |
} |
|
| 284 | ||
| 285 |
# if a warning was produced, say it here |
|
| 286 | 138x |
warn.txt <- attr(x, "warn.txt") |
| 287 | 138x |
if (!is.null(warn.txt) && nchar(warn.txt) > 0L) {
|
| 288 | ! |
lav_msg_warn(gettext(warn.txt)) |
| 289 |
} |
|
| 290 | ||
| 291 |
# in case of non-linear constraints: store final con.jac and con.lambda |
|
| 292 |
# in lavmodel |
|
| 293 | 138x |
if (!is.null(attr(x, "con.jac"))) {
|
| 294 | 65x |
lavmodel@con.jac <- attr(x, "con.jac") |
| 295 |
} |
|
| 296 | 138x |
if (!is.null(attr(x, "con.lambda"))) {
|
| 297 | 65x |
lavmodel@con.lambda <- attr(x, "con.lambda") |
| 298 |
} |
|
| 299 | ||
| 300 |
# store parameters in lavmodel |
|
| 301 | 138x |
lavmodel <- lav_model_set_parameters(lavmodel, x = as.numeric(x)) |
| 302 | ||
| 303 |
# store parameters in @ParTable$est |
|
| 304 | 138x |
lavpartable$est <- lav_model_get_parameters( |
| 305 | 138x |
lavmodel = lavmodel, |
| 306 | 138x |
type = "user", extra = TRUE |
| 307 |
) |
|
| 308 | ||
| 309 | 138x |
if (lav_verbose()) {
|
| 310 | ! |
cat("lavoptim ... done.\n")
|
| 311 |
} |
|
| 312 |
} else {
|
|
| 313 | 2x |
x <- numeric(0L) |
| 314 | 2x |
attr(x, "iterations") <- 0L |
| 315 | 2x |
attr(x, "converged") <- FALSE |
| 316 | 2x |
attr(x, "warn.txt") <- "" |
| 317 | 2x |
attr(x, "control") <- lavoptions$control |
| 318 | 2x |
attr(x, "dx") <- numeric(0L) |
| 319 | 2x |
fx <- try(lav_model_objective( |
| 320 | 2x |
lavmodel = lavmodel, |
| 321 | 2x |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 322 | 2x |
lavcache = lavcache |
| 323 | 2x |
), silent = TRUE) |
| 324 | 2x |
if (!inherits(fx, "try-error")) {
|
| 325 | 2x |
attr(x, "fx") <- fx |
| 326 |
} else {
|
|
| 327 | ! |
fx <- as.numeric(NA) |
| 328 | ! |
attr(fx, "fx.group") <- as.numeric(NA) |
| 329 | ! |
attr(x, "fx") <- fx |
| 330 |
} |
|
| 331 | ||
| 332 | 2x |
lavpartable$est <- lavpartable$start |
| 333 |
} |
|
| 334 | ||
| 335 |
# should we fake/force convergence? (eg. to enforce the |
|
| 336 |
# computation of a test statistic) |
|
| 337 | 140x |
if (lavoptions$optim.force.converged) {
|
| 338 | ! |
attr(x, "converged") <- TRUE |
| 339 |
} |
|
| 340 | ||
| 341 |
# store optimization info in lavoptim |
|
| 342 | 140x |
lavoptim <- list() |
| 343 | 140x |
x2 <- x |
| 344 | 140x |
attributes(x2) <- NULL |
| 345 | 140x |
lavoptim$x <- x2 |
| 346 | 140x |
lavoptim$dx <- attr(x, "dx") |
| 347 | 140x |
lavoptim$npar <- length(x) |
| 348 | 140x |
lavoptim$iterations <- attr(x, "iterations") |
| 349 | 140x |
lavoptim$converged <- attr(x, "converged") |
| 350 | 140x |
lavoptim$warn.txt <- attr(x, "warn.txt") |
| 351 | 140x |
lavoptim$parscale <- attr(x, "parscale") |
| 352 | 140x |
lavoptim$partrace <- attr(x, "partrace") |
| 353 | 140x |
fx.copy <- fx <- attr(x, "fx") |
| 354 | 140x |
attributes(fx) <- NULL |
| 355 | 140x |
lavoptim$fx <- fx |
| 356 | 140x |
lavoptim$fx.group <- attr(fx.copy, "fx.group") |
| 357 | 140x |
if (!is.null(attr(fx.copy, "logl.group"))) {
|
| 358 | ! |
lavoptim$logl.group <- attr(fx.copy, "logl.group") |
| 359 | ! |
lavoptim$logl <- sum(lavoptim$logl.group) |
| 360 |
} else {
|
|
| 361 | 140x |
lavoptim$logl.group <- as.numeric(NA) |
| 362 | 140x |
lavoptim$logl <- as.numeric(NA) |
| 363 |
} |
|
| 364 | 140x |
lavoptim$control <- attr(x, "control") |
| 365 | 140x |
if (!is.null(attr(x, "x.rstarts"))) {
|
| 366 | ! |
lavoptim$x.rstarts <- attr(x, "x.rstarts") |
| 367 |
} |
|
| 368 | ||
| 369 | 140x |
lavpartable <- lav_partable_set_cache(lavpartable, force = TRUE) |
| 370 | 140x |
list( |
| 371 | 140x |
lavoptim = lavoptim, lavmodel = lavmodel, lavpartable = lavpartable, |
| 372 | 140x |
x = x |
| 373 |
) |
|
| 374 |
} |
| 1 |
# get missing patterns |
|
| 2 |
lav_data_missing_patterns <- function(Y, sort.freq = FALSE, coverage = FALSE, |
|
| 3 |
Lp = NULL) {
|
|
| 4 |
# handle two-level data |
|
| 5 | 10x |
if (!is.null(Lp)) {
|
| 6 | ! |
Y.orig <- Y |
| 7 | ! |
Z <- NULL |
| 8 | ! |
if (length(Lp$between.idx[[2]]) > 0L) {
|
| 9 | ! |
Y <- Y[, -Lp$between.idx[[2]], drop = FALSE] |
| 10 | ! |
z.idx <- which(!duplicated(Lp$cluster.idx[[2]])) |
| 11 | ! |
Z <- Y.orig[z.idx, Lp$between.idx[[2]], drop = FALSE] |
| 12 |
} |
|
| 13 |
} |
|
| 14 | ||
| 15 |
# construct TRUE/FALSE matrix: TRUE if value is observed |
|
| 16 | 10x |
OBS <- !is.na(Y) |
| 17 | ||
| 18 |
# empty cases |
|
| 19 | 10x |
empty.idx <- which(rowSums(OBS) == 0L) |
| 20 | ||
| 21 |
# pattern of observed values per observation |
|
| 22 | 10x |
case.id <- apply(1L * OBS, 1L, paste, collapse = "") |
| 23 | ||
| 24 |
# remove empty patterns |
|
| 25 | 10x |
if (length(empty.idx)) {
|
| 26 | ! |
case.id.nonempty <- case.id[-empty.idx] |
| 27 |
} else {
|
|
| 28 | 10x |
case.id.nonempty <- case.id |
| 29 |
} |
|
| 30 | ||
| 31 |
# sort non-empty patterns (from high occurence to low occurence) |
|
| 32 | 10x |
if (sort.freq) {
|
| 33 | 10x |
TABLE <- sort(table(case.id.nonempty), decreasing = TRUE) |
| 34 |
} else {
|
|
| 35 | ! |
TABLE <- table(case.id.nonempty) |
| 36 |
} |
|
| 37 | ||
| 38 |
# unique pattern ids |
|
| 39 | 10x |
pat.id <- names(TABLE) |
| 40 | ||
| 41 |
# number of patterns |
|
| 42 | 10x |
pat.npatterns <- length(pat.id) |
| 43 | ||
| 44 |
# case idx per pattern |
|
| 45 | 10x |
pat.case.idx <- lapply( |
| 46 | 10x |
seq_len(pat.npatterns), |
| 47 | 10x |
function(p) which(case.id == pat.id[p]) |
| 48 |
) |
|
| 49 | ||
| 50 |
# unique pattern frequencies |
|
| 51 | 10x |
pat.freq <- as.integer(TABLE) |
| 52 | ||
| 53 |
# first occurrence of each pattern |
|
| 54 | 10x |
pat.first <- match(pat.id, case.id) |
| 55 | ||
| 56 |
# TRUE/FALSE for each pattern |
|
| 57 | 10x |
pat.obs <- OBS[pat.first, , drop = FALSE] # observed per pattern |
| 58 | ||
| 59 | 10x |
Mp <- list( |
| 60 | 10x |
npatterns = pat.npatterns, id = pat.id, freq = pat.freq, |
| 61 | 10x |
case.idx = pat.case.idx, pat = pat.obs, empty.idx = empty.idx, |
| 62 | 10x |
nel = sum(OBS) |
| 63 |
) |
|
| 64 | ||
| 65 | 10x |
if (coverage) {
|
| 66 |
# FIXME: if we have empty cases, include them in N? |
|
| 67 |
# no for now |
|
| 68 | 10x |
Mp$coverage <- crossprod(OBS) / sum(pat.freq) |
| 69 |
# Mp$coverage <- crossprod(OBS) / NROW(Y) |
|
| 70 |
} |
|
| 71 | ||
| 72 |
# additional info in we have two-level data |
|
| 73 | 10x |
if (!is.null(Lp)) {
|
| 74 | ! |
Mp$j.idx <- lapply( |
| 75 | ! |
seq_len(pat.npatterns), |
| 76 | ! |
function(p) Lp$cluster.idx[[2]][Mp$case.idx[[p]]] |
| 77 |
) |
|
| 78 | ! |
Mp$j1.idx <- lapply( |
| 79 | ! |
seq_len(pat.npatterns), |
| 80 | ! |
function(p) sort(unique.default(Mp$j.idx[[p]])) # new in 0.6-19: sort!! |
| 81 |
# because table/tabulate |
|
| 82 |
# also sorts... |
|
| 83 |
) |
|
| 84 | ! |
Mp$j.freq <- lapply( |
| 85 | ! |
seq_len(pat.npatterns), |
| 86 | ! |
function(p) as.integer(unname(table(sort(Mp$j.idx[[p]])))) # sort not needed? |
| 87 |
) |
|
| 88 | ||
| 89 |
# between-level patterns |
|
| 90 | ! |
if (!is.null(Z)) {
|
| 91 | ! |
Mp$Zp <- lav_data_missing_patterns(Z, |
| 92 | ! |
sort.freq = FALSE, |
| 93 | ! |
coverage = FALSE, Lp = NULL |
| 94 |
) |
|
| 95 |
} |
|
| 96 |
} |
|
| 97 | ||
| 98 | 10x |
Mp |
| 99 |
} |
|
| 100 | ||
| 101 |
# get response patterns (ignore empty cases!) |
|
| 102 |
lav_data_resp_patterns <- function(Y) {
|
|
| 103 |
# construct TRUE/FALSE matrix: TRUE if value is observed |
|
| 104 | 2x |
OBS <- !is.na(Y) |
| 105 | ||
| 106 |
# empty cases |
|
| 107 | 2x |
empty.idx <- which(rowSums(OBS) == 0L) |
| 108 | ||
| 109 |
# removeYempty cases |
|
| 110 | 2x |
if (length(empty.idx) > 0L) {
|
| 111 | ! |
Y <- Y[-empty.idx, , drop = FALSE] |
| 112 |
} |
|
| 113 | ||
| 114 | 2x |
ntotal <- nrow(Y) |
| 115 | 2x |
nvar <- ncol(Y) |
| 116 | ||
| 117 |
# identify, label and sort response patterns |
|
| 118 | 2x |
id <- apply(Y, MARGIN = 1, paste, collapse = "") |
| 119 | ||
| 120 |
# sort patterns (from high occurence to low occurence) |
|
| 121 | 2x |
TABLE <- sort(table(id), decreasing = TRUE) |
| 122 | 2x |
order <- names(TABLE) |
| 123 | 2x |
npatterns <- length(TABLE) |
| 124 | 2x |
pat <- Y[match(order, id), , drop = FALSE] |
| 125 | 2x |
row.names(pat) <- as.character(TABLE) |
| 126 | ||
| 127 |
# handle NA? |
|
| 128 | 2x |
Y[is.na(Y)] <- -9 |
| 129 | 2x |
total.patterns <- prod(apply(Y, 2, function(x) length(unique(x)))) |
| 130 | 2x |
empty.patterns <- total.patterns - npatterns |
| 131 |
# return a list |
|
| 132 |
# out <- list(nobs=ntotal, nvar=nvar, |
|
| 133 |
# id=id, npatterns=npatterns, |
|
| 134 |
# order=order, pat=pat) |
|
| 135 | ||
| 136 |
# only return pat |
|
| 137 | 2x |
out <- list( |
| 138 | 2x |
npatterns = npatterns, pat = pat, total.patterns = total.patterns, |
| 139 | 2x |
empty.patterns = empty.patterns |
| 140 |
) |
|
| 141 | ||
| 142 | 2x |
out |
| 143 |
} |
|
| 144 | ||
| 145 |
# get cluster information |
|
| 146 |
# - cluster can be a vector! |
|
| 147 |
# - clus can contain multiple columns! |
|
| 148 |
lav_data_cluster_patterns <- function(Y = NULL, |
|
| 149 |
clus = NULL, # the cluster ids |
|
| 150 |
cluster = NULL, # the cluster 'names' |
|
| 151 |
multilevel = FALSE, |
|
| 152 |
ov.names = NULL, |
|
| 153 |
ov.names.x = NULL, |
|
| 154 |
ov.names.l = NULL) {
|
|
| 155 |
# how many levels? |
|
| 156 | 4x |
nlevels <- length(cluster) + 1L |
| 157 | ||
| 158 |
# did we get any data (or is this just for lav_data_simulate_old) |
|
| 159 | 4x |
if (!is.null(Y) && !is.null(clus)) {
|
| 160 | 4x |
haveData <- TRUE |
| 161 |
} else {
|
|
| 162 | ! |
haveData <- FALSE |
| 163 |
} |
|
| 164 | ||
| 165 |
# check clus |
|
| 166 | 4x |
if (haveData) {
|
| 167 | 4x |
stopifnot(ncol(clus) == (nlevels - 1L), nrow(Y) == nrow(clus)) |
| 168 |
} |
|
| 169 | ||
| 170 | 4x |
cluster.size <- vector("list", length = nlevels)
|
| 171 | 4x |
cluster.id <- vector("list", length = nlevels)
|
| 172 | 4x |
cluster.idx <- vector("list", length = nlevels)
|
| 173 | 4x |
nclusters <- vector("list", length = nlevels)
|
| 174 | 4x |
cluster.sizes <- vector("list", length = nlevels)
|
| 175 | 4x |
ncluster.sizes <- vector("list", length = nlevels)
|
| 176 | 4x |
cluster.size.ns <- vector("list", length = nlevels)
|
| 177 | ||
| 178 | 4x |
ov.idx <- vector("list", length = nlevels)
|
| 179 | 4x |
ov.x.idx <- vector("list", length = nlevels)
|
| 180 | 4x |
ov.y.idx <- vector("list", length = nlevels)
|
| 181 | 4x |
both.idx <- vector("list", length = nlevels)
|
| 182 | 4x |
within.idx <- vector("list", length = nlevels)
|
| 183 | 4x |
within.x.idx <- vector("list", length = nlevels)
|
| 184 | 4x |
within.y.idx <- vector("list", length = nlevels)
|
| 185 | 4x |
between.idx <- vector("list", length = nlevels)
|
| 186 | 4x |
between.x.idx <- vector("list", length = nlevels)
|
| 187 | 4x |
between.y.idx <- vector("list", length = nlevels)
|
| 188 | 4x |
both.names <- vector("list", length = nlevels)
|
| 189 | 4x |
within.names <- vector("list", length = nlevels)
|
| 190 | 4x |
within.x.names <- vector("list", length = nlevels)
|
| 191 | 4x |
within.y.names <- vector("list", length = nlevels)
|
| 192 | 4x |
between.names <- vector("list", length = nlevels)
|
| 193 | 4x |
between.x.names <- vector("list", length = nlevels)
|
| 194 | 4x |
between.y.names <- vector("list", length = nlevels)
|
| 195 | ||
| 196 |
# level-1 is special |
|
| 197 | 4x |
if (haveData) {
|
| 198 | 4x |
nclusters[[1]] <- NROW(Y) |
| 199 |
} |
|
| 200 | ||
| 201 |
# higher levels: |
|
| 202 | 4x |
for (l in 2:nlevels) {
|
| 203 | 4x |
if (haveData) {
|
| 204 | 4x |
CLUS <- clus[, (l - 1L)] |
| 205 | ||
| 206 |
# cluster.id: original cluster identifier |
|
| 207 | 4x |
cluster.id[[l]] <- unique(CLUS) |
| 208 | ||
| 209 |
# cluster.idx: internal cluster idx (always an integer from 1 to J |
|
| 210 |
# for every obervation; |
|
| 211 |
# the first cluster id we observe is '1', the second '2', etc...) |
|
| 212 | 4x |
cluster.idx[[l]] <- match(CLUS, cluster.id[[l]]) |
| 213 | ||
| 214 | 4x |
cluster.size[[l]] <- tabulate(cluster.idx[[l]]) |
| 215 | 4x |
nclusters[[l]] <- length(cluster.size[[l]]) |
| 216 |
# check if we have more observations than clusters |
|
| 217 | 4x |
if (nclusters[[1]] == nclusters[[l]]) {
|
| 218 | ! |
lav_msg_stop(gettext("every cluster contains only one observation."))
|
| 219 |
} |
|
| 220 | 4x |
mean.cluster.size <- mean(cluster.size[[l]]) |
| 221 | 4x |
if (mean.cluster.size < 1.5) {
|
| 222 | ! |
lav_msg_warn(gettextf( |
| 223 | ! |
"mean cluster size is %s. This means that many clusters only |
| 224 | ! |
contain a single observation.", mean.cluster.size)) |
| 225 |
} |
|
| 226 | 4x |
cluster.sizes[[l]] <- unique(cluster.size[[l]]) |
| 227 | 4x |
ncluster.sizes[[l]] <- length(cluster.sizes[[l]]) |
| 228 | 4x |
cluster.size.ns[[l]] <- as.integer(table(factor(cluster.size[[l]], |
| 229 | 4x |
levels = as.character(cluster.sizes[[l]]) |
| 230 |
))) |
|
| 231 |
} else {
|
|
| 232 | ! |
cluster.id[[l]] <- integer(0L) |
| 233 | ! |
cluster.idx[[l]] <- integer(0L) |
| 234 | ! |
cluster.size[[l]] <- integer(0L) |
| 235 | ! |
nclusters[[l]] <- integer(0L) |
| 236 | ! |
cluster.sizes[[l]] <- integer(0L) |
| 237 | ! |
ncluster.sizes[[l]] <- integer(0L) |
| 238 | ! |
cluster.size.ns[[l]] <- integer(0L) |
| 239 |
} |
|
| 240 |
} |
|
| 241 | ||
| 242 |
# for all levels: |
|
| 243 | 4x |
if (multilevel) {
|
| 244 | 4x |
for (l in 1:nlevels) {
|
| 245 |
# index of ov.names for this level |
|
| 246 | 8x |
ov.idx[[l]] <- match(ov.names.l[[l]], ov.names) |
| 247 | ||
| 248 |
# new in 0.6-12: always preserve the order of ov.idx[[l]] |
|
| 249 | 8x |
idx <- which(ov.names %in% ov.names.l[[1]] & |
| 250 | 8x |
ov.names %in% ov.names.l[[2]]) |
| 251 | 8x |
both.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 252 | ||
| 253 | 8x |
idx <- which(ov.names %in% ov.names.l[[1]] & |
| 254 | 8x |
!ov.names %in% ov.names.l[[2]]) |
| 255 | 8x |
within.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 256 |
# backwards compatibility: also store in within.idx[[2]] |
|
| 257 | 8x |
if (l == 2) {
|
| 258 | 4x |
within.idx[[l]] <- within.idx[[1]] |
| 259 |
} |
|
| 260 | ||
| 261 | 8x |
idx <- which(!ov.names %in% ov.names.l[[1]] & |
| 262 | 8x |
ov.names %in% ov.names.l[[2]]) |
| 263 | 8x |
between.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 264 | ||
| 265 |
# names |
|
| 266 |
# both.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] & |
|
| 267 |
# ov.names %in% ov.names.l[[2]] ] |
|
| 268 |
# within.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] & |
|
| 269 |
# !ov.names %in% ov.names.l[[2]] ] |
|
| 270 |
# between.names[[l]] <- ov.names[!ov.names %in% ov.names.l[[1]] & |
|
| 271 |
# ov.names %in% ov.names.l[[2]] ] |
|
| 272 | 8x |
both.names[[l]] <- ov.names[both.idx[[l]]] |
| 273 | 8x |
within.names[[l]] <- ov.names[within.idx[[l]]] |
| 274 | 8x |
between.names[[l]] <- ov.names[between.idx[[l]]] |
| 275 |
} |
|
| 276 |
} |
|
| 277 | ||
| 278 |
# fixed.x wrt variable index |
|
| 279 | 4x |
if (multilevel && length(ov.names.x) > 0L) {
|
| 280 | ! |
for (l in 1:nlevels) {
|
| 281 |
# some ov.names.x could be 'splitted', and end up in both.names |
|
| 282 |
# they should NOT be part ov.x.idx (as they become latent variables) |
|
| 283 | ! |
idx <- which(ov.names %in% ov.names.x & |
| 284 | ! |
ov.names %in% ov.names.l[[l]] & |
| 285 | ! |
!ov.names %in% unlist(both.names)) |
| 286 | ! |
ov.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 287 | ||
| 288 |
# not any longer, we split them, but still treat them as 'fixed' |
|
| 289 |
# ov.x.idx[[l]] <- which( ov.names %in% ov.names.x & |
|
| 290 |
# ov.names %in% ov.names.l[[l]] ) |
|
| 291 | ||
| 292 |
# if some ov.names.x have been 'splitted', and end up in both.names, |
|
| 293 |
# they should become part of ov.y.idx (despite being exogenous) |
|
| 294 |
# as they are now latent variables |
|
| 295 | ! |
idx <- which(ov.names %in% ov.names.l[[l]] & |
| 296 | ! |
!ov.names %in% ov.names.x[!ov.names.x %in% unlist(both.names)]) |
| 297 | ! |
ov.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 298 | ||
| 299 |
# not any longer, ov.x stays ov.x (even if we split) |
|
| 300 |
# ov.y.idx[[l]] <- which( ov.names %in% ov.names.l[[l]] & |
|
| 301 |
# !ov.names %in% ov.names.x ) |
|
| 302 | ||
| 303 | ||
| 304 |
# if(l == 1L) {
|
|
| 305 |
# next |
|
| 306 |
# } |
|
| 307 |
# below, we only fill in the [[2]] element (and higher) |
|
| 308 | ||
| 309 | ! |
idx <- which(ov.names %in% ov.names.l[[1]] & |
| 310 | ! |
!ov.names %in% ov.names.l[[2]] & |
| 311 | ! |
ov.names %in% ov.names.x) |
| 312 | ! |
within.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 313 |
# backwards compatibility: also store in within.x.idx[[2]] |
|
| 314 | ! |
if (l == 2) {
|
| 315 | ! |
within.x.idx[[l]] <- within.x.idx[[1]] |
| 316 |
} |
|
| 317 | ||
| 318 | ! |
idx <- which(ov.names %in% ov.names.l[[1]] & |
| 319 | ! |
!ov.names %in% ov.names.l[[2]] & |
| 320 | ! |
!ov.names %in% ov.names.x) |
| 321 | ! |
within.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 322 |
# backwards compatibility: also store in within.y.idx[[2]] |
|
| 323 | ! |
if (l == 2) {
|
| 324 | ! |
within.y.idx[[l]] <- within.y.idx[[1]] |
| 325 |
} |
|
| 326 | ||
| 327 | ! |
idx <- which(!ov.names %in% ov.names.l[[1]] & |
| 328 | ! |
ov.names %in% ov.names.l[[2]] & |
| 329 | ! |
ov.names %in% ov.names.x) |
| 330 | ! |
between.x.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 331 | ||
| 332 | ! |
idx <- which(!ov.names %in% ov.names.l[[1]] & |
| 333 | ! |
ov.names %in% ov.names.l[[2]] & |
| 334 | ! |
!ov.names %in% ov.names.x) |
| 335 | ! |
between.y.idx[[l]] <- ov.idx[[l]][ov.idx[[l]] %in% idx] |
| 336 | ||
| 337 |
# within.x.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] & |
|
| 338 |
# ov.names %in% ov.names.x & |
|
| 339 |
# !ov.names %in% ov.names.l[[2]] ] |
|
| 340 |
# within.y.names[[l]] <- ov.names[ ov.names %in% ov.names.l[[1]] & |
|
| 341 |
# !ov.names %in% ov.names.x & |
|
| 342 |
# !ov.names %in% ov.names.l[[2]] ] |
|
| 343 |
# between.x.names[[l]] <- ov.names[!ov.names %in% ov.names.l[[1]] & |
|
| 344 |
# ov.names %in% ov.names.x & |
|
| 345 |
# ov.names %in% ov.names.l[[2]] ] |
|
| 346 |
# between.y.names[[l]] <- ov.names[!ov.names %in% ov.names.l[[1]] & |
|
| 347 |
# !ov.names %in% ov.names.x & |
|
| 348 |
# ov.names %in% ov.names.l[[2]] ] |
|
| 349 | ! |
within.x.names[[l]] <- ov.names[within.x.idx[[l]]] |
| 350 | ! |
within.y.names[[l]] <- ov.names[within.y.idx[[l]]] |
| 351 | ! |
between.x.names[[l]] <- ov.names[between.x.idx[[l]]] |
| 352 | ! |
between.y.names[[l]] <- ov.names[between.y.idx[[l]]] |
| 353 |
} |
|
| 354 |
} else {
|
|
| 355 | 4x |
ov.y.idx <- ov.idx |
| 356 |
} |
|
| 357 | ||
| 358 | 4x |
out <- list( |
| 359 | 4x |
ov.names = ov.names, ov.names.x = ov.names.x, # for this group |
| 360 | 4x |
cluster = cluster, # clus = clus, |
| 361 |
# per level |
|
| 362 | 4x |
nclusters = nclusters, |
| 363 | 4x |
cluster.size = cluster.size, cluster.id = cluster.id, |
| 364 | 4x |
cluster.idx = cluster.idx, cluster.sizes = cluster.sizes, |
| 365 | 4x |
ncluster.sizes = ncluster.sizes, |
| 366 | 4x |
cluster.size.ns = cluster.size.ns, |
| 367 | 4x |
ov.idx = ov.idx, ov.x.idx = ov.x.idx, ov.y.idx = ov.y.idx, |
| 368 | 4x |
both.idx = both.idx, within.idx = within.idx, |
| 369 | 4x |
within.x.idx = within.x.idx, within.y.idx = within.y.idx, |
| 370 | 4x |
between.idx = between.idx, |
| 371 | 4x |
between.x.idx = between.x.idx, between.y.idx = between.y.idx, |
| 372 | 4x |
both.names = both.names, within.names = within.names, |
| 373 | 4x |
within.x.names = within.x.names, |
| 374 | 4x |
within.y.names = within.y.names, |
| 375 | 4x |
between.names = between.names, |
| 376 | 4x |
between.x.names = between.x.names, |
| 377 | 4x |
between.y.names = between.y.names |
| 378 |
) |
|
| 379 | ||
| 380 | 4x |
out |
| 381 |
} |
| 1 |
lav_lavaan_step15_baseline <- function(lavoptions = NULL, |
|
| 2 |
lavsamplestats = NULL, |
|
| 3 |
lavdata = NULL, |
|
| 4 |
lavcache = NULL, |
|
| 5 |
lavh1 = NULL, |
|
| 6 |
lavpartable = NULL) {
|
|
| 7 |
# # # # # # # # # # # |
|
| 8 |
# # 15. baseline # # (since 0.6-5) |
|
| 9 |
# # # # # # # # # # # |
|
| 10 | ||
| 11 |
# if options$do.fit and options$test not "none" and options$baseline = TRUE |
|
| 12 |
# try fit.indep <- lav_object_independence(...) |
|
| 13 |
# if not succesfull or not converged |
|
| 14 |
# ** warning ** |
|
| 15 |
# lavbaseline < list() |
|
| 16 |
# else |
|
| 17 |
# lavbaseline <- list with partable and test of fit.indep |
|
| 18 | 140x |
lavbaseline <- list() |
| 19 | 140x |
if (lavoptions$do.fit && |
| 20 | 140x |
!("none" %in% lavoptions$test) &&
|
| 21 | 140x |
is.logical(lavoptions$baseline) && lavoptions$baseline) {
|
| 22 | 45x |
if (lav_verbose()) {
|
| 23 | ! |
cat("lavbaseline ...")
|
| 24 |
} |
|
| 25 | 45x |
current.verbose <- lav_verbose() |
| 26 | 45x |
lav_verbose(FALSE) |
| 27 | 45x |
fit.indep <- try(lav_object_independence( |
| 28 | 45x |
object = NULL, |
| 29 | 45x |
lavsamplestats = lavsamplestats, |
| 30 | 45x |
lavdata = lavdata, |
| 31 | 45x |
lavcache = lavcache, |
| 32 | 45x |
lavoptions = lavoptions, |
| 33 | 45x |
lavpartable = lavpartable, |
| 34 | 45x |
lavh1 = lavh1 |
| 35 | 45x |
), silent = TRUE) |
| 36 | 45x |
lav_verbose(current.verbose) |
| 37 | 45x |
if (inherits(fit.indep, "try-error") || !fit.indep@optim$converged) {
|
| 38 | ! |
lav_msg_warn(gettext("estimation of the baseline model failed."))
|
| 39 | ! |
lavbaseline <- list() |
| 40 | ! |
if (lav_verbose()) {
|
| 41 | ! |
cat(" FAILED.\n")
|
| 42 |
} |
|
| 43 |
} else {
|
|
| 44 |
# store relevant information |
|
| 45 | 45x |
lavbaseline <- list( |
| 46 | 45x |
partable = fit.indep@ParTable, |
| 47 | 45x |
test = fit.indep@test |
| 48 |
) |
|
| 49 | 45x |
if (lav_verbose()) {
|
| 50 | ! |
cat(" done.\n")
|
| 51 |
} |
|
| 52 |
} |
|
| 53 |
} |
|
| 54 | ||
| 55 | 140x |
lavbaseline |
| 56 |
} |
| 1 |
# Gauss-Newton style optimization |
|
| 2 |
# |
|
| 3 |
# Initial version needed for DLS - model based |
|
| 4 |
# YR - 19 Jan 2021 |
|
| 5 |
# |
|
| 6 |
# TODo: |
|
| 7 |
# - what to do if the function value goes up? |
|
| 8 |
# - handle general (nonlinear) equality constraints |
|
| 9 |
# - handle general (nonlinear) inequality constraints |
|
| 10 |
# - better approach for simple bounds |
|
| 11 |
# ... |
|
| 12 | ||
| 13 |
# YR - 04 Nov 2023: add huber = TRUE option to get 'outlier-robust' estimates |
|
| 14 |
# (see Yuan and Zhong 2008, where they call this IRLS_r) |
|
| 15 | ||
| 16 | ||
| 17 |
# objective function, plus 'extra' information |
|
| 18 |
# needed for a Gauss Newton step |
|
| 19 |
lav_objective_GN <- function(x, lavsamplestats = NULL, lavmodel = NULL, |
|
| 20 |
lavoptions = NULL, lavdata = NULL, |
|
| 21 |
extra = FALSE, lambda = NULL) {
|
|
| 22 |
# evaluate objective function |
|
| 23 | ! |
lavmodel <- lav_model_set_parameters(lavmodel = lavmodel, x = x) |
| 24 | ! |
obj <- lav_model_objective( |
| 25 | ! |
lavmodel = lavmodel, lavdata = lavdata, |
| 26 | ! |
lavsamplestats = lavsamplestats |
| 27 |
) |
|
| 28 | ! |
attributes(obj) <- NULL |
| 29 | ||
| 30 |
# monitoring obj only |
|
| 31 | ! |
if (!extra) {
|
| 32 |
# handle linear equality constraints |
|
| 33 | ! |
if (lavmodel@eq.constraints) {
|
| 34 | ! |
hx <- lavmodel@ceq.function(x) |
| 35 | ! |
obj <- obj + max(abs(lambda)) * sum(abs(hx)) |
| 36 |
} |
|
| 37 | ! |
return(list(obj = obj, U.invQ = NULL, lambda = lambda)) |
| 38 |
} |
|
| 39 | ||
| 40 |
# model implied statistics |
|
| 41 | ! |
lavimplied <- lav_model_implied(lavmodel = lavmodel) |
| 42 | ! |
wls.est <- lav_model_wls_est(lavmodel = lavmodel, lavimplied = lavimplied) |
| 43 | ||
| 44 |
# observed statistics |
|
| 45 | ! |
wls.obs <- lavsamplestats@WLS.obs |
| 46 | ||
| 47 |
# always use expected information |
|
| 48 | ! |
A1 <- lav_model_h1_information_expected( |
| 49 | ! |
lavobject = NULL, |
| 50 | ! |
lavmodel = lavmodel, |
| 51 | ! |
lavsamplestats = lavsamplestats, |
| 52 | ! |
lavdata = lavdata, |
| 53 | ! |
lavoptions = lavoptions, |
| 54 | ! |
lavimplied = lavimplied, |
| 55 | ! |
lavh1 = NULL, |
| 56 | ! |
lavcache = NULL |
| 57 |
) |
|
| 58 |
# Delta |
|
| 59 | ! |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 60 | ||
| 61 |
# first group |
|
| 62 | ! |
g <- 1L |
| 63 | ! |
if (lavmodel@estimator == "DWLS") {
|
| 64 | ! |
PRE.g <- t(Delta[[g]] * A1[[g]]) |
| 65 |
} else {
|
|
| 66 | ! |
PRE.g <- t(Delta[[g]]) %*% A1[[g]] |
| 67 |
} |
|
| 68 | ! |
Q.g <- PRE.g %*% (wls.obs[[g]] - wls.est[[g]]) |
| 69 | ! |
U.g <- PRE.g %*% Delta[[g]] |
| 70 | ||
| 71 |
# additional groups (if any) |
|
| 72 | ! |
if (lavsamplestats@ngroups > 1L) {
|
| 73 | ! |
fg <- lavsamplestats@nobs[[1]] / lavsamplestats@ntotal |
| 74 | ! |
Q <- fg * Q.g |
| 75 | ! |
U <- fg * U.g |
| 76 | ||
| 77 | ! |
for (g in 2:lavsamplestats@ngroups) {
|
| 78 | ! |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 79 | ! |
if (lavmodel@estimator == "DWLS") {
|
| 80 | ! |
PRE.g <- t(Delta[[g]] * A1[[g]]) |
| 81 |
} else {
|
|
| 82 | ! |
PRE.g <- t(Delta[[g]]) %*% A1[[g]] |
| 83 |
} |
|
| 84 | ! |
Q.g <- PRE.g %*% (wls.obs[[g]] - wls.est[[g]]) |
| 85 | ! |
U.g <- PRE.g %*% Delta[[g]] |
| 86 | ||
| 87 | ! |
Q <- Q + fg * Q.g |
| 88 | ! |
U <- U + fg * U.g |
| 89 |
} |
|
| 90 |
} else {
|
|
| 91 | ! |
Q <- Q.g |
| 92 | ! |
U <- U.g |
| 93 |
} |
|
| 94 | ||
| 95 |
# handle equality constraints |
|
| 96 |
# this can be made more efficient; see Jamshidian & Bentler 1993 |
|
| 97 |
# where instead of inverting a p+r matrix, they use a p-r matrix |
|
| 98 |
# (if the eq constraints are linear) |
|
| 99 | ! |
if (lavmodel@eq.constraints) {
|
| 100 | ! |
hx <- lavmodel@ceq.function(x) |
| 101 | ! |
npar <- nrow(U) |
| 102 | ! |
H <- lavmodel@con.jac |
| 103 | ! |
U <- U + crossprod(H) |
| 104 | ! |
U <- rbind( |
| 105 | ! |
cbind(U, t(H)), |
| 106 | ! |
cbind(H, matrix(0, nrow(H), nrow(H))) |
| 107 |
) |
|
| 108 | ! |
Q <- rbind(Q, matrix(-hx, nrow(H), 1)) |
| 109 |
} |
|
| 110 | ||
| 111 |
# compute step |
|
| 112 |
# note, we could use U + k*I for a given scalar 'k' (Levenberg, 1944) |
|
| 113 |
# or U + k*(diag(U) (Marquardt, 1963) |
|
| 114 | ! |
U.invQ <- drop(solve(U, Q)) |
| 115 | ! |
if (lavmodel@eq.constraints) {
|
| 116 |
# merit function |
|
| 117 | ! |
lambda <- U.invQ[-seq_len(npar)] |
| 118 | ! |
obj <- obj + max(abs(lambda)) * sum(abs(hx)) |
| 119 |
} else {
|
|
| 120 | ! |
lambda <- NULL |
| 121 |
} |
|
| 122 | ||
| 123 | ! |
list(obj = obj, U.invQ = U.invQ, lambda = lambda) |
| 124 |
} |
|
| 125 | ||
| 126 |
lav_optim_gn <- function(lavmodel = NULL, lavsamplestats = NULL, |
|
| 127 |
lavpartable = NULL, |
|
| 128 |
lavdata = NULL, lavoptions = NULL) {
|
|
| 129 |
# no support (yet) for nonlinear constraints |
|
| 130 | ! |
nonlinear.idx <- c( |
| 131 | ! |
lavmodel@ceq.nonlinear.idx, |
| 132 | ! |
lavmodel@cin.nonlinear.idx |
| 133 |
) |
|
| 134 | ! |
if (length(nonlinear.idx) > 0L) {
|
| 135 | ! |
lav_msg_stop(gettext( |
| 136 | ! |
"nonlinear constraints not supported (yet) with optim.method = \"GN\".")) |
| 137 |
} |
|
| 138 | ||
| 139 |
# no support (yet) for inequality constraints |
|
| 140 | ! |
if (!is.null(body(lavmodel@cin.function))) {
|
| 141 | ! |
lav_msg_stop(gettext( |
| 142 | ! |
"inequality constraints not supported (yet) with optim.method = \"GN\".")) |
| 143 |
} |
|
| 144 | ||
| 145 |
# extract current set of free parameters |
|
| 146 | ! |
x <- lav_model_get_parameters(lavmodel) |
| 147 | ! |
npar <- length(x) |
| 148 | ||
| 149 |
# extract bounds (if any) |
|
| 150 | ! |
lb <- ub <- NULL |
| 151 | ! |
if (!is.null(lavpartable) && !is.null(lavpartable$lower)) {
|
| 152 | ! |
lb <- lavpartable$lower[lavpartable$free > 0] |
| 153 | ! |
stopifnot(length(x) == length(lb)) |
| 154 | ! |
lb.idx <- which(x < lb) |
| 155 | ! |
if (length(lb.idx) > 0L) {
|
| 156 | ! |
x[lb.idx] <- lb[lb.idx] |
| 157 |
} |
|
| 158 |
} |
|
| 159 | ! |
if (!is.null(lavpartable) && !is.null(lavpartable$upper)) {
|
| 160 | ! |
ub <- lavpartable$upper[lavpartable$free > 0] |
| 161 | ! |
stopifnot(length(x) == length(ub)) |
| 162 | ! |
ub.idx <- which(x > ub) |
| 163 | ! |
if (length(ub.idx) > 0L) {
|
| 164 | ! |
x[ub.idx] <- ub[ub.idx] |
| 165 |
} |
|
| 166 |
} |
|
| 167 | ||
| 168 |
# options |
|
| 169 | ! |
iter.max <- lavoptions$optim.gn.iter.max |
| 170 | ! |
tol.x <- lavoptions$optim.gn.tol.x |
| 171 | ! |
stephalf.max <- as.integer(lavoptions$optim.gn.stephalf.max) |
| 172 | ! |
if (stephalf.max < 0L) {
|
| 173 | ! |
stephalf.max <- 0L |
| 174 |
} |
|
| 175 | ||
| 176 |
# initialize |
|
| 177 | ! |
iter <- 0 |
| 178 | ! |
alpha <- 1.0 |
| 179 | ! |
old.x <- x |
| 180 | ||
| 181 |
# start Gauss-Newton steps |
|
| 182 | ! |
for (iter in seq_len(iter.max)) {
|
| 183 | ! |
old.out <- lav_objective_GN( |
| 184 | ! |
x = old.x, lavsamplestats = lavsamplestats, |
| 185 | ! |
lavoptions = lavoptions, lavdata = lavdata, |
| 186 | ! |
lavmodel = lavmodel, extra = TRUE |
| 187 |
) |
|
| 188 | ! |
old.obj <- old.out$obj |
| 189 | ! |
U.invQ <- old.out$U.invQ |
| 190 | ||
| 191 |
# only the first time |
|
| 192 | ! |
if (lav_verbose() && iter == 1L) {
|
| 193 | ! |
cat("iteration = ", sprintf("%2d", iter - 1L),
|
| 194 | ! |
": objective = ", sprintf("%11.9f", old.obj), "\n",
|
| 195 | ! |
sep = "" |
| 196 |
) |
|
| 197 |
} |
|
| 198 | ||
| 199 |
# update |
|
| 200 | ! |
alpha <- 1.0 |
| 201 | ! |
step <- U.invQ[seq_len(npar)] |
| 202 |
# TODO: if step-halving fails, we could also |
|
| 203 |
# allow the steps to be negative |
|
| 204 | ! |
for (h in 1:max(1L, stephalf.max)) {
|
| 205 | ! |
new.x <- old.x + (alpha * step) |
| 206 | ||
| 207 |
# apply simple bounds (if any) |
|
| 208 | ! |
if (!is.null(lb)) {
|
| 209 | ! |
lb.idx <- which(new.x < lb) |
| 210 | ! |
if (length(lb.idx) > 0L) {
|
| 211 | ! |
new.x[lb.idx] <- lb[lb.idx] |
| 212 |
} |
|
| 213 |
} |
|
| 214 | ! |
if (!is.null(ub)) {
|
| 215 | ! |
ub.idx <- which(new.x > ub) |
| 216 | ! |
if (length(ub.idx) > 0L) {
|
| 217 | ! |
new.x[ub.idx] <- ub[ub.idx] |
| 218 |
} |
|
| 219 |
} |
|
| 220 | ||
| 221 | ! |
new.obj <- lav_objective_GN( |
| 222 | ! |
x = new.x, |
| 223 | ! |
lavsamplestats = lavsamplestats, |
| 224 | ! |
lavdata = lavdata, lavoptions = lavoptions, |
| 225 | ! |
lavmodel = lavmodel, extra = FALSE, |
| 226 | ! |
lambda = old.out$lambda |
| 227 | ! |
)$obj |
| 228 | ||
| 229 | ! |
if (is.finite(new.obj) && new.obj < old.obj) {
|
| 230 | ! |
break |
| 231 | ! |
} else if (stephalf.max == 0L) { # no step-halving!
|
| 232 | ! |
break |
| 233 |
} else {
|
|
| 234 |
# step-halving |
|
| 235 | ! |
alpha <- alpha / 2.0 |
| 236 |
# if(verbose) {
|
|
| 237 |
# cat(" -- step halving -- : alpha = ", alpha, "\n")
|
|
| 238 |
# } |
|
| 239 |
} |
|
| 240 |
} |
|
| 241 | ||
| 242 |
# TODO - if this fails, we need to recover somehow |
|
| 243 |
# negative steps: |
|
| 244 | ! |
if (stephalf.max != 0L && h == stephalf.max) {
|
| 245 | ! |
if (lav_verbose()) {
|
| 246 | ! |
cat(" -- step halving failed; function value may increase.\n")
|
| 247 |
} |
|
| 248 |
# forcing step with alpha = 1 |
|
| 249 | ! |
new.x <- old.x + (1 * step) |
| 250 |
} |
|
| 251 | ||
| 252 | ! |
rms.x <- sqrt(mean((old.x - new.x) * (old.x - new.x))) |
| 253 | ||
| 254 |
# verbose? |
|
| 255 | ! |
if (lav_verbose()) {
|
| 256 | ! |
cat("iteration = ", sprintf("%2d", iter),
|
| 257 | ! |
": objective = ", sprintf("%11.9f", new.obj),
|
| 258 | ! |
" alpha = ", sprintf("%6.5f", alpha),
|
| 259 | ! |
" rms.x = ", sprintf("%9.9f", rms.x), "\n",
|
| 260 | ! |
sep = "" |
| 261 |
) |
|
| 262 |
# print(new.x) |
|
| 263 |
} |
|
| 264 | ||
| 265 |
# check for convergence |
|
| 266 | ! |
if (rms.x < tol.x) {
|
| 267 | ! |
old.x <- new.x |
| 268 | ! |
old.obj <- new.obj |
| 269 | ! |
if (lav_verbose()) {
|
| 270 | ! |
cat("Gauss-Newton algorithm converged: rms.x = ",
|
| 271 | ! |
sprintf("%12.12f", rms.x), " < ",
|
| 272 | ! |
sprintf("%12.12f", tol.x), "\n",
|
| 273 | ! |
sep = "" |
| 274 |
) |
|
| 275 |
} |
|
| 276 | ! |
break |
| 277 |
} else {
|
|
| 278 | ! |
old.x <- new.x |
| 279 | ! |
old.obj <- new.obj |
| 280 |
} |
|
| 281 |
} # iter |
|
| 282 | ||
| 283 | ! |
x <- new.x |
| 284 | ||
| 285 |
# one last evaluation, to get fx.group attribute |
|
| 286 | ! |
lavmodel <- lav_model_set_parameters(lavmodel = lavmodel, x = x) |
| 287 | ! |
fx <- lav_model_objective( |
| 288 | ! |
lavmodel = lavmodel, lavdata = lavdata, |
| 289 | ! |
lavsamplestats = lavsamplestats |
| 290 |
) |
|
| 291 | ||
| 292 |
# add attributes |
|
| 293 | ! |
if (iter < iter.max) {
|
| 294 | ! |
attr(x, "converged") <- TRUE |
| 295 | ! |
attr(x, "warn.txt") <- "" |
| 296 |
} else {
|
|
| 297 | ! |
attr(x, "converged") <- FALSE |
| 298 | ! |
attr(x, "warn.txt") <- paste("maxmimum number of iterations (",
|
| 299 | ! |
iter.max, ") ", |
| 300 | ! |
"was reached without convergence.\n", |
| 301 | ! |
sep = "" |
| 302 |
) |
|
| 303 |
} |
|
| 304 | ! |
attr(x, "iterations") <- iter |
| 305 | ! |
attr(x, "control") <- list( |
| 306 | ! |
iter.max = iter.max, |
| 307 | ! |
tol.x = tol.x |
| 308 |
) |
|
| 309 | ! |
attr(x, "fx") <- fx |
| 310 | ||
| 311 | ! |
x |
| 312 |
} |
| 1 |
# functions related to CFI and other 'incremental' fit indices |
|
| 2 | ||
| 3 |
# lower-level functions: |
|
| 4 |
# - lav_fit_cfi |
|
| 5 |
# - lav_fit_rni (same as CFI, but without the max(0,)) |
|
| 6 |
# - lav_fit_tli/lav_fit_nnfi |
|
| 7 |
# - lav_fit_rfi |
|
| 8 |
# - lav_fit_nfi |
|
| 9 |
# - lav_fit_pnfi |
|
| 10 |
# - lav_fit_ifi |
|
| 11 | ||
| 12 |
# higher-level functions: |
|
| 13 |
# - lav_fit_cfi_lavobject |
|
| 14 | ||
| 15 |
# Y.R. 20 July 2022 |
|
| 16 | ||
| 17 |
# CFI - comparative fit index (Bentler, 1990) |
|
| 18 |
# robust version: Brosseau-Liard & Savalei MBR 2014, equation 15 |
|
| 19 |
# Brosseau-Liard, P. E., & Savalei, V. (2014). Adjusting incremental fit |
|
| 20 |
# indices for nonnormality. Multivariate behavioral research, 49(5), 460-470. |
|
| 21 | ||
| 22 |
# robust version MLMV (scaled.shifted) |
|
| 23 |
# Savalei, V. (2018). On the computation of the RMSEA and CFI from the |
|
| 24 |
# mean-and-variance corrected test statistic with nonnormal data in SEM. |
|
| 25 |
# Multivariate behavioral research, 53(3), 419-429. eq 9 |
|
| 26 | ||
| 27 |
# note: robust MLM == robust MLMV |
|
| 28 | ||
| 29 |
# categorical data: |
|
| 30 |
# Savalei, V. (2021). Improving fit indices in structural equation modeling with |
|
| 31 |
# categorical data. Multivariate Behavioral Research, 56(3), 390-407. doi: |
|
| 32 |
# 10.1080/00273171.2020.1717922 |
|
| 33 | ||
| 34 |
# when missing = "fiml": |
|
| 35 |
# Zhang, X., & Savalei, V. (2023). New computations for RMSEA and CFI following |
|
| 36 |
# FIML and TS estimation with missing data. Psychological Methods, 28(2), |
|
| 37 |
# 263-283. https://doi.org/10.1037/met0000445 |
|
| 38 | ||
| 39 | ||
| 40 |
lav_fit_cfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL, |
|
| 41 |
c.hat = 1, c.hat.null = 1) {
|
|
| 42 | 58x |
if (anyNA(c(X2, df, X2.null, df.null, c.hat, c.hat.null))) {
|
| 43 | 2x |
return(as.numeric(NA)) |
| 44 |
} |
|
| 45 | ||
| 46 |
# robust? |
|
| 47 | 56x |
if (df > 0 && !missing(c.hat) && !missing(c.hat.null) && |
| 48 | 56x |
c.hat != 1 && c.hat.null != 1) {
|
| 49 | 2x |
t1 <- max(c(X2 - (c.hat * df), 0)) |
| 50 | 2x |
t2 <- max(c(X2 - (c.hat * df), X2.null - (c.hat.null * df.null), 0)) |
| 51 |
} else {
|
|
| 52 | 54x |
t1 <- max(c(X2 - df, 0)) |
| 53 | 54x |
t2 <- max(c(X2 - df, X2.null - df.null, 0)) |
| 54 |
} |
|
| 55 | ||
| 56 | 56x |
if (isTRUE(all.equal(t1, 0)) && isTRUE(all.equal(t2, 0))) {
|
| 57 | ! |
CFI <- 1 |
| 58 |
} else {
|
|
| 59 | 56x |
CFI <- 1 - t1 / t2 |
| 60 |
} |
|
| 61 | ||
| 62 | 56x |
CFI |
| 63 |
} |
|
| 64 | ||
| 65 |
# RNI - relative noncentrality index (McDonald & Marsh, 1990) |
|
| 66 |
# same as CFI, but without the max(0,) |
|
| 67 |
lav_fit_rni <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL, |
|
| 68 |
c.hat = 1, c.hat.null = 1) {
|
|
| 69 | 27x |
if (anyNA(c(X2, df, X2.null, df.null, c.hat, c.hat.null))) {
|
| 70 | 1x |
return(as.numeric(NA)) |
| 71 |
} |
|
| 72 | ||
| 73 |
# robust? |
|
| 74 | 26x |
if (df > 0 && !missing(c.hat) && !missing(c.hat.null) && |
| 75 | 26x |
c.hat != 1 && c.hat.null != 1) {
|
| 76 | 1x |
t1 <- X2 - (c.hat * df) |
| 77 | 1x |
t2 <- X2.null - (c.hat.null * df.null) |
| 78 |
} else {
|
|
| 79 | 25x |
t1 <- X2 - df |
| 80 | 25x |
t2 <- X2.null - df.null |
| 81 |
} |
|
| 82 | ||
| 83 | 26x |
if (isTRUE(all.equal(t2, 0))) {
|
| 84 | ! |
RNI <- as.numeric(NA) |
| 85 | 26x |
} else if (!is.finite(t1) || !is.finite(t2)) {
|
| 86 | ! |
RNI <- as.numeric(NA) |
| 87 |
} else {
|
|
| 88 | 26x |
RNI <- 1 - t1 / t2 |
| 89 |
} |
|
| 90 | ||
| 91 | 26x |
RNI |
| 92 |
} |
|
| 93 | ||
| 94 |
# TLI - Tucker-Lewis index (Tucker & Lewis, 1973) |
|
| 95 |
# same as |
|
| 96 |
# NNFI - nonnormed fit index (NNFI, Bentler & Bonett, 1980) |
|
| 97 |
# note: formula in lavaan <= 0.5-20: |
|
| 98 |
# t1 <- X2.null/df.null - X2/df |
|
| 99 |
# t2 <- X2.null/df.null - 1 |
|
| 100 |
# if(t1 < 0 && t2 < 0) {
|
|
| 101 |
# TLI <- 1 |
|
| 102 |
# } else {
|
|
| 103 |
# TLI <- t1/t2 |
|
| 104 |
# } |
|
| 105 |
# note: TLI original formula was in terms of fx/df, not X2/df |
|
| 106 |
# then, t1 <- fx_0/df.null - fx/df |
|
| 107 |
# t2 <- fx_0/df.null - 1/N (or N-1 for wishart) |
|
| 108 | ||
| 109 |
# note: in lavaan 0.5-21, we use the alternative formula: |
|
| 110 |
# TLI <- 1 - ((X2 - df)/(X2.null - df.null) * df.null/df) |
|
| 111 |
# - this one has the advantage that a 'robust' version |
|
| 112 |
# can be derived; this seems non-trivial for the original one |
|
| 113 |
# - unlike cfi, we do not use 'max(0, )' for t1 and t2 |
|
| 114 |
# therefore, t1 can go negative, and TLI can be > 1 |
|
| 115 |
lav_fit_tli <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL, |
|
| 116 |
c.hat = 1, c.hat.null = 1) {
|
|
| 117 | 85x |
if (anyNA(c(X2, df, X2.null, df.null, c.hat, c.hat.null))) {
|
| 118 | 3x |
return(as.numeric(NA)) |
| 119 |
} |
|
| 120 | ||
| 121 |
# robust? |
|
| 122 | 82x |
if (df > 0 && !missing(c.hat) && !missing(c.hat.null) && |
| 123 | 82x |
c.hat != 1 && c.hat.null != 1) {
|
| 124 | 3x |
t1 <- (X2 - c.hat * df) * df.null |
| 125 | 3x |
t2 <- (X2.null - c.hat.null * df.null) * df |
| 126 |
} else {
|
|
| 127 | 79x |
t1 <- (X2 - df) * df.null |
| 128 | 79x |
t2 <- (X2.null - df.null) * df |
| 129 |
} |
|
| 130 | ||
| 131 | 82x |
if (df > 0 && abs(t2) > 0) {
|
| 132 | 49x |
TLI <- 1 - t1 / t2 |
| 133 | 33x |
} else if (!is.finite(t1) || !is.finite(t2)) {
|
| 134 | ! |
TLI <- as.numeric(NA) |
| 135 |
} else {
|
|
| 136 | 33x |
TLI <- 1 |
| 137 |
} |
|
| 138 | ||
| 139 | 82x |
TLI |
| 140 |
} |
|
| 141 | ||
| 142 |
# alias for nnfi |
|
| 143 |
lav_fit_nnfi <- lav_fit_tli |
|
| 144 | ||
| 145 |
# RFI - relative fit index (Bollen, 1986; Joreskog & Sorbom 1993) |
|
| 146 |
lav_fit_rfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
|
|
| 147 | 22x |
if (anyNA(c(X2, df, X2.null, df.null))) {
|
| 148 | ! |
return(as.numeric(NA)) |
| 149 |
} |
|
| 150 | ||
| 151 | 22x |
if (df > df.null) {
|
| 152 | 1x |
RLI <- as.numeric(NA) |
| 153 | 21x |
} else if (df > 0 && df.null > 0) {
|
| 154 | 13x |
t1 <- X2.null / df.null - X2 / df |
| 155 | 13x |
t2 <- X2.null / df.null |
| 156 | 13x |
if (!is.finite(t1) || !is.finite(t2)) {
|
| 157 | ! |
RLI <- as.numeric(NA) |
| 158 | 13x |
} else if (t1 < 0 || t2 < 0) {
|
| 159 | ! |
RLI <- 1 |
| 160 |
} else {
|
|
| 161 | 13x |
RLI <- t1 / t2 |
| 162 |
} |
|
| 163 |
} else {
|
|
| 164 | 8x |
RLI <- 1 |
| 165 |
} |
|
| 166 | ||
| 167 | 22x |
RLI |
| 168 |
} |
|
| 169 | ||
| 170 |
# NFI - normed fit index (Bentler & Bonett, 1980) |
|
| 171 |
lav_fit_nfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
|
|
| 172 | 22x |
if (anyNA(c(X2, df, X2.null, df.null))) {
|
| 173 | ! |
return(as.numeric(NA)) |
| 174 |
} |
|
| 175 | ||
| 176 | 22x |
if (df > df.null || isTRUE(all.equal(X2.null, 0))) {
|
| 177 | 1x |
NFI <- as.numeric(NA) |
| 178 | 21x |
} else if (df > 0) {
|
| 179 | 13x |
t1 <- X2.null - X2 |
| 180 | 13x |
t2 <- X2.null |
| 181 | 13x |
NFI <- t1 / t2 |
| 182 |
} else {
|
|
| 183 | 8x |
NFI <- 1 |
| 184 |
} |
|
| 185 | ||
| 186 | 22x |
NFI |
| 187 |
} |
|
| 188 | ||
| 189 |
# PNFI - Parsimony normed fit index (James, Mulaik & Brett, 1982) |
|
| 190 |
lav_fit_pnfi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
|
|
| 191 | 22x |
if (anyNA(c(X2, df, X2.null, df.null))) {
|
| 192 | ! |
return(as.numeric(NA)) |
| 193 |
} |
|
| 194 | ||
| 195 | 22x |
if (df.null > 0 && X2.null > 0) {
|
| 196 | 22x |
t1 <- X2.null - X2 |
| 197 | 22x |
t2 <- X2.null |
| 198 | 22x |
PNFI <- (df / df.null) * (t1 / t2) |
| 199 |
} else {
|
|
| 200 | ! |
PNFI <- as.numeric(NA) |
| 201 |
} |
|
| 202 | ||
| 203 | 22x |
PNFI |
| 204 |
} |
|
| 205 | ||
| 206 |
# IFI - incremental fit index (Bollen, 1989; Joreskog & Sorbom, 1993) |
|
| 207 |
lav_fit_ifi <- function(X2 = NULL, df = NULL, X2.null = NULL, df.null = NULL) {
|
|
| 208 | 22x |
if (anyNA(c(X2, df, X2.null, df.null))) {
|
| 209 | ! |
return(as.numeric(NA)) |
| 210 |
} |
|
| 211 | ||
| 212 | 22x |
t1 <- X2.null - X2 |
| 213 | 22x |
t2 <- X2.null - df |
| 214 | 22x |
if (!is.finite(t1) || !is.finite(t2)) {
|
| 215 | ! |
IFI <- as.numeric(NA) |
| 216 | 22x |
} else if (t2 < 0) {
|
| 217 | ! |
IFI <- 1 |
| 218 | 22x |
} else if (isTRUE(all.equal(t2, 0))) {
|
| 219 | ! |
IFI <- as.numeric(NA) |
| 220 |
} else {
|
|
| 221 | 22x |
IFI <- t1 / t2 |
| 222 |
} |
|
| 223 | ||
| 224 | 22x |
IFI |
| 225 |
} |
|
| 226 | ||
| 227 |
# higher-level function |
|
| 228 |
lav_fit_cfi_lavobject <- function(lavobject = NULL, fit.measures = "cfi", |
|
| 229 |
baseline.model = NULL, h1.model = NULL, |
|
| 230 |
standard.test = "standard", |
|
| 231 |
scaled.test = "none", |
|
| 232 |
robust = TRUE, |
|
| 233 |
cat.check.pd = TRUE) {
|
|
| 234 |
# check lavobject |
|
| 235 | 44x |
stopifnot(inherits(lavobject, "lavaan")) |
| 236 | ||
| 237 |
# check for categorical |
|
| 238 | 44x |
categorical.flag <- lavobject@Model@categorical |
| 239 | ||
| 240 |
# tests |
|
| 241 | 44x |
TEST <- lavobject@test |
| 242 | 44x |
test.names <- sapply(lavobject@test, "[[", "test") |
| 243 | 44x |
if (test.names[1] == "none" || standard.test == "none") {
|
| 244 | ! |
return(list()) |
| 245 |
} |
|
| 246 | 44x |
test.idx <- which(test.names == standard.test)[1] |
| 247 | 44x |
if (length(test.idx) == 0L) {
|
| 248 | ! |
return(list()) |
| 249 |
} |
|
| 250 | ||
| 251 | 44x |
scaled.flag <- FALSE |
| 252 | 44x |
if (!scaled.test %in% c("none", "standard", "default")) {
|
| 253 | 4x |
scaled.idx <- which(test.names == scaled.test) |
| 254 | 4x |
if (length(scaled.idx) > 0L) {
|
| 255 | 4x |
scaled.idx <- scaled.idx[1] # only the first one |
| 256 | 4x |
scaled.flag <- TRUE |
| 257 |
} |
|
| 258 |
} |
|
| 259 | ||
| 260 |
# robust? |
|
| 261 | 44x |
robust.flag <- FALSE |
| 262 | 44x |
if (robust && scaled.flag && |
| 263 | 44x |
scaled.test %in% c( |
| 264 | 44x |
"satorra.bentler", "yuan.bentler.mplus", |
| 265 | 44x |
"yuan.bentler", "scaled.shifted" |
| 266 |
)) {
|
|
| 267 | 4x |
robust.flag <- TRUE |
| 268 |
} |
|
| 269 | ||
| 270 |
# FIML? |
|
| 271 | 44x |
fiml.flag <- FALSE |
| 272 | 44x |
if (robust && lavobject@Options$missing %in% c("ml", "ml.x")) {
|
| 273 | 8x |
fiml.flag <- robust.flag <- TRUE |
| 274 |
# check if we can compute corrected values |
|
| 275 | 8x |
if (scaled.flag) {
|
| 276 | 2x |
version <- "V3" |
| 277 |
} else {
|
|
| 278 | 6x |
version <- "V6" |
| 279 |
} |
|
| 280 | 8x |
fiml <- try( |
| 281 | 8x |
lav_fit_fiml_corrected(lavobject, baseline.model, |
| 282 | 8x |
version = version |
| 283 |
), |
|
| 284 | 8x |
silent = TRUE |
| 285 |
) |
|
| 286 | 8x |
if (inherits(fiml, "try-error")) {
|
| 287 | ! |
lav_msg_warn(gettext("computation of robust CFI failed."))
|
| 288 | ! |
fiml <- list( |
| 289 | ! |
XX3 = as.numeric(NA), df3 = as.numeric(NA), |
| 290 | ! |
c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA), |
| 291 | ! |
XX3.null = as.numeric(NA), df3.null = as.numeric(NA), |
| 292 | ! |
c.hat3.null = as.numeric(NA) |
| 293 |
) |
|
| 294 | 8x |
} else if (anyNA(c( |
| 295 | 8x |
fiml$XX3, fiml$df3, fiml$c.hat3, fiml$XX3.scaled, |
| 296 | 8x |
fiml$XX3.null, fiml$df3.null, fiml$c.hat3.null |
| 297 |
))) {
|
|
| 298 | ! |
lav_msg_warn(gettext("computation of robust CFI resulted in NA values."))
|
| 299 |
} |
|
| 300 |
} |
|
| 301 | ||
| 302 |
# supported fit measures in this function |
|
| 303 |
# baseline model |
|
| 304 | 44x |
fit.baseline <- c("baseline.chisq", "baseline.df", "baseline.pvalue")
|
| 305 | 44x |
if (scaled.flag) {
|
| 306 | 4x |
fit.baseline <- c( |
| 307 | 4x |
fit.baseline, "baseline.chisq.scaled", |
| 308 | 4x |
"baseline.df.scaled", "baseline.pvalue.scaled", |
| 309 | 4x |
"baseline.chisq.scaling.factor" |
| 310 |
) |
|
| 311 |
} |
|
| 312 | ||
| 313 | 44x |
fit.cfi.tli <- c("cfi", "tli")
|
| 314 | 44x |
if (scaled.flag) {
|
| 315 | 4x |
fit.cfi.tli <- c(fit.cfi.tli, "cfi.scaled", "tli.scaled") |
| 316 |
} |
|
| 317 | 44x |
if (robust.flag) {
|
| 318 | 10x |
fit.cfi.tli <- c(fit.cfi.tli, "cfi.robust", "tli.robust") |
| 319 |
} |
|
| 320 | ||
| 321 |
# other incremental fit indices |
|
| 322 | 44x |
fit.cfi.other <- c("nnfi", "rfi", "nfi", "pnfi", "ifi", "rni")
|
| 323 | 44x |
if (scaled.flag) {
|
| 324 | 4x |
fit.cfi.other <- c( |
| 325 | 4x |
fit.cfi.other, "nnfi.scaled", "rfi.scaled", |
| 326 | 4x |
"nfi.scaled", "pnfi.scaled", "ifi.scaled", "rni.scaled" |
| 327 |
) |
|
| 328 |
} |
|
| 329 | 44x |
if (robust.flag) {
|
| 330 | 10x |
fit.cfi.other <- c(fit.cfi.other, "nnfi.robust", "rni.robust") |
| 331 |
} |
|
| 332 | ||
| 333 |
# which one do we need? |
|
| 334 | 44x |
if (missing(fit.measures)) {
|
| 335 |
# default set |
|
| 336 | ! |
fit.measures <- c(fit.baseline, fit.cfi.tli) |
| 337 |
} else {
|
|
| 338 |
# remove any not-CFI related index from fit.measures |
|
| 339 | 44x |
rm.idx <- which(!fit.measures %in% |
| 340 | 44x |
c(fit.baseline, fit.cfi.tli, fit.cfi.other)) |
| 341 | 44x |
if (length(rm.idx) > 0L) {
|
| 342 | 44x |
fit.measures <- fit.measures[-rm.idx] |
| 343 |
} |
|
| 344 | 44x |
if (length(fit.measures) == 0L) {
|
| 345 | ! |
return(list()) |
| 346 |
} |
|
| 347 |
} |
|
| 348 | ||
| 349 | ||
| 350 |
# basic test statistics |
|
| 351 | 44x |
X2 <- TEST[[test.idx]]$stat |
| 352 | 44x |
df <- TEST[[test.idx]]$df |
| 353 | 44x |
G <- lavobject@Data@ngroups # number of groups |
| 354 | 44x |
N <- lav_object_inspect_ntotal(object = lavobject) # N vs N-1 |
| 355 | ||
| 356 |
# scaled X2 |
|
| 357 | 44x |
if (scaled.flag) {
|
| 358 | 4x |
X2.scaled <- TEST[[scaled.idx]]$stat |
| 359 | 4x |
df.scaled <- TEST[[scaled.idx]]$df |
| 360 |
} |
|
| 361 | 44x |
if (robust.flag) {
|
| 362 | 10x |
XX3 <- X2 |
| 363 | 10x |
if (categorical.flag) {
|
| 364 | 2x |
out <- try(lav_fit_catml_dwls(lavobject, check.pd = cat.check.pd), |
| 365 | 2x |
silent = TRUE |
| 366 |
) |
|
| 367 | 2x |
if (inherits(out, "try-error")) {
|
| 368 | ! |
XX3 <- df3 <- c.hat <- c.hat3 <- XX3.scaled <- as.numeric(NA) |
| 369 |
} else {
|
|
| 370 | 2x |
XX3 <- out$XX3 |
| 371 | 2x |
df3 <- out$df3 |
| 372 | 2x |
c.hat3 <- c.hat <- out$c.hat3 |
| 373 | 2x |
XX3.scaled <- out$XX3.scaled |
| 374 |
} |
|
| 375 | 8x |
} else if (fiml.flag) {
|
| 376 | 8x |
XX3 <- fiml$XX3 |
| 377 | 8x |
df3 <- fiml$df3 |
| 378 | 8x |
c.hat3 <- c.hat <- fiml$c.hat3 |
| 379 | 8x |
XX3.scaled <- fiml$XX3.scaled |
| 380 | ! |
} else if (scaled.test == "scaled.shifted") {
|
| 381 |
# compute c.hat from a and b |
|
| 382 | ! |
a <- TEST[[scaled.idx]]$scaling.factor |
| 383 | ! |
b <- TEST[[scaled.idx]]$shift.parameter |
| 384 | ! |
c.hat <- a * (df - b) / df |
| 385 |
} else {
|
|
| 386 | ! |
c.hat <- TEST[[scaled.idx]]$scaling.factor |
| 387 |
} |
|
| 388 |
} |
|
| 389 | ||
| 390 |
# output container |
|
| 391 | 44x |
indices <- list() |
| 392 | ||
| 393 |
# only do what is needed (per groups) |
|
| 394 | 44x |
cfi.baseline.flag <- cfi.tli.flag <- cfi.other.flag <- FALSE |
| 395 | 44x |
if (any(fit.baseline %in% fit.measures)) {
|
| 396 | 24x |
cfi.baseline.flag <- TRUE |
| 397 |
} |
|
| 398 | 44x |
if (any(fit.cfi.tli %in% fit.measures)) {
|
| 399 | 44x |
cfi.tli.flag <- TRUE |
| 400 |
} |
|
| 401 | 44x |
if (any(fit.cfi.other %in% fit.measures)) {
|
| 402 | 20x |
cfi.other.flag <- TRUE |
| 403 |
} |
|
| 404 | ||
| 405 |
# 1. BASELINE model |
|
| 406 | 44x |
baseline.test <- NULL |
| 407 | ||
| 408 |
# we use the following priority: |
|
| 409 |
# 1. user-provided baseline model |
|
| 410 |
# 2. baseline model in @external slot |
|
| 411 |
# 3. baseline model in @baseline slot |
|
| 412 |
# 4. nothing -> compute independence model |
|
| 413 | ||
| 414 |
# TDJ: Also check for user-supplied h1.model, using similar priority: |
|
| 415 |
# 1. user-provided h1 model |
|
| 416 |
# 2. h1 model in @external slot |
|
| 417 |
# 3. default h1 model (already in @h1 slot, no update necessary) |
|
| 418 | ||
| 419 |
# 1. user-provided h1 model |
|
| 420 | 44x |
if (!is.null(h1.model)) {
|
| 421 | ! |
stopifnot(inherits(h1.model, "lavaan")) |
| 422 | ||
| 423 |
# 2. h1 model in @external slot |
|
| 424 | 44x |
} else if (!is.null(lavobject@external$h1.model)) {
|
| 425 | ! |
stopifnot(inherits(lavobject@external$h1.model, "lavaan")) |
| 426 | ! |
h1.model <- lavobject@external$h1.model |
| 427 |
} # else is.null |
|
| 428 | ||
| 429 |
# 1. user-provided baseline model |
|
| 430 | 44x |
if (!is.null(baseline.model)) {
|
| 431 | ! |
baseline.test <- |
| 432 | ! |
lav_fit_measures_check_baseline( |
| 433 | ! |
fit.indep = baseline.model, |
| 434 | ! |
object = lavobject, |
| 435 | ! |
fit.h1 = h1.model # okay if NULL |
| 436 |
) |
|
| 437 |
# 2. baseline model in @external slot |
|
| 438 | 44x |
} else if (!is.null(lavobject@external$baseline.model)) {
|
| 439 | ! |
fit.indep <- lavobject@external$baseline.model |
| 440 | ! |
baseline.test <- |
| 441 | ! |
lav_fit_measures_check_baseline( |
| 442 | ! |
fit.indep = fit.indep, |
| 443 | ! |
object = lavobject, |
| 444 | ! |
fit.h1 = h1.model # okay if NULL |
| 445 |
) |
|
| 446 |
# 3. internal @baseline slot |
|
| 447 | 44x |
} else if (length(lavobject@baseline) > 0L && |
| 448 | 44x |
!is.null(lavobject@baseline$test) && |
| 449 |
## if there is a custom h1.model, need _check_baseline() to update @test |
|
| 450 | 44x |
is.null(h1.model)) {
|
| 451 | 44x |
baseline.test <- lavobject@baseline$test |
| 452 |
# 4. (re)compute independence model |
|
| 453 |
} else {
|
|
| 454 | ! |
fit.indep <- try(lav_object_independence(lavobject), silent = TRUE) |
| 455 | ! |
baseline.test <- |
| 456 | ! |
lav_fit_measures_check_baseline( |
| 457 | ! |
fit.indep = fit.indep, |
| 458 | ! |
object = lavobject, |
| 459 | ! |
fit.h1 = h1.model # okay if NULL |
| 460 |
) |
|
| 461 |
} |
|
| 462 | ||
| 463 |
# baseline.test.idx |
|
| 464 | 44x |
baseline.test.idx <- which(names(baseline.test) == standard.test)[1] |
| 465 | 44x |
if (scaled.flag) {
|
| 466 | 4x |
baseline.scaled.idx <- which(names(baseline.test) == scaled.test)[1] |
| 467 |
} |
|
| 468 | ||
| 469 | 44x |
if (!is.null(baseline.test)) {
|
| 470 | 44x |
X2.null <- baseline.test[[baseline.test.idx]]$stat |
| 471 | 44x |
df.null <- baseline.test[[baseline.test.idx]]$df |
| 472 | 44x |
if (scaled.flag) {
|
| 473 | 4x |
X2.null.scaled <- baseline.test[[baseline.scaled.idx]]$stat |
| 474 | 4x |
df.null.scaled <- baseline.test[[baseline.scaled.idx]]$df |
| 475 |
} |
|
| 476 | 44x |
if (robust.flag) {
|
| 477 | 10x |
XX3.null <- X2.null |
| 478 | 10x |
if (categorical.flag) {
|
| 479 | 2x |
if (inherits(out, "try-error")) {
|
| 480 | ! |
XX3.null <- c.hat.null <- as.numeric(NA) |
| 481 |
} else {
|
|
| 482 | 2x |
XX3.null <- out$XX3.null |
| 483 | 2x |
c.hat.null <- out$c.hat3.null |
| 484 |
} |
|
| 485 | 8x |
} else if (fiml.flag) {
|
| 486 | 8x |
XX3.null <- fiml$XX3.null |
| 487 | 8x |
c.hat.null <- fiml$c.hat3.null |
| 488 | ! |
} else if (scaled.test == "scaled.shifted") {
|
| 489 |
# compute c.hat from a and b |
|
| 490 | ! |
a.null <- |
| 491 | ! |
baseline.test[[baseline.scaled.idx]]$scaling.factor |
| 492 | ! |
b.null <- |
| 493 | ! |
baseline.test[[baseline.scaled.idx]]$shift.parameter |
| 494 | ! |
c.hat.null <- a.null * (df.null - b.null) / df.null |
| 495 |
} else {
|
|
| 496 | ! |
c.hat.null <- |
| 497 | ! |
baseline.test[[baseline.scaled.idx]]$scaling.factor |
| 498 |
} |
|
| 499 |
} |
|
| 500 |
} else {
|
|
| 501 | ! |
X2.null <- df.null <- as.numeric(NA) |
| 502 | ! |
X2.null.scaled <- df.null.scaled <- as.numeric(NA) |
| 503 | ! |
c.hat.null <- as.numeric(NA) |
| 504 |
} |
|
| 505 | ||
| 506 |
# check for NAs of nonfinite numbers |
|
| 507 | 44x |
if (!is.finite(X2) || !is.finite(df) || |
| 508 | 44x |
!is.finite(X2.null) || !is.finite(df.null)) {
|
| 509 | ! |
indices[fit.measures] <- as.numeric(NA) |
| 510 | ! |
return(indices) |
| 511 |
} |
|
| 512 | ||
| 513 |
# fill in baseline indices |
|
| 514 | 44x |
if (cfi.baseline.flag) {
|
| 515 | 24x |
indices["baseline.chisq"] <- X2.null |
| 516 | 24x |
indices["baseline.df"] <- df.null |
| 517 | 24x |
indices["baseline.pvalue"] <- baseline.test[[baseline.test.idx]]$pvalue |
| 518 | 24x |
if (scaled.flag) {
|
| 519 | 2x |
indices["baseline.chisq.scaled"] <- X2.null.scaled |
| 520 | 2x |
indices["baseline.df.scaled"] <- df.null.scaled |
| 521 | 2x |
indices["baseline.pvalue.scaled"] <- |
| 522 | 2x |
baseline.test[[baseline.scaled.idx]]$pvalue |
| 523 | 2x |
indices["baseline.chisq.scaling.factor"] <- |
| 524 | 2x |
baseline.test[[baseline.scaled.idx]]$scaling.factor |
| 525 |
} |
|
| 526 |
} |
|
| 527 | ||
| 528 |
# 2. CFI and TLI |
|
| 529 | 44x |
if (cfi.tli.flag) {
|
| 530 | 44x |
indices["cfi"] <- lav_fit_cfi( |
| 531 | 44x |
X2 = X2, df = df, |
| 532 | 44x |
X2.null = X2.null, df.null = df.null |
| 533 |
) |
|
| 534 | 44x |
indices["tli"] <- lav_fit_tli( |
| 535 | 44x |
X2 = X2, df = df, |
| 536 | 44x |
X2.null = X2.null, df.null = df.null |
| 537 |
) |
|
| 538 | 44x |
if (scaled.flag) {
|
| 539 | 4x |
indices["cfi.scaled"] <- |
| 540 | 4x |
lav_fit_cfi( |
| 541 | 4x |
X2 = X2.scaled, df = df.scaled, |
| 542 | 4x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 543 |
) |
|
| 544 | 4x |
indices["tli.scaled"] <- |
| 545 | 4x |
lav_fit_tli( |
| 546 | 4x |
X2 = X2.scaled, df = df.scaled, |
| 547 | 4x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 548 |
) |
|
| 549 |
} |
|
| 550 | 44x |
if (robust.flag) {
|
| 551 | 10x |
indices["cfi.robust"] <- |
| 552 | 10x |
lav_fit_cfi( |
| 553 | 10x |
X2 = XX3, df = df, |
| 554 | 10x |
X2.null = XX3.null, df.null = df.null, |
| 555 | 10x |
c.hat = c.hat, c.hat.null = c.hat.null |
| 556 |
) |
|
| 557 | 10x |
indices["tli.robust"] <- |
| 558 | 10x |
lav_fit_tli( |
| 559 | 10x |
X2 = XX3, df = df, |
| 560 | 10x |
X2.null = XX3.null, df.null = df.null, |
| 561 | 10x |
c.hat = c.hat, c.hat.null = c.hat.null |
| 562 |
) |
|
| 563 |
} |
|
| 564 |
} |
|
| 565 | ||
| 566 |
# 3. other |
|
| 567 |
# c("nnfi", "rfi", "nfi", "pnfi", "ifi", "rni")
|
|
| 568 | 44x |
if (cfi.other.flag) {
|
| 569 | 20x |
indices["nnfi"] <- |
| 570 | 20x |
lav_fit_nnfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null) |
| 571 | 20x |
indices["rfi"] <- |
| 572 | 20x |
lav_fit_rfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null) |
| 573 | 20x |
indices["nfi"] <- |
| 574 | 20x |
lav_fit_nfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null) |
| 575 | 20x |
indices["pnfi"] <- |
| 576 | 20x |
lav_fit_pnfi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null) |
| 577 | 20x |
indices["ifi"] <- |
| 578 | 20x |
lav_fit_ifi(X2 = X2, df = df, X2.null = X2.null, df.null = df.null) |
| 579 | 20x |
indices["rni"] <- |
| 580 | 20x |
lav_fit_rni(X2 = X2, df = df, X2.null = X2.null, df.null = df.null) |
| 581 | ||
| 582 | 20x |
if (scaled.flag) {
|
| 583 | 2x |
indices["nnfi.scaled"] <- |
| 584 | 2x |
lav_fit_nnfi( |
| 585 | 2x |
X2 = X2.scaled, df = df.scaled, |
| 586 | 2x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 587 |
) |
|
| 588 | 2x |
indices["rfi.scaled"] <- |
| 589 | 2x |
lav_fit_rfi( |
| 590 | 2x |
X2 = X2.scaled, df = df.scaled, |
| 591 | 2x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 592 |
) |
|
| 593 | 2x |
indices["nfi.scaled"] <- |
| 594 | 2x |
lav_fit_nfi( |
| 595 | 2x |
X2 = X2.scaled, df = df.scaled, |
| 596 | 2x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 597 |
) |
|
| 598 | 2x |
indices["pnfi.scaled"] <- |
| 599 | 2x |
lav_fit_pnfi( |
| 600 | 2x |
X2 = X2.scaled, df = df.scaled, |
| 601 | 2x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 602 |
) |
|
| 603 | 2x |
indices["ifi.scaled"] <- |
| 604 | 2x |
lav_fit_ifi( |
| 605 | 2x |
X2 = X2.scaled, df = df.scaled, |
| 606 | 2x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 607 |
) |
|
| 608 | 2x |
indices["rni.scaled"] <- |
| 609 | 2x |
lav_fit_rni( |
| 610 | 2x |
X2 = X2.scaled, df = df.scaled, |
| 611 | 2x |
X2.null = X2.null.scaled, df.null = df.null.scaled |
| 612 |
) |
|
| 613 |
} |
|
| 614 | 20x |
if (robust.flag) {
|
| 615 | 5x |
indices["nnfi.robust"] <- |
| 616 | 5x |
lav_fit_nnfi( |
| 617 | 5x |
X2 = XX3, df = df, |
| 618 | 5x |
X2.null = XX3.null, df.null = df.null, |
| 619 | 5x |
c.hat = c.hat, c.hat.null = c.hat.null |
| 620 |
) |
|
| 621 | 5x |
indices["rni.robust"] <- |
| 622 | 5x |
lav_fit_rni( |
| 623 | 5x |
X2 = XX3, df = df, |
| 624 | 5x |
X2.null = XX3.null, df.null = df.null, |
| 625 | 5x |
c.hat = c.hat, c.hat.null = c.hat.null |
| 626 |
) |
|
| 627 |
} |
|
| 628 |
} |
|
| 629 | ||
| 630 |
# return only those that were requested |
|
| 631 | 44x |
indices[fit.measures] |
| 632 |
} |
|
| 633 | ||
| 634 | ||
| 635 |
# new in 0.6-5 |
|
| 636 |
# internal function to check the (external) baseline model, and |
|
| 637 |
# return baseline 'test' list if everything checks out (and NULL otherwise) |
|
| 638 |
lav_fit_measures_check_baseline <- function(fit.indep = NULL, object = NULL, |
|
| 639 |
fit.h1 = NULL) {
|
|
| 640 | ! |
TEST <- NULL |
| 641 | ||
| 642 |
# check if everything is in order |
|
| 643 | ! |
if (inherits(fit.indep, "try-error")) {
|
| 644 | ! |
lav_msg_warn(gettext("baseline model estimation failed"))
|
| 645 | ! |
return(NULL) |
| 646 | ! |
} else if (!inherits(fit.indep, "lavaan")) {
|
| 647 | ! |
lav_msg_warn(gettext( |
| 648 | ! |
"(user-provided) baseline model is not a fitted lavaan object" |
| 649 |
)) |
|
| 650 | ! |
return(NULL) |
| 651 | ! |
} else if (!fit.indep@optim$converged) {
|
| 652 | ! |
lav_msg_warn(gettext("baseline model did not converge"))
|
| 653 | ! |
return(NULL) |
| 654 |
} else {
|
|
| 655 |
# evaluate if estimator/test matches original object |
|
| 656 |
# note: we do not need to check for 'se', as it may be 'none' |
|
| 657 | ! |
sameTest <- all(object@Options$test == fit.indep@Options$test) |
| 658 | ! |
if (!sameTest) {
|
| 659 | ! |
lav_msg_warn(gettextf( |
| 660 | ! |
"Baseline model was using test(s) = %1$s, but original model was using |
| 661 | ! |
test(s) = %2$s. Refitting baseline model!", |
| 662 | ! |
lav_msg_view(fit.indep@Options$test, "none"), |
| 663 | ! |
lav_msg_view(object@Options$test, "none") |
| 664 |
)) |
|
| 665 |
} |
|
| 666 | ! |
sameEstimator <- (object@Options$estimator == |
| 667 | ! |
fit.indep@Options$estimator) |
| 668 | ! |
if (!sameEstimator) {
|
| 669 | ! |
lav_msg_warn(gettextf( |
| 670 | ! |
"Baseline model was using estimator = %1$s, but original model was |
| 671 | ! |
using estimator = %2$s. Refitting baseline model!", |
| 672 | ! |
dQuote(fit.indep@Options$estimator), |
| 673 | ! |
dQuote(object@Options$estimator) |
| 674 |
)) |
|
| 675 |
} |
|
| 676 | ! |
if (!sameTest || !sameEstimator) {
|
| 677 | ! |
lavoptions <- object@Options |
| 678 | ! |
lavoptions$estimator <- object@Options$estimator |
| 679 | ! |
lavoptions$se <- "none" |
| 680 | ! |
lavoptions$baseline <- FALSE |
| 681 | ! |
lavoptions$check.start <- FALSE |
| 682 | ! |
lavoptions$check.post <- FALSE |
| 683 | ! |
lavoptions$check.vcov <- FALSE |
| 684 | ! |
lavoptions$test <- object@Options$test |
| 685 | ! |
fit.indep <- try( |
| 686 | ! |
lavaan(fit.indep, |
| 687 | ! |
slotOptions = lavoptions, |
| 688 | ! |
slotData = object@Data, |
| 689 | ! |
slotSampleStats = object@SampleStats, |
| 690 | ! |
sloth1 = object@h1, |
| 691 | ! |
slotCache = object@Cache, |
| 692 | ! |
verbose = FALSE |
| 693 |
), |
|
| 694 | ! |
silent = TRUE |
| 695 |
) |
|
| 696 |
# try again |
|
| 697 | ! |
TEST <- lav_fit_measures_check_baseline( |
| 698 | ! |
fit.indep = fit.indep, |
| 699 | ! |
object = object |
| 700 |
) |
|
| 701 |
} else {
|
|
| 702 |
# extract what we need |
|
| 703 | ! |
TEST <- fit.indep@test |
| 704 |
} |
|
| 705 |
} # converged lavaan object |
|
| 706 | ||
| 707 | ||
| 708 | ||
| 709 |
# TDJ: Check for user-supplied h1.model (here, the fit.h1= argument) |
|
| 710 |
# Similar to BASELINE model, use the following priority: |
|
| 711 |
# 1. user-provided h1 model |
|
| 712 |
# 2. h1 model in @external slot |
|
| 713 |
# 3. default h1 model (already in @h1 slot, no update necessary) |
|
| 714 |
# FIXME? user-supplied h1 model in object might be in fit.indep, too |
|
| 715 | ||
| 716 | ! |
user_h1_exists <- FALSE |
| 717 |
# 1. user-provided h1 model |
|
| 718 | ! |
if (!is.null(fit.h1)) {
|
| 719 | ! |
stopifnot(inherits(fit.h1, "lavaan")) |
| 720 | ! |
user_h1_exists <- TRUE |
| 721 | ||
| 722 |
# 2. h1 model in @external slot |
|
| 723 | ! |
} else if (!is.null(object@external$h1.model)) {
|
| 724 | ! |
stopifnot(inherits(object@external$h1.model, "lavaan")) |
| 725 | ! |
fit.h1 <- object@external$h1.model |
| 726 | ! |
user_h1_exists <- TRUE |
| 727 |
} |
|
| 728 | ||
| 729 | ! |
if (user_h1_exists) {
|
| 730 |
## update @test slot |
|
| 731 | ! |
TEST <- lav_update_test_custom_h1( |
| 732 | ! |
lav_obj_h0 = fit.indep, |
| 733 | ! |
lav_obj_h1 = fit.h1 |
| 734 | ! |
)@test |
| 735 |
} |
|
| 736 | ||
| 737 | ! |
TEST |
| 738 |
} |
| 1 |
# the multivariate normal distribution |
|
| 2 | ||
| 3 |
# 1) loglikelihood (from raw data, or sample statistics) |
|
| 4 |
# 2) derivatives with respect to mu, Sigma, vech(Sigma) |
|
| 5 |
# 3) casewise scores with respect to mu, vech(Sigma), mu + vech(Sigma) |
|
| 6 |
# 4) hessian mu + vech(Sigma) |
|
| 7 |
# 5) information h0 mu + vech(Sigma) |
|
| 8 |
# 5a: (unit) expected information |
|
| 9 |
# 5b: (unit) observed information |
|
| 10 |
# 5c: (unit) first.order information |
|
| 11 |
# 6) inverted information h0 mu + vech(Sigma) |
|
| 12 |
# 6a: (unit) inverted expected information |
|
| 13 |
# 6b: / |
|
| 14 |
# 6c: / |
|
| 15 |
# 7) ACOV h0 mu + vech(Sigma) |
|
| 16 |
# 7a: 1/N * inverted expected information |
|
| 17 |
# 7b: 1/N * inverted observed information |
|
| 18 |
# 7c: 1/N * inverted first-order information |
|
| 19 |
# 7d: sandwich acov |
|
| 20 | ||
| 21 |
# YR 07 Feb 2016: first version |
|
| 22 |
# YR 24 Mar 2016: added firstorder information, hessian logl |
|
| 23 |
# YR 19 Jan 2017: added lav_mvnorm_inverted_information_expected |
|
| 24 |
# YR 04 Okt 2018: adding wt= argument, and missing meanstructure= |
|
| 25 |
# YR 27 Jun 2018: adding cluster.idx= argument for information_firstorder |
|
| 26 |
# YR 24 Jul 2022: adding correlation= argument for information_expected |
|
| 27 |
# (only for catml; not for correlation = TRUE!) |
|
| 28 | ||
| 29 |
# 0. densities |
|
| 30 |
lav_mvnorm_dmvnorm <- function(Y = NULL, |
|
| 31 |
wt = NULL, |
|
| 32 |
Mu = NULL, |
|
| 33 |
Sigma = NULL, |
|
| 34 |
Sigma.inv = NULL, |
|
| 35 |
Sinv.method = "eigen", |
|
| 36 |
x.idx = integer(0L), |
|
| 37 |
x.mean = NULL, |
|
| 38 |
x.cov = NULL, |
|
| 39 |
log = TRUE) {
|
|
| 40 | ! |
if (is.matrix(Y)) {
|
| 41 | ! |
if (is.null(Mu) && is.null(Sigma) && is.null(Sigma.inv)) {
|
| 42 | ! |
out <- lav_mvnorm_loglik_data_z(Y = Y, casewise = TRUE) |
| 43 |
} else {
|
|
| 44 | ! |
out <- lav_mvnorm_loglik_data( |
| 45 | ! |
Y = Y, Mu = Mu, Sigma = Sigma, |
| 46 | ! |
casewise = TRUE, |
| 47 | ! |
Sinv.method = Sinv.method |
| 48 |
) |
|
| 49 |
} |
|
| 50 |
} else {
|
|
| 51 |
# just one |
|
| 52 | ! |
P <- length(Y) |
| 53 | ! |
LOG.2PI <- log(2 * pi) |
| 54 | ||
| 55 | ! |
if (is.null(Mu) && is.null(Sigma) && is.null(Sigma.inv)) {
|
| 56 |
# mahalanobis distance |
|
| 57 | ! |
DIST <- sum(Y * Y) |
| 58 | ! |
out <- -(P * LOG.2PI + DIST) / 2 |
| 59 |
} else {
|
|
| 60 | ! |
if (is.null(Sigma.inv)) {
|
| 61 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 62 | ! |
S = Sigma, |
| 63 | ! |
logdet = TRUE, Sinv.method = Sinv.method |
| 64 |
) |
|
| 65 | ! |
logdet <- attr(Sigma.inv, "logdet") |
| 66 |
} else {
|
|
| 67 | ! |
logdet <- attr(Sigma.inv, "logdet") |
| 68 | ! |
if (is.null(logdet)) {
|
| 69 |
# compute - ln|Sigma.inv| |
|
| 70 | ! |
ev <- eigen(Sigma.inv, symmetric = TRUE, only.values = TRUE) |
| 71 | ! |
logdet <- -1 * sum(log(ev$values)) |
| 72 |
} |
|
| 73 |
} |
|
| 74 | ||
| 75 |
# mahalanobis distance |
|
| 76 | ! |
Yc <- Y - Mu |
| 77 | ! |
DIST <- sum(Yc %*% Sigma.inv * Yc) |
| 78 | ! |
out <- -(P * LOG.2PI + logdet + DIST) / 2 |
| 79 |
} |
|
| 80 |
} |
|
| 81 | ||
| 82 | ! |
if (!is.null(wt)) {
|
| 83 | ! |
out <- out * wt |
| 84 |
} |
|
| 85 | ||
| 86 |
# x.idx? |
|
| 87 | ! |
if (length(x.idx) > 0L) {
|
| 88 | ! |
if (is.null(Sigma) && is.null(x.cov)) {
|
| 89 | ! |
lav_msg_stop(gettext("when x.idx is not empty, we need Sigma or x.cov"))
|
| 90 |
} |
|
| 91 | ! |
if (is.matrix(Y)) {
|
| 92 | ! |
X <- Y[, x.idx, drop = FALSE] |
| 93 |
} else {
|
|
| 94 | ! |
X <- Y[x.idx] |
| 95 |
} |
|
| 96 | ||
| 97 | ! |
Mu.X <- x.mean |
| 98 | ! |
Sigma.X <- x.cov |
| 99 | ! |
if (is.null(x.mean)) {
|
| 100 | ! |
Mu.X <- as.numeric(Mu)[x.idx] |
| 101 |
} |
|
| 102 | ! |
if (is.null(x.cov)) {
|
| 103 | ! |
Sigma.X <- Sigma[x.idx, x.idx, drop = FALSE] |
| 104 |
} |
|
| 105 | ||
| 106 | ! |
logl.X <- lav_mvnorm_dmvnorm( |
| 107 | ! |
Y = X, wt = wt, Mu = Mu.X, Sigma = Sigma.X, |
| 108 | ! |
Sigma.inv = NULL, |
| 109 | ! |
Sinv.method = Sinv.method, |
| 110 | ! |
x.idx = integer(0L), log = TRUE |
| 111 |
) |
|
| 112 | ||
| 113 |
# subtract logl.X |
|
| 114 | ! |
out <- out - logl.X |
| 115 |
} |
|
| 116 | ||
| 117 | ! |
if (!log) {
|
| 118 | ! |
out <- exp(out) |
| 119 |
} |
|
| 120 | ||
| 121 | ! |
out |
| 122 |
} |
|
| 123 | ||
| 124 |
# 1. likelihood |
|
| 125 | ||
| 126 |
# 1a: input is raw data |
|
| 127 |
# (note casewise = TRUE same as: dmvnorm(Y, mean, sigma, log = TRUE)) |
|
| 128 |
lav_mvnorm_loglik_data <- function(Y = NULL, |
|
| 129 |
wt = NULL, |
|
| 130 |
Mu = NULL, |
|
| 131 |
Sigma = NULL, |
|
| 132 |
x.idx = integer(0L), |
|
| 133 |
x.mean = NULL, |
|
| 134 |
x.cov = NULL, |
|
| 135 |
casewise = FALSE, |
|
| 136 |
Sinv.method = "eigen") {
|
|
| 137 |
# Y must be a matrix (use lav_mvnorm_dmvnorm() for non-matrix input) |
|
| 138 | 708x |
stopifnot(is.matrix(Y)) |
| 139 | ||
| 140 | 708x |
if (!is.null(wt)) {
|
| 141 | ! |
N <- sum(wt) |
| 142 |
} else {
|
|
| 143 | 708x |
N <- NROW(Y) |
| 144 |
} |
|
| 145 | ||
| 146 | 708x |
P <- NCOL(Y) |
| 147 | 708x |
Mu <- as.numeric(Mu) |
| 148 | ||
| 149 | 708x |
if (casewise) {
|
| 150 | 708x |
LOG.2PI <- log(2 * pi) |
| 151 | ||
| 152 |
# invert Sigma |
|
| 153 | 708x |
if (Sinv.method == "chol") {
|
| 154 | ! |
cS <- chol(Sigma) |
| 155 | ! |
icS <- backsolve(cS, diag(P)) |
| 156 | ! |
Yc <- t(t(Y) - Mu) |
| 157 | ! |
DIST <- rowSums((Yc %*% icS)^2) |
| 158 | ! |
logdet <- -2 * sum(log(diag(icS))) |
| 159 |
} else {
|
|
| 160 | 708x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 161 | 708x |
S = Sigma, logdet = TRUE, |
| 162 | 708x |
Sinv.method = Sinv.method |
| 163 |
) |
|
| 164 | 708x |
logdet <- attr(Sigma.inv, "logdet") |
| 165 |
# mahalanobis distance |
|
| 166 | 708x |
Yc <- t(t(Y) - Mu) |
| 167 | 708x |
DIST <- rowSums(Yc %*% Sigma.inv * Yc) |
| 168 |
} |
|
| 169 | ||
| 170 | 708x |
loglik <- -(P * LOG.2PI + logdet + DIST) / 2 |
| 171 | ||
| 172 |
# weights |
|
| 173 | 708x |
if (!is.null(wt)) {
|
| 174 | ! |
loglik <- loglik * wt |
| 175 |
} |
|
| 176 |
} else {
|
|
| 177 |
# invert Sigma |
|
| 178 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 179 | ! |
S = Sigma, logdet = TRUE, |
| 180 | ! |
Sinv.method = Sinv.method |
| 181 |
) |
|
| 182 | ! |
if (!is.null(wt)) {
|
| 183 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 184 | ! |
sample.mean <- out$center |
| 185 | ! |
sample.cov <- out$cov |
| 186 |
} else {
|
|
| 187 | ! |
sample.mean <- base::.colMeans(Y, m = N, n = P) |
| 188 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 189 |
} |
|
| 190 | ! |
loglik <- lav_mvnorm_loglik_samplestats( |
| 191 | ! |
sample.mean = sample.mean, |
| 192 | ! |
sample.cov = sample.cov, |
| 193 | ! |
sample.nobs = N, |
| 194 | ! |
Mu = Mu, |
| 195 | ! |
Sigma.inv = Sigma.inv |
| 196 |
) |
|
| 197 |
} |
|
| 198 | ||
| 199 |
# fixed.x? |
|
| 200 | 708x |
if (length(x.idx) > 0L) {
|
| 201 | ! |
Mu.X <- x.mean |
| 202 | ! |
Sigma.X <- x.cov |
| 203 | ! |
if (is.null(x.mean)) {
|
| 204 | ! |
Mu.X <- as.numeric(Mu)[x.idx] |
| 205 |
} |
|
| 206 | ! |
if (is.null(x.cov)) {
|
| 207 | ! |
Sigma.X <- Sigma[x.idx, x.idx, drop = FALSE] |
| 208 |
} |
|
| 209 | ! |
loglik.x <- lav_mvnorm_loglik_data( |
| 210 | ! |
Y = Y[, x.idx, drop = FALSE], |
| 211 | ! |
wt = wt, Mu = Mu.X, Sigma = Sigma.X, |
| 212 | ! |
x.idx = integer(0L), casewise = casewise, |
| 213 | ! |
Sinv.method = Sinv.method |
| 214 |
) |
|
| 215 |
# subtract logl.X |
|
| 216 | ! |
loglik <- loglik - loglik.x |
| 217 |
} |
|
| 218 | ||
| 219 | 708x |
loglik |
| 220 |
} |
|
| 221 | ||
| 222 | ||
| 223 | ||
| 224 |
# 1b: input are sample statistics (mean, cov, N) only |
|
| 225 |
lav_mvnorm_loglik_samplestats <- function(sample.mean = NULL, |
|
| 226 |
sample.cov = NULL, |
|
| 227 |
sample.nobs = NULL, |
|
| 228 |
Mu = NULL, |
|
| 229 |
Sigma = NULL, |
|
| 230 |
x.idx = integer(0L), |
|
| 231 |
x.mean = NULL, |
|
| 232 |
x.cov = NULL, |
|
| 233 |
Sinv.method = "eigen", |
|
| 234 |
Sigma.inv = NULL) {
|
|
| 235 | 122x |
P <- length(sample.mean) |
| 236 | 122x |
N <- sample.nobs |
| 237 | 122x |
Mu <- as.numeric(Mu) |
| 238 | 122x |
sample.mean <- as.numeric(sample.mean) |
| 239 | 122x |
LOG.2PI <- log(2 * pi) |
| 240 | ||
| 241 | 122x |
if (is.null(Sigma.inv)) {
|
| 242 | 122x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 243 | 122x |
S = Sigma, logdet = TRUE, |
| 244 | 122x |
Sinv.method = Sinv.method |
| 245 |
) |
|
| 246 | 122x |
logdet <- attr(Sigma.inv, "logdet") |
| 247 |
} else {
|
|
| 248 | ! |
logdet <- attr(Sigma.inv, "logdet") |
| 249 | ! |
if (is.null(logdet)) {
|
| 250 |
# compute - ln|Sigma.inv| |
|
| 251 | ! |
ev <- eigen(Sigma.inv, symmetric = TRUE, only.values = TRUE) |
| 252 | ! |
logdet <- -1 * sum(log(ev$values)) |
| 253 |
} |
|
| 254 |
} |
|
| 255 | ||
| 256 |
# tr(Sigma^{-1} %*% S)
|
|
| 257 | 122x |
DIST1 <- sum(Sigma.inv * sample.cov) |
| 258 |
# (ybar - mu)^T %*% Sigma.inv %*% (ybar - mu) |
|
| 259 | 122x |
Diff <- as.numeric(sample.mean - Mu) |
| 260 | 122x |
DIST2 <- sum(as.numeric(crossprod(Diff, Sigma.inv)) * Diff) |
| 261 | ||
| 262 | 122x |
loglik <- -N / 2 * (P * LOG.2PI + logdet + DIST1 + DIST2) |
| 263 | ||
| 264 |
# fixed.x? |
|
| 265 | 122x |
if (length(x.idx) > 0L) {
|
| 266 | 36x |
Mu.X <- x.mean |
| 267 | 36x |
Sigma.X <- x.cov |
| 268 | 36x |
if (is.null(x.mean)) {
|
| 269 | ! |
Mu.X <- Mu[x.idx] |
| 270 |
} |
|
| 271 | 36x |
if (is.null(x.cov)) {
|
| 272 | ! |
Sigma.X <- Sigma[x.idx, x.idx, drop = FALSE] |
| 273 |
} |
|
| 274 | 36x |
sample.mean.x <- sample.mean[x.idx] |
| 275 | 36x |
sample.cov.x <- sample.cov[x.idx, x.idx, drop = FALSE] |
| 276 | 36x |
loglik.x <- |
| 277 | 36x |
lav_mvnorm_loglik_samplestats( |
| 278 | 36x |
sample.mean = sample.mean.x, |
| 279 | 36x |
sample.cov = sample.cov.x, |
| 280 | 36x |
sample.nobs = sample.nobs, |
| 281 | 36x |
Mu = Mu.X, Sigma = Sigma.X, |
| 282 | 36x |
x.idx = integer(0L), |
| 283 | 36x |
Sinv.method = Sinv.method |
| 284 |
) |
|
| 285 |
# subtract logl.X |
|
| 286 | 36x |
loglik <- loglik - loglik.x |
| 287 |
} |
|
| 288 | ||
| 289 | 122x |
loglik |
| 290 |
} |
|
| 291 | ||
| 292 |
# 1c special case: Mu = 0, Sigma = I |
|
| 293 |
lav_mvnorm_loglik_data_z <- function(Y = NULL, |
|
| 294 |
wt = NULL, |
|
| 295 |
casewise = FALSE) {
|
|
| 296 | ! |
if (!is.null(wt)) {
|
| 297 | ! |
N <- sum(wt) |
| 298 |
} else {
|
|
| 299 | ! |
N <- NROW(Y) |
| 300 |
} |
|
| 301 | ||
| 302 | ! |
P <- NCOL(Y) |
| 303 | ! |
LOG.2PI <- log(2 * pi) |
| 304 | ||
| 305 | ! |
if (casewise) {
|
| 306 | ! |
DIST <- rowSums(Y * Y) |
| 307 | ! |
loglik <- -(P * LOG.2PI + DIST) / 2 |
| 308 | ! |
if (!is.null(wt)) {
|
| 309 | ! |
loglik <- loglik * wt |
| 310 |
} |
|
| 311 |
} else {
|
|
| 312 | ! |
if (!is.null(wt)) {
|
| 313 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 314 | ! |
sample.mean <- out$center |
| 315 | ! |
sample.cov <- out$cov |
| 316 |
} else {
|
|
| 317 | ! |
sample.mean <- base::.colMeans(Y, m = N, n = P) |
| 318 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 319 |
} |
|
| 320 | ||
| 321 | ! |
DIST1 <- sum(diag(sample.cov)) |
| 322 | ! |
DIST2 <- sum(sample.mean * sample.mean) |
| 323 | ||
| 324 | ! |
loglik <- -N / 2 * (P * LOG.2PI + DIST1 + DIST2) |
| 325 |
} |
|
| 326 | ||
| 327 | ! |
loglik |
| 328 |
} |
|
| 329 | ||
| 330 | ||
| 331 | ||
| 332 | ||
| 333 | ||
| 334 |
# 2. Derivatives |
|
| 335 | ||
| 336 |
# 2a: derivative logl with respect to mu |
|
| 337 |
lav_mvnorm_dlogl_dmu <- function(Y = NULL, |
|
| 338 |
wt = NULL, |
|
| 339 |
Mu = NULL, |
|
| 340 |
Sigma = NULL, |
|
| 341 |
x.idx = integer(0L), |
|
| 342 |
Sinv.method = "eigen", |
|
| 343 |
Sigma.inv = NULL) {
|
|
| 344 | ! |
Mu <- as.numeric(Mu) |
| 345 | ||
| 346 | ! |
if (is.null(Sigma.inv)) {
|
| 347 |
# invert Sigma |
|
| 348 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 349 | ! |
S = Sigma, logdet = FALSE, |
| 350 | ! |
Sinv.method = Sinv.method |
| 351 |
) |
|
| 352 |
} |
|
| 353 | ||
| 354 |
# substract 'Mu' from Y |
|
| 355 | ! |
Yc <- t(t(Y) - Mu) |
| 356 | ||
| 357 |
# weights |
|
| 358 | ! |
if (!is.null(wt)) {
|
| 359 | ! |
Yc <- Yc * wt |
| 360 |
} |
|
| 361 | ||
| 362 |
# derivative |
|
| 363 | ! |
dmu <- as.numeric(Sigma.inv %*% colSums(Yc)) |
| 364 | ||
| 365 |
# fixed.x? |
|
| 366 | ! |
if (length(x.idx) > 0L) {
|
| 367 | ! |
dmu[x.idx] <- 0 |
| 368 |
} |
|
| 369 | ||
| 370 | ! |
dmu |
| 371 |
} |
|
| 372 | ||
| 373 |
# 2b: derivative logl with respect to Sigma (full matrix, ignoring symmetry) |
|
| 374 |
lav_mvnorm_dlogl_dSigma <- function(Y = NULL, |
|
| 375 |
wt = NULL, |
|
| 376 |
Mu = NULL, |
|
| 377 |
Sigma = NULL, |
|
| 378 |
x.idx = integer(0L), |
|
| 379 |
Sinv.method = "eigen", |
|
| 380 |
Sigma.inv = NULL) {
|
|
| 381 | ! |
if (!is.null(wt)) {
|
| 382 | ! |
N <- sum(wt) |
| 383 |
} else {
|
|
| 384 | ! |
N <- NROW(Y) |
| 385 |
} |
|
| 386 | ||
| 387 | ! |
Mu <- as.numeric(Mu) |
| 388 | ||
| 389 | ! |
if (is.null(Sigma.inv)) {
|
| 390 |
# invert Sigma |
|
| 391 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 392 | ! |
S = Sigma, logdet = FALSE, |
| 393 | ! |
Sinv.method = Sinv.method |
| 394 |
) |
|
| 395 |
} |
|
| 396 | ||
| 397 |
# W.tilde |
|
| 398 | ! |
if (!is.null(wt)) {
|
| 399 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 400 | ! |
SY <- out$cov |
| 401 | ! |
MY <- out$center |
| 402 | ! |
W.tilde <- SY + tcrossprod(MY - Mu) |
| 403 |
} else {
|
|
| 404 |
# substract 'Mu' from Y |
|
| 405 |
# Yc <- t( t(Y) - Mu ) |
|
| 406 |
# W.tilde <- crossprod(Yc) / N |
|
| 407 | ! |
W.tilde <- lav_matrix_cov(Y, Mu = Mu) |
| 408 |
} |
|
| 409 | ||
| 410 |
# derivative |
|
| 411 | ! |
dSigma <- -(N / 2) * (Sigma.inv - (Sigma.inv %*% W.tilde %*% Sigma.inv)) |
| 412 | ||
| 413 |
# fixed.x? |
|
| 414 | ! |
if (length(x.idx) > 0L) {
|
| 415 | ! |
dSigma[x.idx, x.idx] <- 0 |
| 416 |
} |
|
| 417 | ||
| 418 | ! |
dSigma |
| 419 |
} |
|
| 420 | ||
| 421 |
# 2c: derivative logl with respect to vech(Sigma) |
|
| 422 |
lav_mvnorm_dlogl_dvechSigma <- function(Y = NULL, |
|
| 423 |
wt = NULL, |
|
| 424 |
Mu = NULL, |
|
| 425 |
Sigma = NULL, |
|
| 426 |
x.idx = integer(0L), |
|
| 427 |
Sinv.method = "eigen", |
|
| 428 |
Sigma.inv = NULL) {
|
|
| 429 | ! |
if (!is.null(wt)) {
|
| 430 | ! |
N <- sum(wt) |
| 431 |
} else {
|
|
| 432 | ! |
N <- NROW(Y) |
| 433 |
} |
|
| 434 | ||
| 435 | ! |
Mu <- as.numeric(Mu) |
| 436 | ||
| 437 | ! |
if (is.null(Sigma.inv)) {
|
| 438 |
# invert Sigma |
|
| 439 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 440 | ! |
S = Sigma, logdet = FALSE, |
| 441 | ! |
Sinv.method = Sinv.method |
| 442 |
) |
|
| 443 |
} |
|
| 444 | ||
| 445 |
# W.tilde |
|
| 446 | ! |
if (!is.null(wt)) {
|
| 447 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 448 | ! |
SY <- out$cov |
| 449 | ! |
MY <- out$center |
| 450 | ! |
W.tilde <- SY + tcrossprod(MY - Mu) |
| 451 |
} else {
|
|
| 452 | ! |
W.tilde <- lav_matrix_cov(Y, Mu = Mu) |
| 453 |
} |
|
| 454 | ||
| 455 |
# derivative (avoiding kronecker product) |
|
| 456 | ! |
dSigma <- -(N / 2) * (Sigma.inv - (Sigma.inv %*% W.tilde %*% Sigma.inv)) |
| 457 | ||
| 458 |
# fixed.x? |
|
| 459 | ! |
if (length(x.idx) > 0L) {
|
| 460 | ! |
dSigma[x.idx, x.idx] <- 0 |
| 461 |
} |
|
| 462 | ||
| 463 |
# vech |
|
| 464 | ! |
dvechSigma <- as.numeric(lav_matrix_duplication_pre( |
| 465 | ! |
as.matrix(lav_matrix_vec(dSigma)) |
| 466 |
)) |
|
| 467 | ||
| 468 | ! |
dvechSigma |
| 469 |
} |
|
| 470 | ||
| 471 |
# 2d: : derivative logl with respect to Mu and vech(Sigma) |
|
| 472 |
lav_mvnorm_dlogl_dmu_dvechSigma <- function(Y = NULL, |
|
| 473 |
wt = NULL, |
|
| 474 |
Mu = NULL, |
|
| 475 |
Sigma = NULL, |
|
| 476 |
x.idx = integer(0L), |
|
| 477 |
Sinv.method = "eigen", |
|
| 478 |
Sigma.inv = NULL) {
|
|
| 479 | ! |
if (!is.null(wt)) {
|
| 480 | ! |
N <- sum(wt) |
| 481 |
} else {
|
|
| 482 | ! |
N <- NROW(Y) |
| 483 |
} |
|
| 484 | ||
| 485 | ! |
Mu <- as.numeric(Mu) |
| 486 | ||
| 487 | ! |
if (is.null(Sigma.inv)) {
|
| 488 |
# invert Sigma |
|
| 489 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 490 | ! |
S = Sigma, logdet = FALSE, |
| 491 | ! |
Sinv.method = Sinv.method |
| 492 |
) |
|
| 493 |
} |
|
| 494 | ||
| 495 |
# substract Mu |
|
| 496 | ! |
Yc <- t(t(Y) - Mu) |
| 497 | ||
| 498 |
# W.tilde |
|
| 499 | ! |
if (!is.null(wt)) {
|
| 500 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 501 | ! |
SY <- out$cov |
| 502 | ! |
MY <- out$center |
| 503 | ! |
W.tilde <- SY + tcrossprod(MY - Mu) |
| 504 | ! |
dmu <- as.numeric(Sigma.inv %*% colSums(Yc * wt)) |
| 505 |
} else {
|
|
| 506 | ! |
W.tilde <- lav_matrix_cov(Y, Mu = Mu) |
| 507 | ! |
dmu <- as.numeric(Sigma.inv %*% colSums(Yc)) |
| 508 |
} |
|
| 509 | ||
| 510 |
# derivative (avoiding kronecker product) |
|
| 511 | ! |
dSigma <- -(N / 2) * (Sigma.inv - (Sigma.inv %*% W.tilde %*% Sigma.inv)) |
| 512 | ||
| 513 |
# fixed.x? |
|
| 514 | ! |
if (length(x.idx) > 0L) {
|
| 515 | ! |
dSigma[x.idx, x.idx] <- 0 |
| 516 | ! |
dmu[x.idx] <- 0 |
| 517 |
} |
|
| 518 | ||
| 519 |
# vech |
|
| 520 | ! |
dvechSigma <- as.numeric(lav_matrix_duplication_pre( |
| 521 | ! |
as.matrix(lav_matrix_vec(dSigma)) |
| 522 |
)) |
|
| 523 | ||
| 524 | ! |
c(dmu, dvechSigma) |
| 525 |
} |
|
| 526 | ||
| 527 |
# 3. Casewise scores |
|
| 528 | ||
| 529 |
# 3a: casewise scores with respect to mu |
|
| 530 |
lav_mvnorm_scores_mu <- function(Y = NULL, |
|
| 531 |
wt = NULL, |
|
| 532 |
Mu = NULL, |
|
| 533 |
x.idx = integer(0L), |
|
| 534 |
Sigma = NULL, |
|
| 535 |
Sinv.method = "eigen", |
|
| 536 |
Sigma.inv = NULL) {
|
|
| 537 | ! |
Mu <- as.numeric(Mu) |
| 538 | ||
| 539 | ! |
if (is.null(Sigma.inv)) {
|
| 540 |
# invert Sigma |
|
| 541 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 542 | ! |
S = Sigma, logdet = FALSE, |
| 543 | ! |
Sinv.method = Sinv.method |
| 544 |
) |
|
| 545 |
} |
|
| 546 | ||
| 547 |
# substract Mu |
|
| 548 | ! |
Yc <- t(t(Y) - Mu) |
| 549 | ||
| 550 |
# postmultiply with Sigma.inv |
|
| 551 | ! |
SC <- Yc %*% Sigma.inv |
| 552 | ||
| 553 |
# weights |
|
| 554 | ! |
if (!is.null(wt)) {
|
| 555 | ! |
SC <- SC * wt |
| 556 |
} |
|
| 557 | ||
| 558 |
# fixed.x? |
|
| 559 | ! |
if (length(x.idx) > 0L) {
|
| 560 | ! |
SC[, x.idx] <- 0 |
| 561 |
} |
|
| 562 | ||
| 563 | ! |
SC |
| 564 |
} |
|
| 565 | ||
| 566 |
# 3b: casewise scores with respect to vech(Sigma) |
|
| 567 |
lav_mvnorm_scores_vech_sigma <- function(Y = NULL, |
|
| 568 |
wt = NULL, |
|
| 569 |
Mu = NULL, |
|
| 570 |
Sigma = NULL, |
|
| 571 |
x.idx = integer(0L), |
|
| 572 |
Sinv.method = "eigen", |
|
| 573 |
Sigma.inv = NULL) {
|
|
| 574 | ! |
P <- NCOL(Y) |
| 575 | ! |
Mu <- as.numeric(Mu) |
| 576 | ||
| 577 | ! |
if (is.null(Sigma.inv)) {
|
| 578 |
# invert Sigma |
|
| 579 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 580 | ! |
S = Sigma, logdet = FALSE, |
| 581 | ! |
Sinv.method = Sinv.method |
| 582 |
) |
|
| 583 |
} |
|
| 584 | ||
| 585 |
# vech(Sigma.inv) |
|
| 586 | ! |
isigma <- lav_matrix_vech(Sigma.inv) |
| 587 | ||
| 588 |
# substract Mu |
|
| 589 | ! |
Yc <- t(t(Y) - Mu) |
| 590 | ||
| 591 |
# postmultiply with Sigma.inv |
|
| 592 | ! |
Yc <- Yc %*% Sigma.inv |
| 593 | ||
| 594 |
# tcrossprod |
|
| 595 | ! |
idx1 <- lav_matrix_vech_col_idx(P) |
| 596 | ! |
idx2 <- lav_matrix_vech_row_idx(P) |
| 597 | ! |
Z <- Yc[, idx1] * Yc[, idx2] |
| 598 | ||
| 599 |
# substract isigma from each row |
|
| 600 | ! |
SC <- t(t(Z) - isigma) |
| 601 | ||
| 602 |
# adjust for vech |
|
| 603 | ! |
SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2 |
| 604 | ||
| 605 |
# fixed.x? |
|
| 606 | ! |
if (length(x.idx) > 0L) {
|
| 607 | ! |
SC[, lav_matrix_vech_which_idx(n = P, idx = x.idx)] <- 0 |
| 608 |
} |
|
| 609 | ||
| 610 |
# weights |
|
| 611 | ! |
if (!is.null(wt)) {
|
| 612 | ! |
SC <- SC * wt |
| 613 |
} |
|
| 614 | ||
| 615 | ! |
SC |
| 616 |
} |
|
| 617 | ||
| 618 |
# 3c: casewise scores with respect to mu + vech(Sigma) |
|
| 619 |
lav_mvnorm_scores_mu_vech_sigma <- function(Y = NULL, |
|
| 620 |
wt = NULL, |
|
| 621 |
Mu = NULL, |
|
| 622 |
Sigma = NULL, |
|
| 623 |
x.idx = integer(0L), |
|
| 624 |
Sinv.method = "eigen", |
|
| 625 |
Sigma.inv = NULL) {
|
|
| 626 | 1x |
P <- NCOL(Y) |
| 627 | 1x |
Mu <- as.numeric(Mu) |
| 628 | ||
| 629 | 1x |
if (is.null(Sigma.inv)) {
|
| 630 |
# invert Sigma |
|
| 631 | 1x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 632 | 1x |
S = Sigma, logdet = FALSE, |
| 633 | 1x |
Sinv.method = Sinv.method |
| 634 |
) |
|
| 635 |
} |
|
| 636 | ||
| 637 |
# vech(Sigma.inv) |
|
| 638 | 1x |
isigma <- lav_matrix_vech(Sigma.inv) |
| 639 | ||
| 640 |
# substract Mu |
|
| 641 | 1x |
Yc <- t(t(Y) - Mu) |
| 642 | ||
| 643 |
# postmultiply with Sigma.inv |
|
| 644 | 1x |
Yc <- Yc %*% Sigma.inv |
| 645 | ||
| 646 |
# tcrossprod |
|
| 647 | 1x |
idx1 <- lav_matrix_vech_col_idx(P) |
| 648 | 1x |
idx2 <- lav_matrix_vech_row_idx(P) |
| 649 | 1x |
Z <- Yc[, idx1] * Yc[, idx2] |
| 650 | ||
| 651 |
# substract isigma from each row |
|
| 652 | 1x |
SC <- t(t(Z) - isigma) |
| 653 | ||
| 654 |
# adjust for lav_matrix_duplication_pre (not vech!) |
|
| 655 | 1x |
SC[, lav_matrix_diagh_idx(P)] <- SC[, lav_matrix_diagh_idx(P)] / 2 |
| 656 | ||
| 657 |
# fixed.x? |
|
| 658 | 1x |
if (length(x.idx) > 0L) {
|
| 659 | ! |
Yc[, x.idx] <- 0 |
| 660 | ! |
SC[, lav_matrix_vech_which_idx(n = P, idx = x.idx)] <- 0 |
| 661 |
} |
|
| 662 | ||
| 663 | 1x |
out <- cbind(Yc, SC) |
| 664 | ||
| 665 |
# weights |
|
| 666 | 1x |
if (!is.null(wt)) {
|
| 667 | ! |
out <- out * wt |
| 668 |
} |
|
| 669 | ||
| 670 | 1x |
out |
| 671 |
} |
|
| 672 | ||
| 673 | ||
| 674 |
# 4. hessian of logl |
|
| 675 | ||
| 676 |
# 4a: hessian logl Mu and vech(Sigma) from raw data |
|
| 677 |
lav_mvnorm_logl_hessian_data <- function(Y = NULL, |
|
| 678 |
wt = NULL, |
|
| 679 |
Mu = NULL, |
|
| 680 |
Sigma = NULL, |
|
| 681 |
x.idx = integer(0L), |
|
| 682 |
Sinv.method = "eigen", |
|
| 683 |
Sigma.inv = NULL, |
|
| 684 |
meanstructure = TRUE) {
|
|
| 685 | ! |
if (!is.null(wt)) {
|
| 686 | ! |
N <- sum(wt) |
| 687 |
} else {
|
|
| 688 | ! |
N <- NROW(Y) |
| 689 |
} |
|
| 690 | ||
| 691 |
# observed information |
|
| 692 | ! |
observed <- lav_mvnorm_information_observed_data( |
| 693 | ! |
Y = Y, wt = wt, Mu = Mu, |
| 694 | ! |
Sigma = Sigma, x.idx = x.idx, |
| 695 | ! |
Sinv.method = Sinv.method, Sigma.inv = Sigma.inv, |
| 696 | ! |
meanstructure = meanstructure |
| 697 |
) |
|
| 698 | ||
| 699 | ! |
-N * observed |
| 700 |
} |
|
| 701 | ||
| 702 |
# 4b: hessian Mu and vech(Sigma) from samplestats |
|
| 703 |
lav_mvnorm_logl_hessian_samplestats <- |
|
| 704 |
function(sample.mean = NULL, |
|
| 705 |
sample.cov = NULL, |
|
| 706 |
sample.nobs = NULL, |
|
| 707 |
Mu = NULL, |
|
| 708 |
Sigma = NULL, |
|
| 709 |
x.idx = integer(0L), |
|
| 710 |
Sinv.method = "eigen", |
|
| 711 |
Sigma.inv = NULL, |
|
| 712 |
meanstructure = TRUE) {
|
|
| 713 | ! |
N <- sample.nobs |
| 714 | ||
| 715 |
# observed information |
|
| 716 | ! |
observed <- lav_mvnorm_information_observed_samplestats( |
| 717 | ! |
sample.mean = sample.mean, sample.cov = sample.cov, |
| 718 | ! |
Mu = Mu, Sigma = Sigma, |
| 719 | ! |
x.idx = x.idx, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv, |
| 720 | ! |
meanstructure = meanstructure |
| 721 |
) |
|
| 722 | ||
| 723 | ! |
-N * observed |
| 724 |
} |
|
| 725 | ||
| 726 |
# 5) Information h0 |
|
| 727 | ||
| 728 |
# 5a: unit expected information h0 Mu and vech(Sigma) |
|
| 729 |
lav_mvnorm_information_expected <- function(Y = NULL, # unused! |
|
| 730 |
wt = NULL, # unused! |
|
| 731 |
Mu = NULL, # unused! |
|
| 732 |
Sigma = NULL, |
|
| 733 |
x.idx = integer(0L), |
|
| 734 |
Sinv.method = "eigen", |
|
| 735 |
Sigma.inv = NULL, |
|
| 736 |
meanstructure = TRUE, |
|
| 737 |
correlation = FALSE) {
|
|
| 738 | 70x |
if (is.null(Sigma.inv)) {
|
| 739 |
# invert Sigma |
|
| 740 | 70x |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 741 | 70x |
S = Sigma, logdet = FALSE, |
| 742 | 70x |
Sinv.method = Sinv.method |
| 743 |
) |
|
| 744 |
} |
|
| 745 | ||
| 746 |
# if (lav_use_lavaanC()) {
|
|
| 747 |
# if (correlation) {
|
|
| 748 |
# I22 <- lavaanC::m_kronecker_dup_cor_pre_post(Sigma.inv, |
|
| 749 |
# multiplicator = 0.5) |
|
| 750 |
# } else {
|
|
| 751 |
# I22 <- lavaanC::m_kronecker_dup_pre_post(Sigma.inv, multiplicator = 0.5) |
|
| 752 |
# } |
|
| 753 |
# } else {
|
|
| 754 | 70x |
if (correlation) {
|
| 755 | ! |
I22 <- 0.5 * lav_matrix_duplication_cor_pre_post(Sigma.inv %x% Sigma.inv) |
| 756 |
} else {
|
|
| 757 | 70x |
I22 <- 0.5 * lav_matrix_duplication_pre_post(Sigma.inv %x% Sigma.inv) |
| 758 |
} |
|
| 759 |
# } |
|
| 760 | ||
| 761 |
# fixed.x? |
|
| 762 | 70x |
if (length(x.idx) > 0L) {
|
| 763 | 18x |
pstar.x <- lav_matrix_vech_which_idx( |
| 764 | 18x |
n = NCOL(Sigma.inv), idx = x.idx |
| 765 |
) |
|
| 766 | 18x |
I22[pstar.x, ] <- 0 |
| 767 | 18x |
I22[, pstar.x] <- 0 |
| 768 |
} |
|
| 769 | ||
| 770 | 70x |
if (meanstructure) {
|
| 771 | 26x |
I11 <- Sigma.inv |
| 772 |
# fixed.x? |
|
| 773 | 26x |
if (length(x.idx) > 0L) {
|
| 774 | 6x |
I11[x.idx, ] <- 0 |
| 775 | 6x |
I11[, x.idx] <- 0 |
| 776 |
} |
|
| 777 | 26x |
out <- lav_matrix_bdiag(I11, I22) |
| 778 |
} else {
|
|
| 779 | 44x |
out <- I22 |
| 780 |
} |
|
| 781 | ||
| 782 | 70x |
out |
| 783 |
} |
|
| 784 | ||
| 785 |
# 5b: unit observed information h0 |
|
| 786 |
lav_mvnorm_information_observed_data <- function(Y = NULL, |
|
| 787 |
wt = NULL, |
|
| 788 |
Mu = NULL, |
|
| 789 |
Sigma = NULL, |
|
| 790 |
x.idx = integer(0L), |
|
| 791 |
Sinv.method = "eigen", |
|
| 792 |
Sigma.inv = NULL, |
|
| 793 |
meanstructure = TRUE) {
|
|
| 794 | ! |
if (!is.null(wt)) {
|
| 795 | ! |
N <- sum(wt) |
| 796 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 797 | ! |
sample.cov <- out$cov |
| 798 | ! |
sample.mean <- out$center |
| 799 |
} else {
|
|
| 800 | ! |
N <- NROW(Y) |
| 801 |
# sample statistics |
|
| 802 | ! |
sample.mean <- colMeans(Y) |
| 803 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 804 |
} |
|
| 805 | ||
| 806 | ! |
lav_mvnorm_information_observed_samplestats( |
| 807 | ! |
sample.mean = sample.mean, |
| 808 | ! |
sample.cov = sample.cov, Mu = Mu, Sigma = Sigma, |
| 809 | ! |
x.idx = x.idx, Sinv.method = Sinv.method, Sigma.inv = Sigma.inv, |
| 810 | ! |
meanstructure = meanstructure |
| 811 |
) |
|
| 812 |
} |
|
| 813 | ||
| 814 |
# 5b-bis: observed information h0 from sample statistics |
|
| 815 |
lav_mvnorm_information_observed_samplestats <- function( |
|
| 816 |
sample.mean = NULL, |
|
| 817 |
sample.cov = NULL, |
|
| 818 |
Mu = NULL, |
|
| 819 |
Sigma = NULL, |
|
| 820 |
x.idx = integer(0L), |
|
| 821 |
Sinv.method = "eigen", |
|
| 822 |
Sigma.inv = NULL, |
|
| 823 |
meanstructure = TRUE) {
|
|
| 824 | ||
| 825 | ! |
sample.mean <- as.numeric(sample.mean) |
| 826 | ! |
Mu <- as.numeric(Mu) |
| 827 | ||
| 828 | ! |
if (is.null(Sigma.inv)) {
|
| 829 |
# invert Sigma |
|
| 830 | ! |
Sigma.inv <- lav_matrix_symmetric_inverse( |
| 831 | ! |
S = Sigma, logdet = FALSE, |
| 832 | ! |
Sinv.method = Sinv.method |
| 833 |
) |
|
| 834 |
} |
|
| 835 | ||
| 836 | ! |
W.tilde <- sample.cov + tcrossprod(sample.mean - Mu) |
| 837 | ||
| 838 | ! |
if (meanstructure) {
|
| 839 | ! |
I11 <- Sigma.inv |
| 840 | ! |
I21 <- lav_matrix_duplication_pre((Sigma.inv %*% |
| 841 | ! |
(sample.mean - Mu)) %x% Sigma.inv) |
| 842 | ! |
I12 <- t(I21) |
| 843 |
} |
|
| 844 | ||
| 845 | ! |
AAA <- Sigma.inv %*% (2 * W.tilde - Sigma) %*% Sigma.inv |
| 846 |
# if (lav_use_lavaanC()) {
|
|
| 847 |
# I22 <- lavaanC::m_kronecker_dup_pre_post(Sigma.inv, AAA, 0.5) |
|
| 848 |
# } else {
|
|
| 849 | ! |
I22 <- (1 / 2) * lav_matrix_duplication_pre_post(Sigma.inv %x% AAA) |
| 850 |
# } |
|
| 851 | ||
| 852 | ! |
if (meanstructure) {
|
| 853 | ! |
out <- rbind( |
| 854 | ! |
cbind(I11, I12), |
| 855 | ! |
cbind(I21, I22) |
| 856 |
) |
|
| 857 |
} else {
|
|
| 858 | ! |
out <- I22 |
| 859 |
} |
|
| 860 | ||
| 861 |
# fixed.x? |
|
| 862 | ! |
if (length(x.idx) > 0L) {
|
| 863 | ! |
not.x <- lav_matrix_vech_which_idx( |
| 864 | ! |
n = NCOL(Sigma.inv), idx = x.idx, |
| 865 | ! |
add.idx.at.start = meanstructure |
| 866 |
) |
|
| 867 | ! |
out[, not.x] <- 0 |
| 868 | ! |
out[not.x, ] <- 0 |
| 869 |
} |
|
| 870 | ||
| 871 | ! |
out |
| 872 |
} |
|
| 873 | ||
| 874 |
# 5c: unit first-order information h0 |
|
| 875 |
lav_mvnorm_information_firstorder <- function(Y = NULL, |
|
| 876 |
wt = NULL, |
|
| 877 |
cluster.idx = NULL, |
|
| 878 |
Mu = NULL, |
|
| 879 |
Sigma = NULL, |
|
| 880 |
x.idx = integer(0L), |
|
| 881 |
Sinv.method = "eigen", |
|
| 882 |
Sigma.inv = NULL, |
|
| 883 |
meanstructure = TRUE) {
|
|
| 884 | 1x |
if (!is.null(wt)) {
|
| 885 | ! |
N <- sum(wt) |
| 886 |
} else {
|
|
| 887 | 1x |
N <- NROW(Y) |
| 888 |
} |
|
| 889 | ||
| 890 | 1x |
if (meanstructure) {
|
| 891 | 1x |
SC <- lav_mvnorm_scores_mu_vech_sigma( |
| 892 | 1x |
Y = Y, wt = wt, |
| 893 | 1x |
Mu = Mu, Sigma = Sigma, x.idx = x.idx, |
| 894 | 1x |
Sinv.method = Sinv.method, Sigma.inv = Sigma.inv |
| 895 |
) |
|
| 896 |
} else {
|
|
| 897 |
# the caller should use Mu = sample.mean |
|
| 898 | ! |
SC <- lav_mvnorm_scores_vech_sigma( |
| 899 | ! |
Y = Y, wt = wt, |
| 900 | ! |
Mu = Mu, Sigma = Sigma, |
| 901 | ! |
Sinv.method = Sinv.method, Sigma.inv = Sigma.inv |
| 902 |
) |
|
| 903 |
} |
|
| 904 | ||
| 905 |
# handle clustering |
|
| 906 | 1x |
if (!is.null(cluster.idx)) {
|
| 907 |
# take the sum within each cluster |
|
| 908 | ! |
SC <- rowsum(SC, group = cluster.idx, reorder = FALSE, na.rm = TRUE) |
| 909 | ||
| 910 |
# lower bias if number of clusters is not very high |
|
| 911 |
# FIXME: reference? |
|
| 912 | ! |
nC <- nrow(SC) |
| 913 | ! |
correction.factor <- nC / (nC - 1) |
| 914 | ! |
SC <- SC * sqrt(correction.factor) |
| 915 |
} |
|
| 916 | ||
| 917 |
# unit information |
|
| 918 | 1x |
out <- crossprod(SC) / N |
| 919 | ||
| 920 | 1x |
out |
| 921 |
} |
|
| 922 | ||
| 923 | ||
| 924 |
# 6: inverted information h0 |
|
| 925 | ||
| 926 |
# 6a: inverted unit expected information h0 Mu and vech(Sigma) |
|
| 927 |
# |
|
| 928 |
# Note: this is the same as lav_samplestats_Gamma_NT() |
|
| 929 |
# but where COV=Sigma and MEAN=Mu |
|
| 930 |
# |
|
| 931 |
lav_mvnorm_inverted_information_expected <- function(Y = NULL, # unused! |
|
| 932 |
wt = NULL, # unused! |
|
| 933 |
Mu = NULL, # unused! |
|
| 934 |
Sigma = NULL, |
|
| 935 |
x.idx = integer(0L), |
|
| 936 |
meanstructure = TRUE) {
|
|
| 937 | ! |
if (length(x.idx) > 0L) {
|
| 938 |
# cov(Y|X) = A - B C^{-1} B'
|
|
| 939 |
# where A = cov(Y), B = cov(Y,X), C = cov(X) |
|
| 940 | ! |
A <- Sigma[-x.idx, -x.idx, drop = FALSE] |
| 941 | ! |
B <- Sigma[-x.idx, x.idx, drop = FALSE] |
| 942 | ! |
C <- Sigma[ x.idx, x.idx, drop = FALSE] |
| 943 | ! |
YbarX <- A - B %*% solve(C, t(B)) |
| 944 | ||
| 945 |
# reinsert YbarX in Y+X (residual) covariance matrix |
|
| 946 | ! |
YbarX.aug <- matrix(0, nrow = NROW(Sigma), ncol = NCOL(Sigma)) |
| 947 | ! |
YbarX.aug[-x.idx, -x.idx] <- YbarX |
| 948 | ||
| 949 |
# take difference |
|
| 950 | ! |
R <- Sigma - YbarX.aug |
| 951 | ||
| 952 |
# if (lav_use_lavaanC()) {
|
|
| 953 |
# SS <- lavaanC::m_kronecker_dup_ginv_pre_post(Sigma, multiplicator = 2.0) |
|
| 954 |
# RR <- lavaanC::m_kronecker_dup_ginv_pre_post(R, multiplicator = 2.0) |
|
| 955 |
# } else {
|
|
| 956 | ! |
SS <- 2 * lav_matrix_duplication_ginv_pre_post(Sigma %x% Sigma) |
| 957 | ! |
RR <- 2 * lav_matrix_duplication_ginv_pre_post(R %x% R) |
| 958 |
# } |
|
| 959 | ! |
I22 <- SS - RR |
| 960 | ||
| 961 | ! |
if (meanstructure) {
|
| 962 | ! |
I11 <- YbarX.aug |
| 963 | ! |
out <- lav_matrix_bdiag(I11, I22) |
| 964 |
} else {
|
|
| 965 | ! |
out <- I22 |
| 966 |
} |
|
| 967 |
} else {
|
|
| 968 |
# if (lav_use_lavaanC()) {
|
|
| 969 |
# I22 <- lavaanC::m_kronecker_dup_ginv_pre_post(Sigma, multiplicator = 2.0) |
|
| 970 |
# } else {
|
|
| 971 | ! |
I22 <- 2 * lav_matrix_duplication_ginv_pre_post(Sigma %x% Sigma) |
| 972 |
# } |
|
| 973 | ! |
if (meanstructure) {
|
| 974 | ! |
I11 <- Sigma |
| 975 | ! |
out <- lav_matrix_bdiag(I11, I22) |
| 976 |
} else {
|
|
| 977 | ! |
out <- I22 |
| 978 |
} |
|
| 979 |
} |
|
| 980 | ||
| 981 | ! |
out |
| 982 |
} |
|
| 983 | ||
| 984 |
# 6b: inverted unit observed information h0 |
|
| 985 | ||
| 986 |
# one could use the inverse of a partitioned matrix, but that does not |
|
| 987 |
# seem to help much... unless we can find an expression for solve(I22) |
|
| 988 | ||
| 989 |
# 6c: inverted unit first-order information h0 |
|
| 990 |
# / |
|
| 991 | ||
| 992 | ||
| 993 |
# 7) ACOV h0 mu + vech(Sigma) |
|
| 994 |
# not implemented, as too trivial |
|
| 995 | ||
| 996 |
# 7a: 1/N * inverted expected information |
|
| 997 | ||
| 998 |
# 7b: 1/N * inverted observed information |
|
| 999 | ||
| 1000 |
# 7c: 1/N * inverted first-order information |
|
| 1001 | ||
| 1002 |
# 7d: sandwich acov |
| 1 |
# the weighted bivariate linear regression model |
|
| 2 |
# YR 14 March 2020 ((replacing the old lav_pearson.R + lav_binorm.R routines) |
|
| 3 |
# |
|
| 4 |
# - bivariate standard normal |
|
| 5 |
# - pearson correlation |
|
| 6 |
# - bivariate linear regression |
|
| 7 |
# - using sampling weights wt |
|
| 8 | ||
| 9 | ||
| 10 |
# density of a bivariate __standard__ normal |
|
| 11 |
lav_dbinorm <- lav_dbinorm <- function(u, v, rho, force.zero = FALSE) {
|
|
| 12 |
# dirty hack to handle extreme large values for rho |
|
| 13 |
# note that u, v, and rho are vectorized! |
|
| 14 | 296x |
RHO.limit <- 0.9999 |
| 15 | 296x |
abs.rho <- abs(rho) |
| 16 | 296x |
idx <- which(abs.rho > RHO.limit) |
| 17 | 296x |
if (length(idx) > 0L) {
|
| 18 | ! |
rho[idx] <- sign(rho[idx]) * RHO.limit |
| 19 |
} |
|
| 20 | ||
| 21 | 296x |
R <- 1 - rho * rho |
| 22 | 296x |
out <- 1 / (2 * pi * sqrt(R)) * exp(-0.5 * (u * u - 2 * rho * u * v + v * v) / R) |
| 23 | ||
| 24 |
# if abs(u) or abs(v) are very large (say, >10), set result equal |
|
| 25 |
# to exactly zero |
|
| 26 | 296x |
idx <- which(abs(u) > 10 | abs(v) > 10) |
| 27 | 296x |
if (length(idx) > 0L && force.zero) {
|
| 28 | ! |
out[idx] <- 0 |
| 29 |
} |
|
| 30 | ||
| 31 | 296x |
out |
| 32 |
} |
|
| 33 | ||
| 34 |
# partial derivative - rho |
|
| 35 |
lav_dbinorm_drho <- function(u, v, rho) {
|
|
| 36 | ! |
R <- 1 - rho * rho |
| 37 | ! |
lav_dbinorm(u, v, rho) * (u * v * R - rho * (u * u - 2 * rho * u * v + v * v) + rho * R) / (R * R) |
| 38 |
} |
|
| 39 | ||
| 40 |
# partial derivative - u |
|
| 41 |
lav_dbinorm_du <- function(u, v, rho) {
|
|
| 42 | ! |
R <- 1 - rho * rho |
| 43 | ! |
-lav_dbinorm(u, v, rho) * (u - rho * v) / R |
| 44 |
} |
|
| 45 | ||
| 46 |
# partial derivative - v |
|
| 47 |
lav_dbinorm_dv <- function(u, v, rho) {
|
|
| 48 | ! |
R <- 1 - rho * rho |
| 49 | ! |
-lav_dbinorm(u, v, rho) * (v - rho * u) / R |
| 50 |
} |
|
| 51 | ||
| 52 | ||
| 53 |
# CDF of bivariate standard normal |
|
| 54 |
# function pbinorm(upper.x, upper.y, rho) |
|
| 55 | ||
| 56 |
# partial derivative pbinorm - upper.x |
|
| 57 |
lav_pbinorm_dupperx <- function(upper.x, upper.y, rho = 0.0) {
|
|
| 58 | ! |
R <- 1 - rho * rho |
| 59 | ! |
dnorm(upper.x) * pnorm((upper.y - rho * upper.x) / sqrt(R)) |
| 60 |
} |
|
| 61 | ||
| 62 |
lav_pbinorm_duppery <- function(upper.x, upper.y, rho = 0.0) {
|
|
| 63 | ! |
R <- 1 - rho * rho |
| 64 | ! |
dnorm(upper.y) * pnorm((upper.x - rho * upper.y) / sqrt(R)) |
| 65 |
} |
|
| 66 | ||
| 67 |
lav_pbinorm_drho <- function(upper.x, upper.y, rho = 0.0) {
|
|
| 68 | ! |
lav_dbinorm(upper.x, upper.y, rho) |
| 69 |
} |
|
| 70 | ||
| 71 | ||
| 72 |
# switch between pbivnorm, mnormt, ... |
|
| 73 |
pbinorm <- function(upper.x = NULL, upper.y = NULL, rho = 0.0, |
|
| 74 |
lower.x = -Inf, lower.y = -Inf, check = FALSE) {
|
|
| 75 | 96x |
pbinorm2( |
| 76 | 96x |
upper.x = upper.x, upper.y = upper.y, rho = rho, |
| 77 | 96x |
lower.x = lower.x, lower.y = lower.y, check = check |
| 78 |
) |
|
| 79 |
} |
|
| 80 | ||
| 81 |
# using vectorized version (a la pbivnorm) |
|
| 82 |
pbinorm2 <- function(upper.x = NULL, upper.y = NULL, rho = 0.0, |
|
| 83 |
lower.x = -Inf, lower.y = -Inf, check = FALSE) {
|
|
| 84 | 96x |
N <- length(upper.x) |
| 85 | 96x |
stopifnot(length(upper.y) == N) |
| 86 | 96x |
if (N > 1L) {
|
| 87 | 96x |
if (length(rho) == 1L) {
|
| 88 | 96x |
rho <- rep(rho, N) |
| 89 |
} |
|
| 90 | 96x |
if (length(lower.x) == 1L) {
|
| 91 | ! |
lower.x <- rep(lower.x, N) |
| 92 |
} |
|
| 93 | 96x |
if (length(lower.y) == 1L) {
|
| 94 | ! |
lower.y <- rep(lower.y, N) |
| 95 |
} |
|
| 96 |
} |
|
| 97 | ||
| 98 | 96x |
upper.only <- all(lower.x == -Inf & lower.y == -Inf) |
| 99 | 96x |
if (upper.only) {
|
| 100 | ! |
upper.x[upper.x == +Inf] <- exp(10) # better pnorm? |
| 101 | ! |
upper.y[upper.y == +Inf] <- exp(10) |
| 102 | ! |
upper.x[upper.x == -Inf] <- -exp(10) |
| 103 | ! |
upper.y[upper.y == -Inf] <- -exp(10) |
| 104 | ! |
res <- pbivnorm(upper.x, upper.y, rho = rho) |
| 105 |
} else {
|
|
| 106 |
# pbivnorm does not handle -Inf well... |
|
| 107 | 96x |
lower.x[lower.x == -Inf] <- -exp(10) |
| 108 | 96x |
lower.y[lower.y == -Inf] <- -exp(10) |
| 109 | 96x |
res <- pbivnorm(upper.x, upper.y, rho = rho) - |
| 110 | 96x |
pbivnorm(lower.x, upper.y, rho = rho) - |
| 111 | 96x |
pbivnorm(upper.x, lower.y, rho = rho) + |
| 112 | 96x |
pbivnorm(lower.x, lower.y, rho = rho) |
| 113 |
} |
|
| 114 | ||
| 115 | 96x |
res |
| 116 |
} |
|
| 117 | ||
| 118 | ||
| 119 | ||
| 120 |
# pearson correlation |
|
| 121 |
# if no missing, solution is just cor(Y1,Y2) or cor(e1,e2) |
|
| 122 |
# but if missing, two-step solution is NOT the same as cor(Y1,Y2) or cor(e1,e2) |
|
| 123 |
lav_bvreg_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 124 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 125 |
Y1.name = NULL, Y2.name = NULL, |
|
| 126 |
optim.method = "nlminb1", |
|
| 127 |
# optim.method = "none", |
|
| 128 |
optim.scale = 1, |
|
| 129 |
init.theta = NULL, |
|
| 130 |
control = list()) {
|
|
| 131 | 90x |
if (is.null(fit.y1)) {
|
| 132 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 133 |
} |
|
| 134 | 90x |
if (is.null(fit.y2)) {
|
| 135 | ! |
fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt) |
| 136 |
} |
|
| 137 | ||
| 138 |
# create cache environment |
|
| 139 | 90x |
cache <- lav_bvreg_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt) |
| 140 | ||
| 141 |
# the complete case is trivial |
|
| 142 | 90x |
if (!anyNA(fit.y1$y) && !anyNA(fit.y2$y)) {
|
| 143 | ! |
return(cache$theta[1L]) |
| 144 |
} |
|
| 145 | ||
| 146 |
# optim.method |
|
| 147 | 90x |
minObjective <- lav_bvreg_min_objective |
| 148 | 90x |
minGradient <- lav_bvreg_min_gradient |
| 149 | 90x |
minHessian <- lav_bvreg_min_hessian |
| 150 | 90x |
if (optim.method == "nlminb" || optim.method == "nlminb2") {
|
| 151 |
# nothing to do |
|
| 152 | 90x |
} else if (optim.method == "nlminb0") {
|
| 153 | ! |
minGradient <- minHessian <- NULL |
| 154 | 90x |
} else if (optim.method == "nlminb1") {
|
| 155 | 90x |
minHessian <- NULL |
| 156 | ! |
} else if (optim.method == "none") {
|
| 157 | ! |
return(cache$theta[1L]) |
| 158 |
} |
|
| 159 | ||
| 160 |
# optimize |
|
| 161 | 90x |
if (is.null(control$trace)) {
|
| 162 | 90x |
control$trace <- ifelse(lav_verbose(), 1, 0) |
| 163 |
} |
|
| 164 | ||
| 165 |
# init theta? |
|
| 166 | 90x |
if (!is.null(init.theta)) {
|
| 167 | ! |
start.x <- init.theta |
| 168 |
} else {
|
|
| 169 | 90x |
start.x <- cache$theta |
| 170 |
} |
|
| 171 | ||
| 172 |
# try 1 |
|
| 173 | 90x |
optim <- nlminb( |
| 174 | 90x |
start = start.x, objective = minObjective, |
| 175 | 90x |
gradient = minGradient, hessian = minHessian, |
| 176 | 90x |
control = control, |
| 177 | 90x |
scale = optim.scale, lower = -0.999, upper = +0.999, |
| 178 | 90x |
cache = cache |
| 179 |
) |
|
| 180 | ||
| 181 |
# try 2 (scale = 10) |
|
| 182 | 90x |
if (optim$convergence != 0L) {
|
| 183 | 2x |
optim <- nlminb( |
| 184 | 2x |
start = start.x, objective = minObjective, |
| 185 | 2x |
gradient = minGradient, hessian = minHessian, |
| 186 | 2x |
control = control, |
| 187 | 2x |
scale = 10, lower = -0.999, upper = +0.999, |
| 188 | 2x |
cache = cache |
| 189 |
) |
|
| 190 |
} |
|
| 191 | ||
| 192 |
# try 3 (start = 0, step.min = 0.1) |
|
| 193 | 90x |
if (optim$convergence != 0L) {
|
| 194 | ! |
control$step.min <- 0.1 |
| 195 | ! |
minGradient <- lav_bvreg_min_gradient |
| 196 |
# try again, with different starting value |
|
| 197 | ! |
optim <- nlminb( |
| 198 | ! |
start = 0, objective = minObjective, |
| 199 | ! |
gradient = minGradient, hessian = NULL, |
| 200 | ! |
control = control, |
| 201 | ! |
scale = optim.scale, lower = -0.999, upper = +0.999, |
| 202 | ! |
cache = cache |
| 203 |
) |
|
| 204 |
} |
|
| 205 | ||
| 206 |
# check convergence |
|
| 207 | 90x |
if (optim$convergence != 0L) {
|
| 208 | ! |
if (!is.null(Y1.name) && !is.null(Y2.name)) {
|
| 209 | ! |
lav_msg_warn(gettextf( |
| 210 | ! |
"estimation pearson correlation did not converge for variables %1$s |
| 211 | ! |
and %2$s.", Y1.name, Y2.name)) |
| 212 |
} else {
|
|
| 213 | ! |
lav_msg_warn(gettext( |
| 214 | ! |
"estimation pearson correlation(s) did not always converge")) |
| 215 |
} |
|
| 216 | ||
| 217 |
# use init (as we always did in < 0.6-6; this is also what Mplus does) |
|
| 218 | ! |
rho <- start.x |
| 219 |
} else {
|
|
| 220 |
# store result |
|
| 221 | 90x |
rho <- optim$par |
| 222 |
} |
|
| 223 | ||
| 224 | 90x |
rho |
| 225 |
} |
|
| 226 | ||
| 227 |
# Y1 = linear |
|
| 228 |
# Y2 = linear |
|
| 229 |
lav_bvreg_init_cache <- function(fit.y1 = NULL, |
|
| 230 |
fit.y2 = NULL, |
|
| 231 |
wt = NULL, |
|
| 232 |
scores = FALSE, |
|
| 233 |
parent = parent.frame()) {
|
|
| 234 |
# data |
|
| 235 | 180x |
Y1 <- fit.y1$y |
| 236 | 180x |
Y2 <- fit.y2$y |
| 237 | 180x |
eXo <- fit.y1$X |
| 238 | ||
| 239 |
# Y1 |
|
| 240 | 180x |
Y1c <- Y1 - fit.y1$yhat |
| 241 | 180x |
evar.y1 <- fit.y1$theta[fit.y1$var.idx] |
| 242 | 180x |
sd.y1 <- sqrt(evar.y1) |
| 243 | 180x |
eta.y1 <- fit.y1$yhat |
| 244 | ||
| 245 |
# Y2 |
|
| 246 | 180x |
Y2c <- Y2 - fit.y2$yhat |
| 247 | 180x |
evar.y2 <- fit.y2$theta[fit.y1$var.idx] |
| 248 | 180x |
sd.y2 <- sqrt(evar.y2) |
| 249 | 180x |
eta.y2 <- fit.y2$yhat |
| 250 | ||
| 251 | ||
| 252 |
# exo? |
|
| 253 | 180x |
if (is.null(eXo)) {
|
| 254 | ! |
nexo <- 0L |
| 255 |
} else {
|
|
| 256 | 180x |
nexo <- ncol(eXo) |
| 257 |
} |
|
| 258 | ||
| 259 |
# nobs |
|
| 260 | 180x |
if (is.null(wt)) {
|
| 261 | 180x |
N <- length(Y1) |
| 262 |
} else {
|
|
| 263 | ! |
N <- sum(wt) |
| 264 |
} |
|
| 265 | ||
| 266 |
# starting value |
|
| 267 | 180x |
if (fit.y1$nexo > 0L) {
|
| 268 | 180x |
E1 <- Y1 - fit.y1$yhat |
| 269 | 180x |
E2 <- Y2 - fit.y2$yhat |
| 270 | 180x |
if (is.null(wt)) {
|
| 271 | 180x |
rho.init <- cor(E1, E2, use = "pairwise.complete.obs") |
| 272 |
} else {
|
|
| 273 | ! |
tmp <- na.omit(cbind(E1, E2, wt)) |
| 274 | ! |
rho.init <- cov.wt(tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1] |
| 275 |
} |
|
| 276 |
} else {
|
|
| 277 | ! |
if (is.null(wt)) {
|
| 278 | ! |
rho.init <- cor(Y1, Y2, use = "pairwise.complete.obs") |
| 279 |
} else {
|
|
| 280 | ! |
tmp <- na.omit(cbind(Y1, Y2, wt)) |
| 281 | ! |
rho.init <- cov.wt(tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1] |
| 282 |
} |
|
| 283 |
} |
|
| 284 | ||
| 285 |
# sanity check |
|
| 286 | 180x |
if (is.na(rho.init) || abs(rho.init) >= 1.0) {
|
| 287 | ! |
rho.init <- 0.0 |
| 288 |
} |
|
| 289 | ||
| 290 |
# parameter vector |
|
| 291 | 180x |
theta <- rho.init # only |
| 292 | ||
| 293 |
# different cache if scores or not |
|
| 294 | 180x |
if (scores) {
|
| 295 | 90x |
out <- list2env( |
| 296 | 90x |
list( |
| 297 | 90x |
nexo = nexo, theta = theta, N = N, |
| 298 | 90x |
Y1c = Y1c, Y2c = Y2c, eXo = eXo, |
| 299 | 90x |
evar.y1 = evar.y1, sd.y1 = sd.y1, eta.y1 = eta.y1, |
| 300 | 90x |
evar.y2 = evar.y2, sd.y2 = sd.y2, eta.y2 = eta.y2 |
| 301 |
), |
|
| 302 | 90x |
parent = parent |
| 303 |
) |
|
| 304 |
} else {
|
|
| 305 | 90x |
out <- list2env( |
| 306 | 90x |
list( |
| 307 | 90x |
nexo = nexo, theta = theta, N = N, |
| 308 | 90x |
Y1c = Y1c, Y2c = Y2c, |
| 309 | 90x |
evar.y1 = evar.y1, sd.y1 = sd.y1, eta.y1 = eta.y1, |
| 310 | 90x |
evar.y2 = evar.y2, sd.y2 = sd.y2, eta.y2 = eta.y2 |
| 311 |
), |
|
| 312 | 90x |
parent = parent |
| 313 |
) |
|
| 314 |
} |
|
| 315 | ||
| 316 | 180x |
out |
| 317 |
} |
|
| 318 | ||
| 319 | ||
| 320 |
# casewise likelihoods, unweighted! |
|
| 321 |
lav_bvreg_lik_cache <- function(cache = NULL) {
|
|
| 322 | 708x |
with(cache, {
|
| 323 | 708x |
rho <- theta[1L] |
| 324 | ||
| 325 | 708x |
cov.y12 <- rho * sqrt(evar.y1) * sqrt(evar.y2) |
| 326 | 708x |
sigma <- matrix(c(evar.y1, cov.y12, cov.y12, evar.y2), 2L, 2L) |
| 327 | 708x |
lik <- exp(lav_mvnorm_loglik_data( |
| 328 | 708x |
Y = cbind(Y1c, Y2c), wt = NULL, |
| 329 | 708x |
Mu = c(0, 0), Sigma = sigma, |
| 330 | 708x |
casewise = TRUE |
| 331 |
)) |
|
| 332 |
# catch very small values |
|
| 333 | 708x |
lik.toosmall.idx <- which(lik < sqrt(.Machine$double.eps)) |
| 334 | 708x |
lik[lik.toosmall.idx] <- as.numeric(NA) |
| 335 | ||
| 336 | 708x |
return(lik) |
| 337 |
}) |
|
| 338 |
} |
|
| 339 | ||
| 340 |
lav_bvreg_logl_cache <- function(cache = NULL) {
|
|
| 341 | 708x |
with(cache, {
|
| 342 | 708x |
lik <- lav_bvreg_lik_cache(cache) # unweighted! |
| 343 | ||
| 344 | 708x |
if (!is.null(wt)) {
|
| 345 | ! |
logl <- sum(wt * log(lik), na.rm = TRUE) |
| 346 |
} else {
|
|
| 347 | 708x |
logl <- sum(log(lik), na.rm = TRUE) |
| 348 |
} |
|
| 349 | ||
| 350 | 708x |
return(logl) |
| 351 |
}) |
|
| 352 |
} |
|
| 353 | ||
| 354 |
lav_bvreg_gradient_cache <- function(cache = NULL) {
|
|
| 355 | 460x |
with(cache, {
|
| 356 | 460x |
rho <- theta[1L] |
| 357 | 460x |
R <- (1 - rho * rho) |
| 358 | ||
| 359 | 460x |
sd.y1.y2 <- sd.y1 * sd.y2 |
| 360 | 460x |
t1 <- (Y1c * Y2c) / sd.y1.y2 |
| 361 | 460x |
t2 <- (Y1c * Y1c) / evar.y1 - (2 * rho * t1) + (Y2c * Y2c) / evar.y2 |
| 362 | 460x |
dx <- (rho + t1 - t2 * rho / R) / R |
| 363 | ||
| 364 |
# to be consistent with (log)lik_cache |
|
| 365 | 460x |
if (length(lik.toosmall.idx) > 0L) {
|
| 366 | 238x |
dx[lik.toosmall.idx] <- as.numeric(NA) |
| 367 |
} |
|
| 368 | ||
| 369 | 460x |
if (is.null(wt)) {
|
| 370 | 460x |
dx.rho <- sum(dx, na.rm = TRUE) |
| 371 |
} else {
|
|
| 372 | ! |
dx.rho <- sum(wt * dx, na.rm = TRUE) |
| 373 |
} |
|
| 374 | ||
| 375 | 460x |
return(dx.rho) |
| 376 |
}) |
|
| 377 |
} |
|
| 378 | ||
| 379 |
lav_bvreg_hessian_cache <- function(cache = NULL) {
|
|
| 380 | ! |
with(cache, {
|
| 381 | ! |
rho <- theta[1L] |
| 382 | ||
| 383 | ! |
rho2 <- rho * rho |
| 384 | ! |
R2 <- R * R |
| 385 | ! |
R3 <- R * R * R |
| 386 | ||
| 387 | ! |
h <- 1 / R - (2 * rho2 * t2) / R3 + 2 * rho2 * (1 - t2 / R) / R2 + 4 * rho * t1 / R2 - t2 / R2 |
| 388 | ||
| 389 |
# to be consistent with (log)lik_cache |
|
| 390 | ! |
if (length(lik.toosmall.idx) > 0L) {
|
| 391 | ! |
h[lik.toosmall.idx] <- as.numeric(NA) |
| 392 |
} |
|
| 393 | ||
| 394 | ! |
if (is.null(wt)) {
|
| 395 | ! |
H <- sum(h, na.rm = TRUE) |
| 396 |
} else {
|
|
| 397 | ! |
H <- sum(wt * h, na.rm = TRUE) |
| 398 |
} |
|
| 399 | ! |
dim(H) <- c(1L, 1L) # for nlminb |
| 400 | ||
| 401 | ! |
return(H) |
| 402 |
}) |
|
| 403 |
} |
|
| 404 | ||
| 405 |
# compute total (log)likelihood, for specific 'x' (nlminb) |
|
| 406 |
lav_bvreg_min_objective <- function(x, cache = NULL) {
|
|
| 407 | 674x |
cache$theta <- x |
| 408 | 674x |
-1 * lav_bvreg_logl_cache(cache = cache) / cache$N |
| 409 |
} |
|
| 410 | ||
| 411 |
# compute gradient, for specific 'x' (nlminb) |
|
| 412 |
lav_bvreg_min_gradient <- function(x, cache = NULL) {
|
|
| 413 |
# check if x has changed |
|
| 414 | 460x |
if (!all(x == cache$theta)) {
|
| 415 | 34x |
cache$theta <- x |
| 416 | 34x |
tmp <- lav_bvreg_logl_cache(cache = cache) |
| 417 |
} |
|
| 418 | 460x |
-1 * lav_bvreg_gradient_cache(cache = cache) / cache$N |
| 419 |
} |
|
| 420 | ||
| 421 |
# compute hessian, for specific 'x' (nlminb) |
|
| 422 |
lav_bvreg_min_hessian <- function(x, cache = NULL) {
|
|
| 423 |
# check if x has changed |
|
| 424 | ! |
if (!all(x == cache$theta)) {
|
| 425 | ! |
tmp <- lav_bvreg_logl_cache(cache = cache) |
| 426 | ! |
tmp <- lav_bvreg_gradient_cache(cache = cache) |
| 427 |
} |
|
| 428 | ! |
-1 * lav_bvreg_hessian_cache(cache = cache) / cache$N |
| 429 |
} |
|
| 430 | ||
| 431 |
# casewise scores - cache |
|
| 432 |
# FIXME: should we also set 'lik.toosmall.idx' cases to NA? |
|
| 433 |
lav_bvreg_cor_scores_cache <- function(cache = NULL) {
|
|
| 434 | 90x |
with(cache, {
|
| 435 | 90x |
rho <- theta[1L] |
| 436 | 90x |
R <- (1 - rho * rho) |
| 437 | ||
| 438 |
# mu.y1 |
|
| 439 | 90x |
dx.mu.y1 <- (2 * Y1c / evar.y1 - 2 * rho * Y2c / (sd.y1 * sd.y2)) / (2 * R) |
| 440 | 90x |
if (!is.null(wt)) {
|
| 441 | ! |
dx.mu.y1 <- wt * dx.mu.y1 |
| 442 |
} |
|
| 443 | ||
| 444 |
# mu.y2 |
|
| 445 | 90x |
dx.mu.y2 <- -(2 * rho * Y1c / (sd.y1 * sd.y2) - 2 * Y2c / evar.y2) / (2 * R) |
| 446 | 90x |
if (!is.null(wt)) {
|
| 447 | ! |
dx.mu.y2 <- wt * dx.mu.y2 |
| 448 |
} |
|
| 449 | ||
| 450 |
# evar.y1 |
|
| 451 | 90x |
dx.var.y1 <- -(0.5 / evar.y1 - ((Y1c * Y1c) / (evar.y1 * evar.y1) - |
| 452 | 90x |
rho * Y1c * Y2c / (evar.y1 * sd.y1 * sd.y2)) / (2 * R)) |
| 453 | 90x |
if (!is.null(wt)) {
|
| 454 | ! |
dx.var.y1 <- wt * dx.var.y1 |
| 455 |
} |
|
| 456 | ||
| 457 |
# var.y2 |
|
| 458 | 90x |
dx.var.y2 <- -(0.5 / evar.y2 + (rho * Y1c * Y2c / (evar.y2 * sd.y1 * sd.y2) - |
| 459 | 90x |
(Y2c * Y2c) / (evar.y2 * evar.y2)) / (2 * R)) |
| 460 | 90x |
if (!is.null(wt)) {
|
| 461 | ! |
dx.var.y2 <- wt * dx.var.y2 |
| 462 |
} |
|
| 463 | ||
| 464 |
# sl.y1 |
|
| 465 | 90x |
dx.sl.y1 <- NULL |
| 466 | 90x |
if (nexo > 0L) {
|
| 467 | 90x |
dx.sl.y1 <- dx.mu.y1 * eXo # weights already included in dx.mu.y1 |
| 468 |
} |
|
| 469 | ||
| 470 |
# sl.y2 |
|
| 471 | 90x |
dx.sl.y2 <- NULL |
| 472 | 90x |
if (nexo > 0L) {
|
| 473 | 90x |
dx.sl.y2 <- dx.mu.y2 * eXo # weights already included in dx.mu.y2 |
| 474 |
} |
|
| 475 | ||
| 476 |
# rho |
|
| 477 | 90x |
z <- (Y1c * Y1c) / evar.y1 - 2 * rho * Y1c * Y2c / (sd.y1 * sd.y2) + (Y2c * Y2c) / evar.y2 |
| 478 | 90x |
dx.rho <- rho / R + (Y1c * Y2c / (sd.y1 * sd.y2 * R) - z * rho / (R * R)) |
| 479 | 90x |
if (!is.null(wt)) {
|
| 480 | ! |
dx.rho <- wt * dx.rho |
| 481 |
} |
|
| 482 | ||
| 483 | 90x |
out <- list( |
| 484 | 90x |
dx.mu.y1 = dx.mu.y1, dx.var.y1 = dx.var.y1, |
| 485 | 90x |
dx.mu.y2 = dx.mu.y2, dx.var.y2 = dx.var.y2, |
| 486 | 90x |
dx.sl.y1 = dx.sl.y1, dx.sl.y2 = dx.sl.y2, |
| 487 | 90x |
dx.rho = dx.rho |
| 488 |
) |
|
| 489 | 90x |
return(out) |
| 490 |
}) |
|
| 491 |
} |
|
| 492 | ||
| 493 |
# casewise scores |
|
| 494 |
# |
|
| 495 |
# Y1 = linear |
|
| 496 |
# Y2 = linear |
|
| 497 |
lav_bvreg_cor_scores <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 498 |
rho = NULL, |
|
| 499 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 500 |
evar.y1 = NULL, beta.y1 = NULL, |
|
| 501 |
evar.y2 = NULL, beta.y2 = NULL) {
|
|
| 502 | 90x |
if (is.null(fit.y1)) {
|
| 503 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 504 |
} |
|
| 505 | 90x |
if (is.null(fit.y2)) {
|
| 506 | ! |
fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt) |
| 507 |
} |
|
| 508 | ||
| 509 |
# user specified parameters |
|
| 510 | 90x |
if (!is.null(evar.y1) || !is.null(beta.y1)) {
|
| 511 | ! |
fit.y1 <- lav_uvreg_update_fit( |
| 512 | ! |
fit.y = fit.y1, |
| 513 | ! |
evar.new = evar.y1, beta.new = beta.y1 |
| 514 |
) |
|
| 515 |
} |
|
| 516 | 90x |
if (!is.null(evar.y2) || !is.null(beta.y2)) {
|
| 517 | ! |
fit.y2 <- lav_uvreg_update_fit( |
| 518 | ! |
fit.y = fit.y2, |
| 519 | ! |
evar.new = evar.y2, beta.new = beta.y2 |
| 520 |
) |
|
| 521 |
} |
|
| 522 | ||
| 523 |
# create cache environment |
|
| 524 | 90x |
cache <- lav_bvreg_init_cache( |
| 525 | 90x |
fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt, |
| 526 | 90x |
scores = TRUE |
| 527 |
) |
|
| 528 | 90x |
cache$theta <- rho |
| 529 | ||
| 530 | 90x |
SC <- lav_bvreg_cor_scores_cache(cache = cache) |
| 531 | ||
| 532 | 90x |
SC |
| 533 |
} |
|
| 534 | ||
| 535 |
# logl - no cache |
|
| 536 |
lav_bvreg_logl <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 537 |
rho = NULL, |
|
| 538 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 539 |
evar.y1 = NULL, beta.y1 = NULL, |
|
| 540 |
evar.y2 = NULL, beta.y2 = NULL) {
|
|
| 541 | ! |
if (is.null(fit.y1)) {
|
| 542 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 543 |
} |
|
| 544 | ! |
if (is.null(fit.y2)) {
|
| 545 | ! |
fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt) |
| 546 |
} |
|
| 547 | ||
| 548 |
# user specified parameters |
|
| 549 | ! |
if (!is.null(evar.y1) || !is.null(beta.y1)) {
|
| 550 | ! |
fit.y1 <- lav_uvreg_update_fit( |
| 551 | ! |
fit.y = fit.y1, |
| 552 | ! |
evar.new = evar.y1, beta.new = beta.y1 |
| 553 |
) |
|
| 554 |
} |
|
| 555 | ! |
if (!is.null(evar.y2) || !is.null(beta.y2)) {
|
| 556 | ! |
fit.y2 <- lav_uvreg_update_fit( |
| 557 | ! |
fit.y = fit.y2, |
| 558 | ! |
evar.new = evar.y2, beta.new = beta.y2 |
| 559 |
) |
|
| 560 |
} |
|
| 561 | ||
| 562 |
# create cache environment |
|
| 563 | ! |
cache <- lav_bvreg_init_cache( |
| 564 | ! |
fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt, |
| 565 | ! |
scores = TRUE |
| 566 |
) |
|
| 567 | ! |
cache$theta <- rho |
| 568 | ||
| 569 | ! |
lav_bvreg_logl_cache(cache = cache) |
| 570 |
} |
|
| 571 | ||
| 572 |
# lik - no cache |
|
| 573 |
lav_bvreg_lik <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 574 |
rho = NULL, |
|
| 575 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 576 |
evar.y1 = NULL, beta.y1 = NULL, |
|
| 577 |
evar.y2 = NULL, beta.y2 = NULL, |
|
| 578 |
.log = FALSE) {
|
|
| 579 | ! |
if (is.null(fit.y1)) {
|
| 580 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 581 |
} |
|
| 582 | ! |
if (is.null(fit.y2)) {
|
| 583 | ! |
fit.y2 <- lav_uvreg_fit(y = Y2, X = eXo, wt = wt) |
| 584 |
} |
|
| 585 | ||
| 586 |
# user specified parameters |
|
| 587 | ! |
if (!is.null(evar.y1) || !is.null(beta.y1)) {
|
| 588 | ! |
fit.y1 <- lav_uvreg_update_fit( |
| 589 | ! |
fit.y = fit.y1, |
| 590 | ! |
evar.new = evar.y1, beta.new = beta.y1 |
| 591 |
) |
|
| 592 |
} |
|
| 593 | ! |
if (!is.null(evar.y2) || !is.null(beta.y2)) {
|
| 594 | ! |
fit.y2 <- lav_uvreg_update_fit( |
| 595 | ! |
fit.y = fit.y2, |
| 596 | ! |
evar.new = evar.y2, beta.new = beta.y2 |
| 597 |
) |
|
| 598 |
} |
|
| 599 | ||
| 600 |
# create cache environment |
|
| 601 | ! |
cache <- lav_bvreg_init_cache( |
| 602 | ! |
fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt, |
| 603 | ! |
scores = TRUE |
| 604 |
) |
|
| 605 | ! |
cache$theta <- rho |
| 606 | ||
| 607 | ! |
lik <- lav_bvreg_lik_cache(cache = cache) |
| 608 | ! |
if (.log) {
|
| 609 | ! |
lik <- log(lik) |
| 610 |
} |
|
| 611 | ||
| 612 | ! |
if (!is.null(wt)) {
|
| 613 | ! |
if (.log) {
|
| 614 | ! |
lik <- wt * lik |
| 615 |
} else {
|
|
| 616 | ! |
tmp <- wt * log(lik) |
| 617 | ! |
lik <- exp(tmp) |
| 618 |
} |
|
| 619 |
} |
|
| 620 | ||
| 621 | ! |
lik |
| 622 |
} |
| 1 |
# the entries of the lavaan and lavaanList objects have changed over time |
|
| 2 |
# this function will check if the lavaan/lavaanList object is up to date, and |
|
| 3 |
# adapt, if not. |
|
| 4 |
# |
|
| 5 |
# this may be useful if an older (say 0.5) lavaan object was saved, and |
|
| 6 |
# passed to a function like lavPredict() in, say, lavaan 0.6-21. |
|
| 7 | ||
| 8 |
# notes: |
|
| 9 |
# - pre<0.5 lavaan objects are no longer supported |
|
| 10 |
# - @Fit slot is ignored (as not used anymore) |
|
| 11 | ||
| 12 |
# YR 16 Oct 2025 + LDW 22 Oct 2025 |
|
| 13 | ||
| 14 |
lav_object_check_version <- function(object = NULL) {
|
|
| 15 | ||
| 16 | 1824x |
is.lavaan.object <- inherits(object, "lavaan") |
| 17 | 1824x |
if (!is.lavaan.object) {
|
| 18 |
# check if lavaanList object, if not return input object |
|
| 19 | ! |
if (!inherits(object, "lavaanList")) return(object) |
| 20 |
} |
|
| 21 | ||
| 22 |
# flag: check or not? |
|
| 23 | 1824x |
check_not_needed_flag <- TRUE |
| 24 | ||
| 25 |
# do we have a version slot? |
|
| 26 | 1824x |
if (.hasSlot(object, "version")) {
|
| 27 | 1824x |
has_version_flag <- TRUE |
| 28 | 1824x |
lavobject_version <- object@version[1] # lavaan.mi has two |
| 29 | 1824x |
lavaanpkg_version <- read.dcf( |
| 30 | 1824x |
file = system.file("DESCRIPTION", package = "lavaan"),
|
| 31 | 1824x |
fields = "Version" |
| 32 | 1824x |
)[1] |
| 33 | 1824x |
if (lavobject_version != lavaanpkg_version) {
|
| 34 | ! |
check_not_needed_flag <- FALSE |
| 35 |
} |
|
| 36 |
} else {
|
|
| 37 |
# <0.6 |
|
| 38 | ! |
has_version_flag <- FALSE |
| 39 | ! |
check_not_needed_flag <- FALSE |
| 40 |
} |
|
| 41 | ||
| 42 |
# check needed? |
|
| 43 | 1824x |
if (check_not_needed_flag) {
|
| 44 | 1824x |
return(object) |
| 45 |
} |
|
| 46 | ||
| 47 |
# ok, we have potentially an older (saved) lavaan or lavaanList object |
|
| 48 |
# check needed slots, and if missing, add them |
|
| 49 | ! |
suppressWarnings(lavobject <- object) |
| 50 | ! |
ngroups <- lav_partable_ngroups(lavobject@ParTable) |
| 51 | ! |
nblocks <- lav_partable_nblocks(lavobject@ParTable) |
| 52 | ! |
nlevels <- lav_partable_nlevels(lavobject@ParTable) |
| 53 | ||
| 54 | ! |
if (!has_version_flag) { # pre 0.6 object!
|
| 55 |
# 0.5-10 (25 Oct 2012) |
|
| 56 | ! |
if (!.hasSlot(lavobject@Data, "group")) {
|
| 57 | ! |
lavobject@Data@group <- character(0L) |
| 58 |
} |
|
| 59 | ||
| 60 |
# 0.5-11 (19 dec 2012) |
|
| 61 | ! |
if (is.lavaan.object) {
|
| 62 | ! |
if (!.hasSlot(lavobject@SampleStats, "bifreq")) {
|
| 63 | ! |
lavobject@SampleStats@bifreq <- vector("list", length = ngroups)
|
| 64 |
} |
|
| 65 | ! |
if (!.hasSlot(lavobject, "Cache")) {
|
| 66 | ! |
lavobject@Cache <- list() |
| 67 |
} |
|
| 68 |
} |
|
| 69 | ||
| 70 |
# 0.5-12 (8 March 2013) |
|
| 71 | ! |
if (is.lavaan.object) {
|
| 72 | ! |
if (!.hasSlot(lavobject@SampleStats, "ridge")) {
|
| 73 | ! |
lavobject@SampleStats@ridge <- 0 |
| 74 |
} |
|
| 75 |
} |
|
| 76 | ||
| 77 |
# 0.5-14 (21 July 2013) |
|
| 78 | ! |
if (is.lavaan.object) {
|
| 79 | ! |
if (!.hasSlot(lavobject@Model, "ov.x.dummy.ov.idx")) {
|
| 80 | ! |
lavobject@Model@ov.x.dummy.ov.idx <- vector("list", length = nblocks)
|
| 81 | ! |
lavobject@Model@ov.x.dummy.lv.idx <- vector("list", length = nblocks)
|
| 82 | ! |
lavobject@Model@ov.y.dummy.ov.idx <- vector("list", length = nblocks)
|
| 83 | ! |
lavobject@Model@ov.y.dummy.lv.idx <- vector("list", length = nblocks)
|
| 84 |
} |
|
| 85 | ! |
if (!.hasSlot(lavobject@SampleStats, "mean.x")) {
|
| 86 | ! |
lavobject@SampleStats@mean.x <- vector("list", length = ngroups)
|
| 87 | ! |
for (g in seq_len(ngroups)) {
|
| 88 | ! |
if (!is.null(lavobject@SampleStats@x.idx[[g]])) {
|
| 89 | ! |
lavobject@SampleStats@mean.x[[g]] <- |
| 90 | ! |
lavobject@SampleStats@mean[[g]][lavobject@SampleStats@x.idx[[g]]] |
| 91 |
} |
|
| 92 |
} |
|
| 93 |
} |
|
| 94 | ! |
if (!.hasSlot(lavobject, "pta")) {
|
| 95 | ! |
lavobject@pta <- list() |
| 96 |
} |
|
| 97 |
} |
|
| 98 | ||
| 99 |
# 0.5-15 (15 Nov 2013) |
|
| 100 | ! |
if (is.lavaan.object) {
|
| 101 | ! |
if (!.hasSlot(lavobject@Data, "Rp")) {
|
| 102 | ! |
lavobject@Data@Rp <- vector("list", length = ngroups)
|
| 103 |
} |
|
| 104 |
} |
|
| 105 | ||
| 106 |
# 0.5-16 (7 March 2014) |
|
| 107 | ! |
if (is.lavaan.object) {
|
| 108 | ! |
if (!.hasSlot(lavobject@SampleStats, "group.w")) {
|
| 109 | ! |
lavobject@SampleStats@group.w <- vector("list", length = ngroups)
|
| 110 | ! |
for (g in seq_len(ngroups)) {
|
| 111 | ! |
lavobject@SampleStats@group.w[[g]] <- |
| 112 | ! |
lavobject@SampleStats@nobs[[g]] / lavobject@SampleStats@ntotal |
| 113 |
} |
|
| 114 |
} |
|
| 115 | ! |
if (!.hasSlot(lavobject@Model, "group.w.free")) {
|
| 116 | ! |
lavobject@Model@group.w.free <- FALSE |
| 117 |
} |
|
| 118 | ! |
if (!.hasSlot(lavobject@Model, "parameterization")) {
|
| 119 | ! |
lavobject@Model@parameterization <- "delta" |
| 120 |
} |
|
| 121 | ! |
if (!.hasSlot(lavobject@Model, "link")) {
|
| 122 | ! |
lavobject@Model@link <- "default" |
| 123 |
} |
|
| 124 |
} |
|
| 125 | ||
| 126 |
# 0.5-17 (30 Sept 2014) |
|
| 127 | ! |
if (is.lavaan.object) {
|
| 128 | ! |
if (!.hasSlot(lavobject@SampleStats, "WLS.VD")) {
|
| 129 | ! |
lavobject@SampleStats@WLS.VD <- vector("list", length = ngroups)
|
| 130 |
} |
|
| 131 |
} |
|
| 132 | ||
| 133 |
# 0.5-18 (18 Nov 2014) |
|
| 134 | ! |
if (is.lavaan.object) {
|
| 135 | ! |
if (!.hasSlot(lavobject@Model, "eq.constraints.k0")) {
|
| 136 | ! |
lavobject@Model@eq.constraints.k0 <- numeric(0L) |
| 137 |
} |
|
| 138 | ! |
if (!.hasSlot(lavobject@Model, "ceq.linear.idx")) {
|
| 139 | ! |
lavobject@Model@ceq.linear.idx <- integer(0L) |
| 140 | ! |
lavobject@Model@ceq.nonlinear.idx <- integer(0L) |
| 141 | ! |
lavobject@Model@cin.linear.idx <- integer(0L) |
| 142 | ! |
lavobject@Model@cin.nonlinear.idx <- integer(0L) |
| 143 |
} |
|
| 144 |
} |
|
| 145 | ||
| 146 |
# 0.5-18 (13 Jan 2015) |
|
| 147 | ! |
if (is.lavaan.object) {
|
| 148 | ! |
if (!.hasSlot(lavobject@Model, "ceq.JAC")) {
|
| 149 | ! |
lavobject@Model@ceq.JAC <- matrix(0, nrow = 0L, |
| 150 | ! |
ncol = lavobject@Model@nx.free) |
| 151 | ! |
lavobject@Model@ceq.rhs <- numeric(0L) |
| 152 | ! |
lavobject@Model@cin.JAC <- matrix(0, nrow = 0L, |
| 153 | ! |
ncol = lavobject@Model@nx.free) |
| 154 | ! |
lavobject@Model@cin.rhs <- numeric(0L) |
| 155 |
} |
|
| 156 |
} |
|
| 157 | ||
| 158 |
# 0.5-19 (30 Jul 2015) |
|
| 159 | ! |
if (is.lavaan.object) {
|
| 160 | ! |
if (!.hasSlot(lavobject, "boot")) {
|
| 161 |
# construct partial optim list |
|
| 162 | ! |
optim_list <- list(x = lavobject@Fit@x, |
| 163 | ! |
dx = numeric(0L), |
| 164 | ! |
npar = lavobject@Fit@npar, |
| 165 | ! |
iterations = lavobject@Fit@iterations, |
| 166 | ! |
converged = lavobject@Fit@converged, |
| 167 | ! |
warn.txt = "", |
| 168 | ! |
parscale = rep(1, lavobject@Fit@npar), |
| 169 | ! |
fx = lavobject@Fit@fx, |
| 170 | ! |
fx.group = lavobject@Fit@fx.group, |
| 171 | ! |
logl.group = lavobject@Fit@logl.group, |
| 172 | ! |
control = lavobject@Fit@control) |
| 173 | ! |
lavobject@boot <- vector("list", 0L)
|
| 174 | ! |
lavobject@optim <- optim_list |
| 175 | ! |
lavobject@implied <- lav_model_implied(lavobject@Model) |
| 176 | ! |
lavobject@vcov <- list(se = lavobject@Options$se[1], |
| 177 | ! |
information = lavobject@Options$information[1], |
| 178 | ! |
vcov = matrix(0, 0, 0)) # for now |
| 179 | ! |
lavobject@test <- lavTest(lavobject) |
| 180 | ! |
lavobject@external <- vector("list", 0L)
|
| 181 |
} |
|
| 182 |
} |
|
| 183 | ||
| 184 |
# 0.5-19: est/se move to @ParTable |
|
| 185 | ! |
if (!is.null(lavobject@Fit@est) && is.null(lavobject@ParTable$est)) {
|
| 186 | ! |
lavobject@ParTable$est <- lavobject@Fit@est |
| 187 |
} |
|
| 188 | ! |
if (!is.null(lavobject@Fit@se) && is.null(lavobject@ParTable$se)) {
|
| 189 | ! |
lavobject@ParTable$se <- lavobject@Fit@se |
| 190 |
} |
|
| 191 | ||
| 192 | ||
| 193 |
# 0.5-21 (16 Dec 2015) |
|
| 194 | ! |
if (is.lavaan.object) {
|
| 195 | ! |
if (!.hasSlot(lavobject@Model, "conditional.x")) {
|
| 196 | ! |
lavobject@Model@conditional.x <- FALSE |
| 197 |
} |
|
| 198 |
} |
|
| 199 | ||
| 200 |
# 0.5-21 (5 Jan 2016) |
|
| 201 | ! |
if (is.lavaan.object) {
|
| 202 | ! |
if (!.hasSlot(lavobject@SampleStats, "x.idx")) {
|
| 203 | ! |
lavobject@SampleStats@x.idx <- rep(list(integer(0L)), ngroups) |
| 204 |
} |
|
| 205 |
} |
|
| 206 | ||
| 207 |
# 0.5-21 (8 Jan 2016) |
|
| 208 | ! |
if (is.lavaan.object) {
|
| 209 | ! |
if (!.hasSlot(lavobject@SampleStats, "res.cov")) {
|
| 210 | ! |
lavobject@SampleStats@res.cov <- vector("list", ngroups)
|
| 211 | ! |
lavobject@SampleStats@res.var <- vector("list", ngroups)
|
| 212 | ! |
lavobject@SampleStats@res.th <- vector("list", ngroups)
|
| 213 | ! |
lavobject@SampleStats@res.th.nox <- vector("list", ngroups)
|
| 214 | ! |
lavobject@SampleStats@res.slopes <- vector("list", ngroups)
|
| 215 | ! |
lavobject@SampleStats@res.int <- vector("list", ngroups)
|
| 216 | ! |
lavobject@SampleStats@res.icov <- vector("list", ngroups)
|
| 217 | ! |
lavobject@SampleStats@res.icov.log.det <- vector("list", ngroups)
|
| 218 |
} |
|
| 219 |
} |
|
| 220 | ||
| 221 |
# 0.5-21 (28 Mar 2016) |
|
| 222 | ! |
if (is.lavaan.object) {
|
| 223 | ! |
if (!.hasSlot(lavobject@SampleStats, "NACOV.user")) {
|
| 224 | ! |
lavobject@SampleStats@NACOV.user <- FALSE |
| 225 |
} |
|
| 226 |
} |
|
| 227 | ||
| 228 |
#### 0.5-21, 3 Jul 2016, Class lavaanList is added #### |
|
| 229 | ||
| 230 |
# 0.5-23 (25 Jan 2017) |
|
| 231 | ! |
if (!.hasSlot(lavobject@Model, "estimator")) {
|
| 232 | ! |
lavobject@Model@estimator <- lavobject@Options$estimator |
| 233 |
} |
|
| 234 | ||
| 235 |
# 0.5-23 (30 Jan 2017) |
|
| 236 | ! |
if (is.lavaan.object) {
|
| 237 | ! |
if (!.hasSlot(lavobject@Data, "cluster")) {
|
| 238 | ! |
lavobject@Data@cluster <- character(0L) |
| 239 | ! |
lavobject@Data@ordered <- character(0L) |
| 240 |
} |
|
| 241 |
} else {
|
|
| 242 | ! |
for (j in seq_along(lavobject@DataList)) {
|
| 243 | ! |
if (!.hasSlot(lavobject@DataList[[j]], "cluster")) {
|
| 244 | ! |
lavobject@DataList[[j]]@cluster <- character(0L) |
| 245 | ! |
lavobject@DataList[[j]]@ordered <- character(0L) |
| 246 |
} |
|
| 247 |
} |
|
| 248 |
} |
|
| 249 | ||
| 250 |
# 0.5-23 (7 Feb 2017) |
|
| 251 | ! |
if (is.lavaan.object) {
|
| 252 | ! |
if (!.hasSlot(lavobject@SampleStats, "zero.cell.tables")) {
|
| 253 | ! |
lavobject@SampleStats@zero.cell.tables <- vector("list", ngroups)
|
| 254 |
} |
|
| 255 |
} else {
|
|
| 256 | ! |
for (j in seq_along(lavobject@SampleStatsList)) {
|
| 257 | ! |
if (!.hasSlot(lavobject@SampleStatsList[[j]], "zero.cell.tables")) {
|
| 258 | ! |
lavobject@SampleStatsList[[j]]@zero.cell.tables <- vector("list", ngroups)
|
| 259 |
} |
|
| 260 |
} |
|
| 261 |
} |
|
| 262 | ||
| 263 |
# 0.5-23 (21 Feb 2017) |
|
| 264 | ! |
if (!.hasSlot(lavobject@Model, "nblocks")) {
|
| 265 | ! |
lavobject@Model@nblocks <- nblocks |
| 266 |
} |
|
| 267 | ! |
if (is.lavaan.object) {
|
| 268 | ! |
if (!.hasSlot(lavobject@Data, "level.label")) {
|
| 269 | ! |
lavobject@Data@level.label <- as.character(seq.int(nlevels)) |
| 270 |
} |
|
| 271 |
} else {
|
|
| 272 | ! |
for (j in seq_along(lavobject@DataList)) {
|
| 273 | ! |
if (!.hasSlot(lavobject@DataList[[j]], "level.label")) {
|
| 274 | ! |
lavobject@DataList[[j]]@level.label <- as.character(seq.int(nlevels)) |
| 275 |
} |
|
| 276 |
} |
|
| 277 |
} |
|
| 278 | ! |
if (is.lavaan.object) {
|
| 279 | ! |
if (!.hasSlot(lavobject@Data, "block.label")) {
|
| 280 | ! |
if (nlevels <= 1L) {
|
| 281 | ! |
if (ngroups <= 1L) {
|
| 282 | ! |
lavobject@Data@block.label <- character(0L) |
| 283 |
} else {
|
|
| 284 | ! |
lavobject@Data@block.label <- lavobject@Data@group.label |
| 285 |
} |
|
| 286 |
} else {
|
|
| 287 | ! |
if (ngroups <= 1L) {
|
| 288 | ! |
lavobject@Data@block.label <- lavobject@Data@level.label |
| 289 |
} else {
|
|
| 290 | ! |
lavobject@Data@block.label <- |
| 291 | ! |
paste(rep(lavobject@Data@group.label, |
| 292 | ! |
each = length(lavobject@Data@level.label)), |
| 293 | ! |
rep(lavobject@Data@level.label, |
| 294 | ! |
times = length(lavobject@Data@group.label)), |
| 295 | ! |
sep = "." |
| 296 |
) |
|
| 297 |
} |
|
| 298 |
} |
|
| 299 |
} |
|
| 300 |
} else {
|
|
| 301 | ! |
for (j in seq_along(lavobject@DataList)) {
|
| 302 | ! |
if (!.hasSlot(lavobject@DataList[[j]], "block.label")) {
|
| 303 | ! |
if (nlevels <= 1L) {
|
| 304 | ! |
if (ngroups <= 1L) {
|
| 305 | ! |
lavobject@DataList[[j]]@block.label <- character(0L) |
| 306 |
} else {
|
|
| 307 | ! |
lavobject@DataList[[j]]@block.label <- |
| 308 | ! |
lavobject@DataList[[j]]@group.label |
| 309 |
} |
|
| 310 |
} else {
|
|
| 311 | ! |
if (ngroups <= 1L) {
|
| 312 | ! |
lavobject@DataList[[j]]@block.label <- |
| 313 | ! |
lavobject@DataList[[j]]@level.label |
| 314 |
} else {
|
|
| 315 | ! |
lavobject@DataList[[j]]@block.label <- |
| 316 | ! |
paste(rep(lavobject@DataList[[j]]@group.label, |
| 317 | ! |
each = length(lavobject@DataList[[j]]@level.label)), |
| 318 | ! |
rep(lavobject@DataList[[j]]@level.label, |
| 319 | ! |
times = length(lavobject@DataList[[j]]@group.label)), |
| 320 | ! |
sep = "." |
| 321 |
) |
|
| 322 |
} |
|
| 323 |
} |
|
| 324 |
} |
|
| 325 |
} |
|
| 326 |
} |
|
| 327 | ||
| 328 |
# 0.5-23 (24 Feb 2017) |
|
| 329 | ! |
if (is.lavaan.object) {
|
| 330 | ! |
if (!.hasSlot(lavobject@Data, "nlevels")) {
|
| 331 | ! |
lavobject@Data@nlevels <- nlevels |
| 332 | ! |
lavobject@Data@Lp <- vector("list", ngroups)
|
| 333 |
} |
|
| 334 |
} else {
|
|
| 335 | ! |
for (j in seq_along(lavobject@DataList)) {
|
| 336 | ! |
if (!.hasSlot(lavobject@DataList[[j]], "nlevels")) {
|
| 337 | ! |
lavobject@DataList[[j]]@nlevels <- nlevels |
| 338 | ! |
lavobject@DataList[[j]]@Lp <- vector("list", ngroups)
|
| 339 |
} |
|
| 340 |
} |
|
| 341 |
} |
|
| 342 | ! |
if (is.lavaan.object) {
|
| 343 | ! |
if (!.hasSlot(lavobject@SampleStats, "YLp")) {
|
| 344 | ! |
lavobject@SampleStats@YLp <- vector("list", ngroups)
|
| 345 |
} |
|
| 346 |
} else {
|
|
| 347 | ! |
for (j in seq_along(lavobject@SampleStatsList)) {
|
| 348 | ! |
if (!.hasSlot(lavobject@SampleStatsList[[j]], "YLp")) {
|
| 349 | ! |
lavobject@SampleStatsList[[j]]@YLp <- vector("list", ngroups)
|
| 350 |
} |
|
| 351 |
} |
|
| 352 |
} |
|
| 353 | ||
| 354 |
# 0.6-1 (8 Mar 2017) |
|
| 355 | ! |
if (is.lavaan.object) {
|
| 356 | ! |
if (!.hasSlot(lavobject, "h1")) {
|
| 357 | ! |
lavobject@h1 <- lav_h1_implied_logl(lavdata = lavobject@Data, |
| 358 | ! |
lavsamplestats = lavobject@SampleStats, |
| 359 | ! |
lavpartable = lavobject@ParTable, |
| 360 | ! |
lavoptions = lavobject@Options) |
| 361 | ! |
lavobject@baseline <- lav_lavaan_step15_baseline( |
| 362 | ! |
lavoptions = lavobject@Options, |
| 363 | ! |
lavsamplestats = lavobject@SampleStats, |
| 364 | ! |
lavdata = lavobject@Data, |
| 365 | ! |
lavcache = lavobject@Cache, |
| 366 | ! |
lavpartable = lavobject@ParTable |
| 367 |
) |
|
| 368 |
} |
|
| 369 | ! |
if (!.hasSlot(lavobject@Data, "ov.names.l")) {
|
| 370 | ! |
lavobject@Data@ov.names.l <- vector("list", 0L)
|
| 371 |
} |
|
| 372 |
} else {
|
|
| 373 | ! |
for (j in seq_along(lavobject@DataList)) {
|
| 374 | ! |
if (!.hasSlot(lavobject@DataList[[j]], "ov.names.l")) {
|
| 375 | ! |
lavobject@DataList[[j]]@ov.names.l <- vector("list", 0L)
|
| 376 |
} |
|
| 377 |
} |
|
| 378 |
} |
|
| 379 | ||
| 380 |
# 0.6-1 (10 Mar 2017) |
|
| 381 | ! |
if (!.hasSlot(lavobject@Model, "multilevel")) {
|
| 382 | ! |
lavobject@Model@multilevel <- FALSE |
| 383 |
} |
|
| 384 | ||
| 385 |
# 0.6-1 (19 Mar 2017) |
|
| 386 | ! |
if (is.lavaan.object) {
|
| 387 | ! |
if (!.hasSlot(lavobject, "loglik")) {
|
| 388 | ! |
lavobject@Model@ceq.simple.only <- FALSE |
| 389 | ! |
lavobject@Model@cin.simple.only <- FALSE |
| 390 | ! |
lavobject@loglik <- lav_model_loglik( |
| 391 | ! |
lavdata = lavobject@Data, |
| 392 | ! |
lavsamplestats = lavobject@SampleStats, |
| 393 | ! |
lavimplied = lavobject@implied, |
| 394 | ! |
lavmodel = lavobject@Model, |
| 395 | ! |
lavoptions = lavobject@Options |
| 396 |
) |
|
| 397 |
} |
|
| 398 |
} |
|
| 399 | ||
| 400 |
# 0.6-1 (1 Oct 2017) |
|
| 401 | ! |
if (is.lavaan.object) {
|
| 402 | ! |
if (!.hasSlot(lavobject@Data, "weights")) {
|
| 403 | ! |
lavobject@Data@weights <- vector("list", ngroups)
|
| 404 |
} |
|
| 405 |
} else {
|
|
| 406 | ! |
for (j in seq_along(lavobject@DataList)) {
|
| 407 | ! |
if (!.hasSlot(lavobject@DataList[[j]], "weights")) {
|
| 408 | ! |
lavobject@DataList[[j]]@weights <- vector("list", ngroups)
|
| 409 |
} |
|
| 410 |
} |
|
| 411 |
} |
|
| 412 | ||
| 413 |
# 0.6-1 (3 Oct 2017) |
|
| 414 | ! |
if (is.lavaan.object) {
|
| 415 | ! |
if (!.hasSlot(lavobject@Data, "sampling.weights")) {
|
| 416 | ! |
lavobject@Data@sampling.weights <- character(0L) |
| 417 |
} |
|
| 418 |
} else {
|
|
| 419 | ! |
for (j in seq_along(lavobject@DataList)) {
|
| 420 | ! |
if (!.hasSlot(lavobject@DataList[[j]], "sampling.weights")) {
|
| 421 | ! |
lavobject@DataList[[j]]@sampling.weights <- character(0L) |
| 422 |
} |
|
| 423 |
} |
|
| 424 |
} |
|
| 425 | ||
| 426 |
# 0.6-1 (2 May 2018) |
|
| 427 | ! |
if (is.lavaan.object) {
|
| 428 | ! |
if (!.hasSlot(lavobject, "version")) lavobject@version <- "PRE 0.6" |
| 429 |
} |
|
| 430 |
} # no-version-flag (pre 0.6) |
|
| 431 | ||
| 432 |
### from here on, we assume that the object is generated by lavaan 0.6-1 or |
|
| 433 |
### higher |
|
| 434 | ||
| 435 |
# check if @test list is named |
|
| 436 | ! |
if (is.null(names(lavobject@test))) {
|
| 437 | ! |
names(lavobject@test) <- sapply(lavobject@test, "[[", "test") |
| 438 |
} |
|
| 439 | ||
| 440 |
# 0.6-2 (12 Jun 2018) |
|
| 441 | ! |
if (!.hasSlot(lavobject@Model, "x.free.var.idx")) {
|
| 442 | ! |
lavobject@Model@x.free.var.idx <- integer(0L) |
| 443 |
} |
|
| 444 | ||
| 445 |
# 0.6-3 (17 Sep 2018) |
|
| 446 | ! |
if (!is.lavaan.object) {
|
| 447 | ! |
if (!.hasSlot(lavobject, "h1List")) {
|
| 448 | ! |
lavobject@h1List <- vector("list", 0L)
|
| 449 | ! |
lavobject@loglikList <- vector("list", 0L)
|
| 450 |
} |
|
| 451 |
} |
|
| 452 | ||
| 453 |
# 0.6-4 (30 Mar 2019) |
|
| 454 | ! |
if (!.hasSlot(lavobject@Model, "ov.efa.idx")) {
|
| 455 | ! |
lavobject@Model@ov.efa.idx <- vector("list", nblocks)
|
| 456 | ! |
lavobject@Model@lv.efa.idx <- vector("list", nblocks)
|
| 457 |
} |
|
| 458 | ||
| 459 |
# 0.6-4 (11 Apr 2019) |
|
| 460 | ! |
if (!.hasSlot(lavobject@Model, "nefa")) {
|
| 461 | ! |
lavobject@Model@nefa <- 0L |
| 462 |
} |
|
| 463 | ||
| 464 |
# 0.6-4 (24 Apr 2019) |
|
| 465 | ! |
if (!.hasSlot(lavobject@Model, "H")) {
|
| 466 | ! |
lavobject@Model@H <- vector("list", 0L)
|
| 467 | ! |
lavobject@Model@lv.order <- vector("list", 0L)
|
| 468 |
} |
|
| 469 | ||
| 470 |
# 0.6-4 (26 Apr 2019) |
|
| 471 | ! |
if (!.hasSlot(lavobject@Model, "ceq.efa.JAC")) {
|
| 472 | ! |
lavobject@Model@ceq.efa.JAC <- matrix(0, nrow = 0L, ncol = 0L) |
| 473 |
} |
|
| 474 | ||
| 475 |
# 0.6-5 (7 Jul 2019) |
|
| 476 | ! |
if (!is.lavaan.object) {
|
| 477 | ! |
if (!.hasSlot(lavobject, "baselineList")) {
|
| 478 | ! |
lavobject@baselineList <- vector("list", 0L)
|
| 479 |
} |
|
| 480 |
} |
|
| 481 | ||
| 482 |
# 0.6-8 (29 Sep 2020) |
|
| 483 | ! |
if (!.hasSlot(lavobject@Model, "rv.ov")) {
|
| 484 | ! |
lavobject@Model@rv.ov <- vector("list", 0L)
|
| 485 | ! |
lavobject@Model@rv.lv <- vector("list", 0L)
|
| 486 |
} |
|
| 487 | ||
| 488 |
# 0.6-8 (18 Dec 2020) |
|
| 489 | ! |
if (!.hasSlot(lavobject@Model, "estimator.args")) {
|
| 490 | ! |
lavobject@Model@estimator.args <- vector("list", 0L)
|
| 491 |
} |
|
| 492 | ||
| 493 |
# 0.6-9 (15 Mar 2021) |
|
| 494 | ! |
if (!.hasSlot(lavobject@Model, "modprop")) {
|
| 495 | ! |
lavobject@Model@modprop = lav_model_properties( |
| 496 | ! |
GLIST = lavobject@Model@GLIST, |
| 497 | ! |
lavpartable = lavobject@ParTable, |
| 498 | ! |
nmat = lavobject@Model@nmat, |
| 499 | ! |
m.free.idx = lavobject@Model@m.free.idx |
| 500 |
) |
|
| 501 |
} |
|
| 502 | ||
| 503 |
# 0.6-9 (22 Jun 2021) |
|
| 504 | ! |
if (is.lavaan.object) {
|
| 505 | ! |
if (!.hasSlot(lavobject, "internal")) {
|
| 506 | ! |
lavobject@internal <- vector("list", 0L)
|
| 507 |
} |
|
| 508 |
} else {
|
|
| 509 | ! |
if (!.hasSlot(lavobject, "internalList")) {
|
| 510 | ! |
lavobject@internalList <- vector("list", 0L)
|
| 511 |
} |
|
| 512 |
} |
|
| 513 | ||
| 514 |
# 0.6-11 (28 Feb 2022) |
|
| 515 | ! |
if (!.hasSlot(lavobject@Model, "nx.unco")) {
|
| 516 |
# is not available, unco == free |
|
| 517 | ! |
lavobject@Model@nx.unco <- lavobject@Model@nx.free |
| 518 | ! |
lavobject@Model@x.unco.idx <- lavobject@Model@x.free.idx |
| 519 | ! |
lavobject@Model@ceq.simple.only <- FALSE |
| 520 | ! |
lavobject@Model@ceq.simple.K <- matrix(0, nrow = 0L, ncol = 0L) |
| 521 |
} |
|
| 522 | ||
| 523 |
# 0.6-13 (25 Jul 2022) |
|
| 524 | ! |
if (!.hasSlot(lavobject@Model, "correlation")) {
|
| 525 | ! |
lavobject@Model@correlation <- FALSE |
| 526 |
} |
|
| 527 | ||
| 528 |
# 0.6-18 (25 Apr 2024) |
|
| 529 | ! |
if (!is.lavaan.object) {
|
| 530 | ! |
if (!.hasSlot(lavobject, "version")) {
|
| 531 | ! |
lavobject@version <- "PRE 0.6.18" |
| 532 |
} |
|
| 533 |
} |
|
| 534 | ||
| 535 |
# 0.6-19 (27 Sep 2024) |
|
| 536 | ! |
if (!.hasSlot(lavobject@Model, "cin.simple.only")) {
|
| 537 | ! |
lavobject@Model@cin.simple.only <- FALSE |
| 538 |
} |
|
| 539 | ||
| 540 |
# 0.6-20 (24 Jan 2025) |
|
| 541 | ! |
if (!.hasSlot(lavobject@Model, "composites")) {
|
| 542 | ! |
lavobject@Model@composites <- any(lavobject@ParTable$op == "<~") |
| 543 |
} |
|
| 544 | ||
| 545 |
# check missing options |
|
| 546 | ! |
object_options <- lavobject@Options |
| 547 | ! |
all_options <- lavOptions() |
| 548 | ! |
missing.idx <- which(!names(all_options) %in% names(object_options)) |
| 549 | ! |
new_options <- c(object_options, all_options[missing.idx]) |
| 550 |
# fill in some "default" values |
|
| 551 | ! |
if (new_options$estimator.orig == "default") {
|
| 552 | ! |
new_options$estimator.orig <- new_options$estimator |
| 553 |
} |
|
| 554 | ||
| 555 |
# 0.6-21 |
|
| 556 | ! |
new_options$gamma.vcov.mplus <- new_options$mimic == "Mplus" |
| 557 | ! |
new_options$gamma.wls.mplus <- new_options$mimic == "Mplus" |
| 558 | ! |
new_options$gls.v11.mplus <- new_options$mimic == "Mplus" |
| 559 | ! |
new_options$cinformation.expected.mplus <- new_options$mimic == "Mplus" |
| 560 | ! |
new_options$h1.information.meat <- "structured" |
| 561 | ! |
new_options$mega.h1.information <- "unstructured" |
| 562 | ||
| 563 |
# 0.6-22 |
|
| 564 | ! |
if (is.null(new_options$rotation.args$mg.agreement)) {
|
| 565 | ! |
new_options$rotation.args$mg.agreement <- FALSE |
| 566 | ! |
new_options$rotation.args$mg.agreement.weight <- 0.5 |
| 567 | ! |
new_options$rotation.args$mg.agreement.method <- "pairwise" |
| 568 | ! |
ew_options$rotation.args$mg.agreement.crit <- "procrustes" |
| 569 | ||
| 570 |
} |
|
| 571 | ! |
if (is.null(new_options$rotation.args$mg.agreement.weight)) {
|
| 572 | ! |
new_options$rotation.args$mg.agreement.weight <- 0.5 |
| 573 |
} |
|
| 574 | ||
| 575 | ! |
lavobject@Options <- new_options |
| 576 | ||
| 577 | ! |
lavobject |
| 578 |
} |
| 1 |
# RAM representation |
|
| 2 |
# |
|
| 3 |
# initial version: YR 2021-10-04 |
|
| 4 | ||
| 5 |
lav_ram <- function(partable = NULL, |
|
| 6 |
target = NULL, |
|
| 7 |
extra = FALSE, |
|
| 8 |
remove.nonexisting = TRUE) {
|
|
| 9 |
# prepare target list |
|
| 10 | ! |
if (is.null(target)) target <- partable |
| 11 | ||
| 12 | ! |
stopifnot(!is.null(target$block)) |
| 13 | ||
| 14 |
# not for categorical data (yet) |
|
| 15 | ! |
if (any(partable$op == "|")) {
|
| 16 | ! |
lav_msg_stop(gettext("RAM representation is not (yet) supported for
|
| 17 | ! |
categorical endogenous variables.")) |
| 18 |
} |
|
| 19 | ||
| 20 |
# not for conditional.x = TRUE yet |
|
| 21 | ! |
conditional.x <- any(partable$exo > 0L & partable$op == "~") |
| 22 | ! |
if (conditional.x) {
|
| 23 | ! |
lav_msg_stop(gettext("RAM representation is not (yet) supported
|
| 24 | ! |
if conditional.x = TRUE")) |
| 25 |
} |
|
| 26 | ||
| 27 |
# prepare output |
|
| 28 | ! |
N <- length(target$lhs) |
| 29 | ! |
tmp.mat <- character(N) |
| 30 | ! |
tmp.row <- integer(N) |
| 31 | ! |
tmp.col <- integer(N) |
| 32 | ||
| 33 |
# global settings |
|
| 34 | ! |
meanstructure <- any(partable$op == "~1") |
| 35 | ! |
categorical <- any(partable$op == "|") |
| 36 | ! |
group.w.free <- any(partable$lhs == "group" & partable$op == "%") |
| 37 | ||
| 38 |
# number of blocks |
|
| 39 | ! |
nblocks <- lav_partable_nblocks(partable) |
| 40 | ||
| 41 |
# always return ov.idx |
|
| 42 | ! |
ov.idx <- vector("list", nblocks)
|
| 43 | ! |
ov.dummy.names.nox <- vector("list", nblocks)
|
| 44 | ! |
ov.dummy.names.x <- vector("list", nblocks)
|
| 45 | ! |
if (extra) {
|
| 46 | ! |
REP.mmNames <- vector("list", nblocks)
|
| 47 | ! |
REP.mmNumber <- vector("list", nblocks)
|
| 48 | ! |
REP.mmRows <- vector("list", nblocks)
|
| 49 | ! |
REP.mmCols <- vector("list", nblocks)
|
| 50 | ! |
REP.mmDimNames <- vector("list", nblocks)
|
| 51 | ! |
REP.mmSymmetric <- vector("list", nblocks)
|
| 52 |
} |
|
| 53 | ||
| 54 | ! |
for (g in 1:nblocks) {
|
| 55 |
# info from user model per block |
|
| 56 | ! |
ov.names <- lav_partable_vnames(partable, "ov", block = g) |
| 57 | ! |
nvar <- length(ov.names) |
| 58 | ! |
ov.idx[[g]] <- seq_len(nvar) |
| 59 | ! |
ov.dummy.names.nox[[g]] <- character(0) |
| 60 | ! |
ov.dummy.names.x[[g]] <- character(0) |
| 61 | ||
| 62 | ! |
lv.names <- lav_partable_vnames(partable, "lv", block = g) |
| 63 | ! |
both.names <- c(ov.names, lv.names) |
| 64 | ! |
nboth <- length(both.names) |
| 65 | ||
| 66 |
# 1. "=~" indicators |
|
| 67 | ! |
idx <- which(target$block == g & target$op == "=~") |
| 68 | ! |
tmp.mat[idx] <- "A" |
| 69 | ! |
tmp.row[idx] <- match(target$rhs[idx], both.names) |
| 70 | ! |
tmp.col[idx] <- match(target$lhs[idx], both.names) |
| 71 | ||
| 72 |
# 2. "~" regressions |
|
| 73 | ! |
idx <- which(target$block == g & (target$op == "~" | |
| 74 | ! |
target$op == "<~")) |
| 75 | ! |
tmp.mat[idx] <- "A" |
| 76 | ! |
tmp.row[idx] <- match(target$lhs[idx], both.names) |
| 77 | ! |
tmp.col[idx] <- match(target$rhs[idx], both.names) |
| 78 | ||
| 79 |
# 3. "~~" variances/covariances |
|
| 80 | ! |
idx <- which(target$block == g & target$op == "~~") |
| 81 | ! |
tmp.mat[idx] <- "S" |
| 82 | ! |
tmp.row[idx] <- match(target$lhs[idx], both.names) |
| 83 | ! |
tmp.col[idx] <- match(target$rhs[idx], both.names) |
| 84 | ||
| 85 |
# catch lower-elements in theta/psi |
|
| 86 | ! |
idx.lower <- which(tmp.mat == "S" & tmp.row > tmp.col) |
| 87 | ! |
if (length(idx.lower) > 0L) {
|
| 88 | ! |
tmp <- tmp.row[idx.lower] |
| 89 | ! |
tmp.row[idx.lower] <- tmp.col[idx.lower] |
| 90 | ! |
tmp.col[idx.lower] <- tmp |
| 91 |
} |
|
| 92 | ||
| 93 |
# 4. "~1" means/intercepts |
|
| 94 | ! |
idx <- which(target$block == g & target$op == "~1") |
| 95 | ! |
tmp.mat[idx] <- "m" |
| 96 | ! |
tmp.row[idx] <- match(target$lhs[idx], both.names) |
| 97 | ! |
tmp.col[idx] <- 1L |
| 98 | ||
| 99 |
# 5. "|" th |
|
| 100 |
# not used yet |
|
| 101 | ||
| 102 |
# 6. "~*~" scales |
|
| 103 |
# not used yet |
|
| 104 | ||
| 105 |
# 7. group weights |
|
| 106 | ! |
idx <- which(target$block == g & target$lhs == "group" & |
| 107 | ! |
target$op == "%") |
| 108 | ! |
tmp.mat[idx] <- "gw" |
| 109 | ! |
tmp.row[idx] <- 1L |
| 110 | ! |
tmp.col[idx] <- 1L |
| 111 | ||
| 112 | ! |
if (extra) {
|
| 113 |
# mRows |
|
| 114 | ! |
mmRows <- list( |
| 115 | ! |
ov.idx = 1L, |
| 116 | ! |
A = nboth, |
| 117 | ! |
S = nboth, |
| 118 | ! |
m = nboth, |
| 119 | ! |
gw = 1L |
| 120 |
) |
|
| 121 | ||
| 122 |
# mCols |
|
| 123 | ! |
mmCols <- list( |
| 124 | ! |
ov.idx = nvar, |
| 125 | ! |
A = nboth, |
| 126 | ! |
S = nboth, |
| 127 | ! |
m = 1L, |
| 128 | ! |
gw = 1L |
| 129 |
) |
|
| 130 | ||
| 131 |
# dimNames for LISREL model matrices |
|
| 132 | ! |
mmDimNames <- list( |
| 133 | ! |
ov.idx = list("ov.idx", ov.names),
|
| 134 | ! |
A = list(both.names, both.names), |
| 135 | ! |
S = list(both.names, both.names), |
| 136 | ! |
m = list(both.names, "intercept"), |
| 137 | ! |
gw = list("group", "weight")
|
| 138 |
) |
|
| 139 |
# isSymmetric |
|
| 140 | ! |
mmSymmetric <- list( |
| 141 | ! |
ov.idx = FALSE, |
| 142 | ! |
A = FALSE, |
| 143 | ! |
S = TRUE, |
| 144 | ! |
m = FALSE, |
| 145 | ! |
gw = FALSE |
| 146 |
) |
|
| 147 | ||
| 148 |
# which mm's do we need? (always include ov.idx, A and S) |
|
| 149 | ! |
IDX <- which(target$block == g) |
| 150 | ! |
mmNames <- c("ov.idx", "A", "S")
|
| 151 | ! |
if (meanstructure) {
|
| 152 | ! |
mmNames <- c(mmNames, "m") |
| 153 |
} |
|
| 154 | ! |
if ("gw" %in% tmp.mat[IDX]) {
|
| 155 | ! |
mmNames <- c(mmNames, "gw") |
| 156 |
} |
|
| 157 | ||
| 158 | ! |
REP.mmNames[[g]] <- mmNames |
| 159 | ! |
REP.mmNumber[[g]] <- length(mmNames) |
| 160 | ! |
REP.mmRows[[g]] <- unlist(mmRows[mmNames]) |
| 161 | ! |
REP.mmCols[[g]] <- unlist(mmCols[mmNames]) |
| 162 | ! |
REP.mmDimNames[[g]] <- mmDimNames[mmNames] |
| 163 | ! |
REP.mmSymmetric[[g]] <- unlist(mmSymmetric[mmNames]) |
| 164 |
} # extra |
|
| 165 |
} # nblocks |
|
| 166 | ||
| 167 | ! |
REP <- list( |
| 168 | ! |
mat = tmp.mat, |
| 169 | ! |
row = tmp.row, |
| 170 | ! |
col = tmp.col |
| 171 |
) |
|
| 172 | ||
| 173 |
# always return ov.idx attribute |
|
| 174 | ! |
attr(REP, "ov.idx") <- ov.idx |
| 175 | ! |
attr(REP, "ov.dummy.names.nox") <- ov.dummy.names.nox |
| 176 | ! |
attr(REP, "ov.dummy.names.x") <- ov.dummy.names.x |
| 177 | ||
| 178 | ! |
if (extra) {
|
| 179 | ! |
attr(REP, "mmNames") <- REP.mmNames |
| 180 | ! |
attr(REP, "mmNumber") <- REP.mmNumber |
| 181 | ! |
attr(REP, "mmRows") <- REP.mmRows |
| 182 | ! |
attr(REP, "mmCols") <- REP.mmCols |
| 183 | ! |
attr(REP, "mmDimNames") <- REP.mmDimNames |
| 184 | ! |
attr(REP, "mmSymmetric") <- REP.mmSymmetric |
| 185 |
} |
|
| 186 | ||
| 187 | ! |
REP |
| 188 |
} |
|
| 189 | ||
| 190 |
# the model-implied variance/covariance matrix of the observed variables |
|
| 191 |
lav_ram_sigmahat <- function(MLIST = NULL, delta = NULL) {
|
|
| 192 | ! |
ov.idx <- as.integer(MLIST$ov.idx[1, ]) |
| 193 | ! |
A <- MLIST$A |
| 194 | ! |
S <- MLIST$S |
| 195 | ||
| 196 |
# get (I-A)^{-1}
|
|
| 197 | ! |
IA.inv <- lav_matrix_inverse_iminus(A) |
| 198 | ||
| 199 |
# compute Sigma for all ov and lv |
|
| 200 | ! |
VYeta <- tcrossprod(IA.inv %*% S, IA.inv) |
| 201 | ||
| 202 |
# select only observed part |
|
| 203 | ! |
VY <- VYeta[ov.idx, ov.idx, drop = FALSE] |
| 204 | ||
| 205 |
# if delta, scale |
|
| 206 | ! |
if (!is.null(MLIST$delta) && delta) {
|
| 207 | ! |
nvar <- ncol(VY) |
| 208 | ! |
DELTA <- diag(MLIST$delta[, 1L], nrow = nvar, ncol = nvar) |
| 209 | ! |
VY <- DELTA %*% VY %*% DELTA |
| 210 |
} |
|
| 211 | ||
| 212 | ! |
VY |
| 213 |
} |
|
| 214 | ||
| 215 |
# VETA: the variance/covariance matrix of the latent variables only |
|
| 216 |
lav_ram_veta <- function(MLIST = NULL) {
|
|
| 217 | ! |
ov.idx <- as.integer(MLIST$ov.idx[1, ]) |
| 218 | ! |
A <- MLIST$A |
| 219 | ! |
S <- MLIST$S |
| 220 | ||
| 221 |
# get (I-A)^{-1}
|
|
| 222 | ! |
IA.inv <- lav_matrix_inverse_iminus(A) |
| 223 | ||
| 224 |
# compute Sigma for all ov and lv |
|
| 225 | ! |
VYeta <- tcrossprod(IA.inv %*% S, IA.inv) |
| 226 | ||
| 227 |
# select only latent part |
|
| 228 | ! |
VETA <- VYeta[-ov.idx, -ov.idx, drop = FALSE] |
| 229 | ||
| 230 | ! |
VETA |
| 231 |
} |
|
| 232 | ||
| 233 |
# MuHat: the model-implied means/intercepts |
|
| 234 |
lav_ram_muhat <- function(MLIST = NULL) {
|
|
| 235 | ! |
ov.idx <- as.integer(MLIST$ov.idx[1, ]) |
| 236 | ! |
A <- MLIST$A |
| 237 | ! |
m <- MLIST$m |
| 238 | ||
| 239 |
# shortcut |
|
| 240 | ! |
if (is.null(m)) {
|
| 241 | ! |
return(matrix(0, nrow = length(ov.idx), 1L)) |
| 242 |
} |
|
| 243 | ||
| 244 |
# get (I-A)^{-1}
|
|
| 245 | ! |
IA.inv <- lav_matrix_inverse_iminus(A) |
| 246 | ||
| 247 |
# all means/intercepts |
|
| 248 | ! |
EYeta <- IA.inv %*% m |
| 249 | ||
| 250 |
# select observed only |
|
| 251 | ! |
muhat <- EYeta[ov.idx, , drop = FALSE] |
| 252 | ||
| 253 | ! |
muhat |
| 254 |
} |
|
| 255 | ||
| 256 |
# derivative of 'Sigma' wrt the (freel) elements in A and/or S |
|
| 257 |
lav_ram_dsigma <- function(m = "A", |
|
| 258 |
idx = seq_len(length(MLIST[[m]])), |
|
| 259 |
MLIST = NULL, |
|
| 260 |
vech = TRUE) {
|
|
| 261 | ! |
ov.idx <- as.integer(MLIST$ov.idx[1, ]) |
| 262 | ! |
A <- MLIST$A |
| 263 | ! |
S <- MLIST$S |
| 264 | ||
| 265 | ! |
nvar <- length(ov.idx) |
| 266 | ! |
nboth <- nrow(A) |
| 267 | ||
| 268 |
# shortcut for ov.idx, m, ... |
|
| 269 | ! |
if (!m %in% c("A", "S")) {
|
| 270 | ! |
pstar <- nvar * (nvar + 1) / 2 |
| 271 | ! |
return(matrix(0.0, nrow = pstar, ncol = length(idx))) |
| 272 |
} |
|
| 273 | ||
| 274 |
# get (I-A)^{-1}
|
|
| 275 | ! |
IA.inv <- lav_matrix_inverse_iminus(A) |
| 276 | ||
| 277 | ! |
if (m == "A") {
|
| 278 | ! |
L1 <- (IA.inv %*% S %*% t(IA.inv))[ov.idx, , drop = FALSE] |
| 279 | ! |
KOL.idx <- matrix(1:(nboth * nboth), nboth, nboth, byrow = TRUE)[idx] |
| 280 | ! |
DX <- (L1 %x% IA.inv[ov.idx, , drop = FALSE])[, idx, drop = FALSE] + |
| 281 | ! |
(IA.inv[ov.idx, , drop = FALSE] %x% L1)[, KOL.idx, drop = FALSE] |
| 282 |
# this is not really needed (because we select idx=m.el.idx) |
|
| 283 |
# but just in case we need all elements of beta... |
|
| 284 | ! |
DX[, which(idx %in% lav_matrix_diag_idx(nboth))] <- 0.0 |
| 285 | ! |
} else if (m == "S") {
|
| 286 | ! |
DX <- (IA.inv[ov.idx, , drop = FALSE] %x% IA.inv[ov.idx, , drop = FALSE]) |
| 287 |
# symmetry correction, but keeping all duplicated elements |
|
| 288 |
# since we depend on idx=m.el.idx |
|
| 289 | ! |
lower.idx <- lav_matrix_vech_idx(nboth, diagonal = FALSE) |
| 290 | ! |
upper.idx <- lav_matrix_vechru_idx(nboth, diagonal = FALSE) |
| 291 | ! |
offdiagSum <- DX[, lower.idx] + DX[, upper.idx] |
| 292 | ! |
DX[, c(lower.idx, upper.idx)] <- cbind(offdiagSum, offdiagSum) |
| 293 | ! |
DX <- DX[, idx, drop = FALSE] |
| 294 |
} else {
|
|
| 295 | ! |
lav_msg_stop(gettext("wrong model matrix names:"), m)
|
| 296 |
} |
|
| 297 | ||
| 298 |
# vech? |
|
| 299 | ! |
if (vech) {
|
| 300 | ! |
v.idx <- lav_matrix_vech_idx(nvar) |
| 301 | ! |
DX <- DX[v.idx, , drop = FALSE] |
| 302 |
} |
|
| 303 | ||
| 304 | ! |
DX |
| 305 |
} |
|
| 306 | ||
| 307 |
# derivative of 'Mu' wrt the (free) elements in A and/or m |
|
| 308 |
lav_ram_dmu <- function(m = "A", |
|
| 309 |
idx = seq_len(length(MLIST[[m]])), |
|
| 310 |
MLIST = NULL, |
|
| 311 |
vech = TRUE) {
|
|
| 312 | ! |
ov.idx <- as.integer(MLIST$ov.idx[1, ]) |
| 313 | ! |
A <- MLIST$A |
| 314 | ! |
S <- MLIST$S |
| 315 | ||
| 316 | ! |
nvar <- length(ov.idx) |
| 317 | ! |
nboth <- nrow(A) |
| 318 | ||
| 319 |
# shortcut for ov.idx, m, ... |
|
| 320 | ! |
if (!m %in% c("A", "m")) {
|
| 321 | ! |
return(matrix(0.0, nrow = nvar, ncol = length(idx))) |
| 322 |
} |
|
| 323 | ||
| 324 |
# get (I-A)^{-1}
|
|
| 325 | ! |
IA.inv <- lav_matrix_inverse_iminus(A) |
| 326 | ||
| 327 | ! |
if (m == "A") {
|
| 328 | ! |
DX <- (t(IA.inv %*% MLIST$m) %x% IA.inv)[ov.idx, idx, drop = FALSE] |
| 329 | ! |
} else if (m == "m") {
|
| 330 | ! |
DX <- IA.inv[ov.idx, idx, drop = FALSE] |
| 331 |
} else {
|
|
| 332 | ! |
lav_msg_stop(gettext("wrong model matrix names:"), m)
|
| 333 |
} |
|
| 334 | ||
| 335 | ! |
DX |
| 336 |
} |
|
| 337 | ||
| 338 |
# derivative of ML/GLS objective function F wrt the free parameters |
|
| 339 |
lav_ram_df <- function(MLIST = NULL, Omega = NULL, Omega.mu = NULL) {
|
|
| 340 | ! |
ov.idx <- as.integer(MLIST$ov.idx[1, ]) |
| 341 | ! |
A <- MLIST$A |
| 342 | ! |
S <- MLIST$S |
| 343 | ||
| 344 | ! |
nvar <- length(ov.idx) |
| 345 | ! |
nboth <- nrow(A) |
| 346 | ||
| 347 |
# get (I-A)^{-1}
|
|
| 348 | ! |
IA.inv <- lav_matrix_inverse_iminus(A) |
| 349 | ||
| 350 |
# meanstructure? |
|
| 351 | ! |
meanstructure <- FALSE |
| 352 | ! |
if (!is.null(Omega.mu)) meanstructure <- TRUE |
| 353 | ||
| 354 |
# pre-compute |
|
| 355 | ! |
tIA.inv <- t(IA.inv) |
| 356 | ! |
Omega..IA.inv..S..tIA.inv <- (Omega %*% IA.inv[ov.idx, , drop = FALSE] %*% S %*% t(IA.inv)) |
| 357 | ||
| 358 |
# 1. A |
|
| 359 | ! |
if (meanstructure) {
|
| 360 | ! |
A.deriv <- |
| 361 | ! |
-1.0 * ((t(IA.inv)[, ov.idx, drop = FALSE] %*% (Omega.mu %*% t(MLIST$m)) %*% t(IA.inv)) + |
| 362 | ! |
(tIA.inv[, ov.idx, drop = FALSE] %*% Omega..IA.inv..S..tIA.inv)) |
| 363 |
} else {
|
|
| 364 | ! |
A.deriv <- -1.0 * (tIA.inv[, ov.idx, drop = FALSE] %*% Omega..IA.inv..S..tIA.inv) |
| 365 |
} |
|
| 366 | ||
| 367 |
# 2. S |
|
| 368 | ! |
S.deriv <- -1.0 * (tIA.inv[, ov.idx, drop = FALSE] %*% Omega %*% IA.inv[ov.idx, , drop = FALSE]) |
| 369 | ! |
diag(S.deriv) <- 0.5 * diag(S.deriv) |
| 370 | ||
| 371 | ! |
if (meanstructure) {
|
| 372 | ! |
m.deriv <- -1.0 * t(t(Omega.mu) %*% IA.inv[ov.idx, , drop = FALSE]) |
| 373 |
} else {
|
|
| 374 | ! |
m.deriv <- NULL |
| 375 |
} |
|
| 376 | ||
| 377 | ! |
list( |
| 378 | ! |
A = A.deriv, |
| 379 | ! |
S = S.deriv, |
| 380 | ! |
m = m.deriv |
| 381 |
) |
|
| 382 |
} |
| 1 |
# Factor extraction method(s) |
|
| 2 |
# YR Feb 2020 |
|
| 3 |
# |
|
| 4 |
# - ULS_corner only (for now) |
|
| 5 |
# - just to get better starting values for ESEM |
|
| 6 | ||
| 7 |
# YR July 2020 |
|
| 8 |
# - adding generic function lav_efa_extraction, using eigenvalue based |
|
| 9 |
# approach; ML and ULS |
|
| 10 |
# - 'corner' is an option |
|
| 11 | ||
| 12 |
lav_efa_extraction <- function(S, nfactors = 1L, |
|
| 13 |
method = "ULS", # or ML |
|
| 14 |
corner = FALSE, |
|
| 15 |
reflect = FALSE, order.lv.by = "none", |
|
| 16 |
min.var = 0.0001) {
|
|
| 17 | 4x |
stopifnot(is.matrix(S)) |
| 18 | 4x |
S <- unname(S) |
| 19 | 4x |
method <- tolower(method) |
| 20 | ||
| 21 |
# extract variances |
|
| 22 | 4x |
S.var <- diag(S) |
| 23 | ||
| 24 |
# force S to be pd (eg if we have polychoric correlations) |
|
| 25 | 4x |
S <- lav_matrix_symmetric_force_pd(S, tol = 1e-08) |
| 26 | ||
| 27 |
# convert to correlation matrix (ULS is not scale invariant!) |
|
| 28 | 4x |
R <- cov2cor(S) |
| 29 | ||
| 30 |
# optim.method |
|
| 31 | 4x |
if (method == "uls") {
|
| 32 | ! |
minObjective <- lav_efa_uls_min_objective |
| 33 | ! |
minGradient <- lav_efa_uls_min_gradient |
| 34 | ! |
cache <- lav_efa_uls_init_cache(R = R, nfactors = nfactors) |
| 35 | 4x |
} else if (method == "ml") {
|
| 36 | 4x |
minObjective <- lav_efa_ml_min_objective |
| 37 | 4x |
minGradient <- lav_efa_ml_min_gradient |
| 38 | 4x |
cache <- lav_efa_ml_init_cache(R = R, nfactors = nfactors) |
| 39 |
} else {
|
|
| 40 | ! |
lav_msg_stop(gettext("method must be uls or ml (for now)"))
|
| 41 |
} |
|
| 42 | 4x |
minHessian <- NULL |
| 43 | ||
| 44 |
# optimize |
|
| 45 | 4x |
control.nlminb <- list( |
| 46 | 4x |
eval.max = 20000L, iter.max = 10000L, |
| 47 | 4x |
trace = if (lav_verbose()) {
|
| 48 | ! |
1L |
| 49 |
} else {
|
|
| 50 | 4x |
0L |
| 51 |
}, |
|
| 52 | 4x |
abs.tol = (.Machine$double.eps * 10) |
| 53 |
) |
|
| 54 | 4x |
if (lav_verbose()) {
|
| 55 | ! |
cat("\n")
|
| 56 | ! |
cat("factor extraction iterations using ", method, ":\n")
|
| 57 |
} |
|
| 58 | 4x |
out <- nlminb( |
| 59 | 4x |
start = cache$theta, objective = minObjective, |
| 60 | 4x |
gradient = minGradient, hessian = minHessian, |
| 61 | 4x |
control = control.nlminb, lower = min.var, upper = +1, |
| 62 | 4x |
cache = cache |
| 63 |
) |
|
| 64 | ||
| 65 |
# extract LAMBDA/THETA |
|
| 66 | 4x |
if (method == "uls") {
|
| 67 | ! |
THETA <- diag(out$par * out$par) |
| 68 | ||
| 69 |
# compute LAMBDA |
|
| 70 | ! |
A <- R |
| 71 | ! |
diag(A) <- diag(A) - (out$par * out$par) |
| 72 | ! |
EV <- eigen(A, symmetric = TRUE) |
| 73 | ! |
Omega.1 <- EV$vectors[, 1:nfactors] |
| 74 | ! |
gamma.1 <- EV$values[1:nfactors] |
| 75 | ||
| 76 |
# LAMBDA <- Omega.1 %*% diag(sqrt(gamma.1)) |
|
| 77 | ! |
LAMBDA <- t(t(Omega.1) * sqrt(gamma.1)) |
| 78 | ||
| 79 |
# rescale if the input matrix was not a correlation matrix |
|
| 80 | ! |
LAMBDA <- sqrt(S.var) * LAMBDA |
| 81 | ! |
diag(THETA) <- S.var * diag(THETA) |
| 82 | 4x |
} else if (method == "ml") {
|
| 83 | 4x |
THETA <- diag(out$par * out$par) |
| 84 | ||
| 85 |
# compute LAMBDA |
|
| 86 | 4x |
psi <- out$par |
| 87 | 4x |
A <- t(psi * cache$R.inv) * psi |
| 88 | 4x |
EV <- eigen(A, symmetric = TRUE) |
| 89 | 4x |
Omega.1 <- EV$vectors[, 1L + cache$nvar - seq_len(cache$nfactors), |
| 90 | 4x |
drop = FALSE |
| 91 |
] |
|
| 92 | 4x |
gamma.1 <- EV$values[1L + cache$nvar - seq_len(cache$nfactors)] |
| 93 | ||
| 94 |
# LAMBDA <- diag(psi) %*% Omega.1 %*%sqrt(solve(Gamma.1)-diag(nfactors)) |
|
| 95 | 4x |
tmp1 <- psi * Omega.1 |
| 96 | 4x |
LAMBDA <- t(t(tmp1) * sqrt((1 / gamma.1) - 1)) |
| 97 | ||
| 98 |
# rescale if the input matrix was not a correlation matrix |
|
| 99 | 4x |
LAMBDA <- sqrt(S.var) * LAMBDA |
| 100 | 4x |
diag(THETA) <- S.var * diag(THETA) |
| 101 |
} |
|
| 102 | ||
| 103 |
# corner? |
|
| 104 | 4x |
if (corner) {
|
| 105 |
# rotate to echelon pattern (see echelon() in GPArotation package) |
|
| 106 | 4x |
HEAD <- LAMBDA[seq_len(nfactors), , drop = FALSE] |
| 107 | 4x |
POST <- try(solve(HEAD, t(chol(tcrossprod(HEAD)))), silent = TRUE) |
| 108 | 4x |
okflag <- FALSE |
| 109 | 4x |
if (inherits(POST, "try-error")) { # new in 0.6-18
|
| 110 |
# this will happen if we have identical elements in the columns |
|
| 111 |
# of HEAD (perhaps the data is artificial?) |
|
| 112 |
# -> add some fuzz and try again |
|
| 113 | ! |
SD <- sqrt(mean(abs(HEAD))) * 1e-04 |
| 114 | ! |
fuzz <- matrix(rnorm(nfactors * nfactors, 0, SD), nfactors, nfactors) |
| 115 | ! |
HEAD2 <- HEAD + fuzz |
| 116 | ! |
POST <- try(solve(HEAD2, t(chol(tcrossprod(HEAD2)))), silent = TRUE) |
| 117 | ! |
if (!inherits(POST, "try-error")) {
|
| 118 | ! |
okflag <- TRUE |
| 119 |
} |
|
| 120 |
} else {
|
|
| 121 | 4x |
okflag <- TRUE |
| 122 |
} |
|
| 123 | 4x |
if (okflag) {
|
| 124 | 4x |
LAMBDA <- LAMBDA %*% POST |
| 125 |
} else {
|
|
| 126 | ! |
lav_msg_warn(gettext( |
| 127 | ! |
"rotation of initial factor solution to echelon pattern failed.")) |
| 128 |
} |
|
| 129 |
} |
|
| 130 | ||
| 131 |
# ALWAYS change the sign so that largest element in the column is positive |
|
| 132 |
# neg.max <- apply(LAMBDA, 2, function(x) { sign(x[which.max(abs(x))]) })
|
|
| 133 |
# neg.idx <- which(neg.max < 0) |
|
| 134 |
# if(length(neg.idx) > 0L) {
|
|
| 135 |
# LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE] |
|
| 136 |
# } |
|
| 137 | ||
| 138 |
# ALWAYS change the sign so that diag(LAMBDA) is positive |
|
| 139 | 4x |
neg.idx <- which(diag(LAMBDA) < 0) |
| 140 | 4x |
if (length(neg.idx) > 0L) {
|
| 141 | ! |
LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE] |
| 142 |
} |
|
| 143 | ||
| 144 |
# reflect so that column sum is always positive |
|
| 145 | 4x |
if (reflect) {
|
| 146 | ! |
SUM <- colSums(LAMBDA) |
| 147 | ! |
neg.idx <- which(SUM < 0) |
| 148 | ! |
if (length(neg.idx) > 0L) {
|
| 149 | ! |
LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE] |
| 150 |
} |
|
| 151 |
} |
|
| 152 | ||
| 153 |
# reorder the columns |
|
| 154 | 4x |
if (order.lv.by == "sumofsquares") {
|
| 155 | ! |
L2 <- LAMBDA * LAMBDA |
| 156 | ! |
order.idx <- base::order(colSums(L2), decreasing = TRUE) |
| 157 | 4x |
} else if (order.lv.by == "index") {
|
| 158 |
# reorder using Asparouhov & Muthen 2009 criterion (see Appendix D) |
|
| 159 | ! |
max.loading <- apply(abs(LAMBDA), 2, max) |
| 160 |
# 1: per factor, number of the loadings that are at least 0.8 of the |
|
| 161 |
# highest loading of the factor |
|
| 162 |
# 2: mean of the index numbers |
|
| 163 | ! |
average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
|
| 164 | ! |
mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i])) |
| 165 |
}) |
|
| 166 |
# order of the factors |
|
| 167 | ! |
order.idx <- base::order(average.index) |
| 168 | 4x |
} else if (order.lv.by == "none") {
|
| 169 | 4x |
order.idx <- seq_len(ncol(LAMBDA)) |
| 170 |
} else {
|
|
| 171 | ! |
lav_msg_stop(gettext("order must be index, sumofsquares or none"))
|
| 172 |
} |
|
| 173 | 4x |
LAMBDA <- LAMBDA[, order.idx, drop = FALSE] |
| 174 | ||
| 175 | 4x |
list(LAMBDA = LAMBDA, THETA = THETA) |
| 176 |
} |
|
| 177 | ||
| 178 | ||
| 179 | ||
| 180 |
lav_efa_uls_init_cache <- function(R = NULL, |
|
| 181 |
nfactors = 1L, |
|
| 182 |
parent = parent.frame()) {
|
|
| 183 | ! |
R.inv <- solve(R) |
| 184 | ! |
nvar <- ncol(R) |
| 185 | ||
| 186 |
# starting values for diagonal elements of THETA |
|
| 187 |
# using Joreskog (1966) suggestion: |
|
| 188 | ! |
theta.init <- (1 - nfactors / (2 * nvar)) * 1 / diag(R.inv) |
| 189 | ! |
theta <- sqrt(theta.init) |
| 190 | ||
| 191 | ! |
out <- list2env( |
| 192 | ! |
list( |
| 193 | ! |
R = R, nfactors = nfactors, |
| 194 | ! |
theta = theta |
| 195 |
), |
|
| 196 | ! |
parent = parent |
| 197 |
) |
|
| 198 | ! |
out |
| 199 |
} |
|
| 200 | ||
| 201 |
# x is here the sqrt() of theta! |
|
| 202 |
lav_efa_uls_min_objective <- function(x, cache = NULL) {
|
|
| 203 | ! |
cache$theta <- x |
| 204 | ! |
with(cache, {
|
| 205 | ! |
A <- R |
| 206 | ! |
diag(A) <- diag(A) - (theta * theta) |
| 207 | ! |
EV <- eigen(A, symmetric = TRUE, only.values = TRUE) |
| 208 | ! |
gamma.2 <- EV$values[-seq_len(nfactors)] |
| 209 | ||
| 210 | ! |
res <- 0.5 * sum(gamma.2 * gamma.2) |
| 211 | ! |
return(res) |
| 212 |
}) |
|
| 213 |
} |
|
| 214 | ||
| 215 |
lav_efa_uls_min_gradient <- function(x, cache = NULL) {
|
|
| 216 |
# check if x has changed |
|
| 217 | ! |
if (!all(x == cache$theta)) {
|
| 218 | ! |
cache$theta <- x |
| 219 |
# nothing to do |
|
| 220 |
} |
|
| 221 | ! |
with(cache, {
|
| 222 | ! |
A <- R |
| 223 | ! |
diag(A) <- diag(A) - (theta * theta) |
| 224 | ! |
EV <- eigen(A, symmetric = TRUE) |
| 225 | ! |
Omega.2 <- EV$vectors[, -seq_len(nfactors)] |
| 226 | ! |
gamma.2 <- EV$values[-seq_len(nfactors)] |
| 227 | ||
| 228 | ! |
res <- -2 * theta * colSums(t(Omega.2 * Omega.2) * gamma.2) |
| 229 | ! |
return(res) |
| 230 |
}) |
|
| 231 |
} |
|
| 232 | ||
| 233 | ||
| 234 |
# ML |
|
| 235 |
lav_efa_ml_init_cache <- function(R = NULL, |
|
| 236 |
nfactors = 1L, |
|
| 237 |
parent = parent.frame()) {
|
|
| 238 | 4x |
R.inv <- solve(R) |
| 239 | 4x |
nvar <- ncol(R) |
| 240 | ||
| 241 |
# starting values for diagonal elements of THETA |
|
| 242 |
# using Joreskog (1966) suggestion: |
|
| 243 | 4x |
theta.init <- (1 - nfactors / (2 * nvar)) * 1 / diag(R.inv) |
| 244 | 4x |
theta <- sqrt(theta.init) |
| 245 | ||
| 246 | 4x |
out <- list2env( |
| 247 | 4x |
list( |
| 248 | 4x |
R = R, nfactors = nfactors, R.inv = R.inv, |
| 249 | 4x |
nvar = nvar, # for ML only |
| 250 | 4x |
theta = theta |
| 251 |
), |
|
| 252 | 4x |
parent = parent |
| 253 |
) |
|
| 254 | 4x |
out |
| 255 |
} |
|
| 256 | ||
| 257 | ||
| 258 |
# x is here the sqrt of theta |
|
| 259 |
lav_efa_ml_min_objective <- function(x, cache = NULL) {
|
|
| 260 | 73x |
cache$theta <- x |
| 261 | 73x |
with(cache, {
|
| 262 | 73x |
psi <- theta |
| 263 |
# A <- diag(psi) %*% R.inv %*% diag(psi) |
|
| 264 | 73x |
A <- t(R.inv * psi) * psi |
| 265 | 73x |
EV <- eigen(A, symmetric = TRUE, only.values = TRUE) |
| 266 | 73x |
gamma.2 <- EV$values[(nvar - nfactors):1L] |
| 267 | ||
| 268 | 73x |
res <- sum(log(gamma.2) + 1 / gamma.2 - 1) |
| 269 | 73x |
return(res) |
| 270 |
}) |
|
| 271 |
} |
|
| 272 | ||
| 273 |
lav_efa_ml_min_gradient <- function(x, cache = NULL) {
|
|
| 274 |
# check if x has changed |
|
| 275 | 57x |
if (!all(x == cache$theta)) {
|
| 276 | 1x |
cache$theta <- x |
| 277 |
# nothing to do |
|
| 278 |
} |
|
| 279 | 57x |
with(cache, {
|
| 280 | 57x |
psi <- theta |
| 281 |
# A <- diag(psi) %*% solve(S) %*% diag(psi) |
|
| 282 | 57x |
A <- t(R.inv * psi) * psi |
| 283 | 57x |
EV <- eigen(A, symmetric = TRUE) |
| 284 | ||
| 285 | 57x |
omega.2 <- EV$vectors[, (nvar - nfactors):1L, drop = FALSE] |
| 286 | 57x |
gamma.2 <- EV$values[(nvar - nfactors):1L] |
| 287 | ||
| 288 | 57x |
res <- colSums(t(omega.2 * omega.2) * (1 - 1 / gamma.2)) |
| 289 | 57x |
return(res) |
| 290 |
}) |
|
| 291 |
} |
|
| 292 | ||
| 293 | ||
| 294 | ||
| 295 | ||
| 296 |
# ULS estimation |
|
| 297 |
# |
|
| 298 |
# - but resulting in a upper-corner all zeroes LAMBDA matrix |
|
| 299 |
# - not using eigenvalues/vectors, but minimizing the residuals |
|
| 300 |
# directly |
|
| 301 | ||
| 302 |
# - should give the same results as MINRES (after an orthogonal transformation) |
|
| 303 |
# - unless there are heywood cases; this function allows for negative variances! |
|
| 304 | ||
| 305 |
lav_efa_extraction_uls_corner <- function(S, nfactors = 1L, reflect = TRUE, |
|
| 306 |
order.lv.by = "none") {
|
|
| 307 | ! |
stopifnot(is.matrix(S)) |
| 308 | ! |
S <- unname(S) |
| 309 | ! |
nvar <- nrow(S) |
| 310 | ||
| 311 |
# extract variances |
|
| 312 | ! |
S.var <- diag(S) |
| 313 | ||
| 314 |
# convert to correlation matrix (ULS is not scale invariant!) |
|
| 315 | ! |
R <- cov2cor(S) |
| 316 |
# R.inv <- solve(R) |
|
| 317 | ||
| 318 |
# eigenvalue decomposition (to get starting values for LAMBDA) |
|
| 319 | ! |
EV <- eigen(R, symmetric = TRUE) |
| 320 | ||
| 321 |
# extract first nfac components (assuming no measurement error) |
|
| 322 | ! |
PC <- (EV$vectors[, seq_len(nfactors), drop = FALSE] %*% |
| 323 | ! |
diag(sqrt(EV$values[seq_len(nfactors)]))) |
| 324 | ||
| 325 |
# rotate to echelon pattern (see echelon() in GPArotation package) |
|
| 326 | ! |
HEAD <- PC[seq_len(nfactors), , drop = FALSE] |
| 327 | ! |
LAMBDA <- PC %*% solve(HEAD, t(chol(tcrossprod(HEAD)))) |
| 328 | ||
| 329 | ! |
THETA <- diag(nvar) |
| 330 | ! |
if (nfactors > 1L) {
|
| 331 | ! |
corner.idx <- which(row(LAMBDA) < nfactors & col(LAMBDA) > row(LAMBDA)) |
| 332 | ! |
lambda.idx <- seq_len(nvar * nfactors)[-corner.idx] |
| 333 | ! |
LAMBDA[corner.idx] <- 0 # to make them exactly zero |
| 334 |
} else {
|
|
| 335 | ! |
corner.idx <- integer(0L) |
| 336 | ! |
lambda.idx <- seq_len(nvar) |
| 337 |
} |
|
| 338 | ||
| 339 |
# optim.method |
|
| 340 | ! |
minObjective <- lav_efa_uls_corner_min_objective |
| 341 | ! |
minGradient <- lav_efa_uls_corner_min_gradient |
| 342 | ! |
minHessian <- NULL |
| 343 | ||
| 344 |
# create cache environment |
|
| 345 | ! |
cache <- lav_efa_uls_corner_init_cache( |
| 346 | ! |
LAMBDA = LAMBDA, |
| 347 | ! |
lambda.idx = lambda.idx, R = R |
| 348 |
) |
|
| 349 | ||
| 350 | ! |
control.nlminb <- list( |
| 351 | ! |
eval.max = 20000L, iter.max = 10000L, |
| 352 | ! |
trace = if (lav_verbose()) {
|
| 353 | ! |
1L |
| 354 |
} else {
|
|
| 355 | ! |
0L |
| 356 |
}, |
|
| 357 | ! |
abs.tol = (.Machine$double.eps * 10) |
| 358 |
) |
|
| 359 | ||
| 360 |
# optimize |
|
| 361 | ! |
out <- nlminb( |
| 362 | ! |
start = cache$theta, objective = minObjective, |
| 363 | ! |
gradient = minGradient, hessian = minHessian, |
| 364 | ! |
control = control.nlminb, lower = -1, upper = +1, |
| 365 | ! |
cache = cache |
| 366 |
) |
|
| 367 | ||
| 368 | ! |
LAMBDA[lambda.idx] <- out$par |
| 369 | ! |
diag(THETA) <- 1 - diag(tcrossprod(LAMBDA)) |
| 370 | ||
| 371 |
# rescale if the input matrix was not a correlation matrix |
|
| 372 | ! |
LAMBDA <- sqrt(S.var) * LAMBDA |
| 373 | ! |
diag(THETA) <- S.var * diag(THETA) |
| 374 | ||
| 375 |
# reflect so that column sum is always positive |
|
| 376 | ! |
if (reflect) {
|
| 377 | ! |
SUM <- colSums(LAMBDA) |
| 378 | ! |
neg.idx <- which(SUM < 0) |
| 379 | ! |
if (length(neg.idx) > 0L) {
|
| 380 | ! |
LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE] |
| 381 |
} |
|
| 382 |
} |
|
| 383 | ||
| 384 |
# reorder the columns |
|
| 385 | ! |
if (order.lv.by == "sumofsquares") {
|
| 386 | ! |
L2 <- LAMBDA * LAMBDA |
| 387 | ! |
order.idx <- base::order(colSums(L2), decreasing = TRUE) |
| 388 | ! |
} else if (order.lv.by == "index") {
|
| 389 |
# reorder using Asparouhov & Muthen 2009 criterion (see Appendix D) |
|
| 390 | ! |
max.loading <- apply(abs(LAMBDA), 2, max) |
| 391 |
# 1: per factor, number of the loadings that are at least 0.8 of the |
|
| 392 |
# highest loading of the factor |
|
| 393 |
# 2: mean of the index numbers |
|
| 394 | ! |
average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
|
| 395 | ! |
mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i])) |
| 396 |
}) |
|
| 397 |
# order of the factors |
|
| 398 | ! |
order.idx <- base::order(average.index) |
| 399 | ! |
} else if (order.lv.by == "none") {
|
| 400 | ! |
order.idx <- seq_len(ncol(LAMBDA)) |
| 401 |
} else {
|
|
| 402 | ! |
lav_msg_stop(gettext("order must be index, sumofsquares or none"))
|
| 403 |
} |
|
| 404 | ! |
LAMBDA <- LAMBDA[, order.idx, drop = FALSE] |
| 405 | ||
| 406 | ! |
list(LAMBDA = LAMBDA, THETA = THETA) |
| 407 |
} |
|
| 408 | ||
| 409 | ||
| 410 |
lav_efa_uls_corner_init_cache <- function(LAMBDA = NULL, |
|
| 411 |
lambda.idx = NULL, |
|
| 412 |
R = NULL, |
|
| 413 |
parent = parent.frame()) {
|
|
| 414 | ! |
theta <- LAMBDA[lambda.idx] |
| 415 | ! |
out <- list2env( |
| 416 | ! |
list( |
| 417 | ! |
LAMBDA = LAMBDA, |
| 418 | ! |
lambda.idx = lambda.idx, |
| 419 | ! |
R = R, |
| 420 | ! |
theta = theta |
| 421 |
), |
|
| 422 | ! |
parent = parent |
| 423 |
) |
|
| 424 | ! |
out |
| 425 |
} |
|
| 426 | ||
| 427 |
lav_efa_uls_corner_min_objective <- function(x, cache = NULL) {
|
|
| 428 | ! |
cache$theta <- x |
| 429 | ! |
with(cache, {
|
| 430 | ! |
LAMBDA[lambda.idx] <- theta |
| 431 | ! |
res1 <- lav_matrix_vech(R - tcrossprod(LAMBDA), diagonal = FALSE) |
| 432 | ! |
res2 <- res1 * res1 |
| 433 | ! |
return(sum(res2)) |
| 434 |
}) |
|
| 435 |
} |
|
| 436 | ||
| 437 |
lav_efa_uls_corner_min_gradient <- function(x, cache = NULL) {
|
|
| 438 |
# check if x has changed |
|
| 439 | ! |
if (!all(x == cache$theta)) {
|
| 440 | ! |
cache$theta <- x |
| 441 |
# nothing to do |
|
| 442 |
} |
|
| 443 | ! |
with(cache, {
|
| 444 | ! |
LAMBDA[lambda.idx] <- theta |
| 445 | ! |
Sigma <- tcrossprod(LAMBDA) |
| 446 | ! |
diag(Sigma) <- 1 # diagonal is ignored |
| 447 | ! |
tmp <- -2 * (R - Sigma) %*% LAMBDA |
| 448 | ! |
return(tmp[lambda.idx]) |
| 449 |
}) |
|
| 450 |
} |
| 1 |
# parse lavaan syntax |
|
| 2 |
# YR 14 Jan 2014: move to lav_syntax.R |
|
| 3 |
# YR 17 Oct 2023: add ldw parser |
|
| 4 |
# YR 23 Oct 2024: switch to "c.r" |
|
| 5 |
# LDW 9 Jan 2026: remove c.r option |
|
| 6 | ||
| 7 |
lavParseModelString <- function(model.syntax = "", as.data.frame. = FALSE, |
|
| 8 |
parser = "new", warn = TRUE, debug = FALSE) {
|
|
| 9 | 118x |
if (!missing(debug)) {
|
| 10 | ! |
current.debug <- lav_debug() |
| 11 | ! |
if (lav_debug(debug)) |
| 12 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 13 |
} |
|
| 14 | 118x |
if (!missing(warn)) {
|
| 15 | 2x |
current.warn <- lav_warn() |
| 16 | 2x |
if (lav_warn(warn)) |
| 17 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 18 |
} |
|
| 19 | 118x |
parser <- tolower(parser) |
| 20 | 118x |
if (!parser %in% c("old", "new")) {
|
| 21 | ! |
lav_msg_stop(gettext("parser= argument should
|
| 22 | ! |
be \"old\" or \"new\"")) |
| 23 |
} |
|
| 24 | ||
| 25 | 118x |
if (parser == "old") {
|
| 26 |
# original/classic parser |
|
| 27 | ! |
out <- lav_parse_model_string_orig( |
| 28 | ! |
model.syntax = model.syntax, |
| 29 | ! |
as.data.frame. = as.data.frame. |
| 30 |
) |
|
| 31 |
} else {
|
|
| 32 |
# new parser |
|
| 33 | 118x |
out <- lav_parse_model_string( |
| 34 | 118x |
model.syntax = model.syntax, |
| 35 | 118x |
as.data.frame. = as.data.frame. |
| 36 |
) |
|
| 37 |
} |
|
| 38 | ||
| 39 | 109x |
out |
| 40 |
} |
|
| 41 | ||
| 42 |
# the 'original' parser (up to 0.6-17) |
|
| 43 |
lav_parse_model_string_orig <- function(model.syntax = "", |
|
| 44 |
as.data.frame. = FALSE) {
|
|
| 45 |
# check for empty syntax |
|
| 46 | ! |
if (length(model.syntax) == 0) {
|
| 47 | ! |
lav_msg_stop(gettextf("lavaan ERROR: empty model syntax"))
|
| 48 |
} |
|
| 49 | ||
| 50 |
# remove comments prior to split: |
|
| 51 |
# match from comment character to newline, but don't eliminate newline |
|
| 52 | ! |
model.syntax <- gsub("[#!].*(?=\n)", "", model.syntax, perl = TRUE)
|
| 53 | ||
| 54 |
# replace semicolons with newlines prior to split |
|
| 55 | ! |
model.syntax <- gsub(";", "\n", model.syntax, fixed = TRUE)
|
| 56 | ||
| 57 |
# remove all whitespace prior to split |
|
| 58 | ! |
model.syntax <- gsub("[ \t]+", "", model.syntax, perl = TRUE)
|
| 59 |
# remove any occurrence of >= 2 consecutive newlines to eliminate |
|
| 60 |
# blank statements; this retains a blank newline at the beginning, |
|
| 61 |
# if such exists, but parser will not choke because of start.idx |
|
| 62 | ! |
model.syntax <- gsub("\n{2,}", "\n", model.syntax, perl = TRUE)
|
| 63 | ||
| 64 |
# replace 'strange' tildes (in some locales) (new in 0.6-6) |
|
| 65 | ! |
model.syntax <- gsub(pattern = "\u02dc", replacement = "~", model.syntax) |
| 66 | ||
| 67 |
# break up in lines |
|
| 68 | ! |
model <- unlist(strsplit(model.syntax, "\n")) |
| 69 | ||
| 70 |
# check for multi-line formulas: they contain no operator symbol |
|
| 71 |
# but before we do that, we remove all strings between double quotes |
|
| 72 |
# to avoid confusion with for example equal("f1=~x1") statements
|
|
| 73 |
# model.simple <- gsub("\\(.*\\)\\*", "MODIFIER*", model)
|
|
| 74 | ! |
model.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", model)
|
| 75 | ||
| 76 |
# start.idx <- grep("[~=<>:|%]", model.simple)
|
|
| 77 | ! |
operators <- c( |
| 78 |
"=~", "<~", "~*~", "~~", "~", "==", "<", ">", ":=", |
|
| 79 |
":", "\\|", "%" |
|
| 80 |
) |
|
| 81 | ! |
lhs.modifiers <- c("efa")
|
| 82 | ! |
operators.extra <- c(operators, lhs.modifiers) |
| 83 | ! |
start.idx <- grep(paste(operators.extra, collapse = "|"), model.simple) |
| 84 | ||
| 85 |
# check for empty start.idx: no operator found (new in 0.6-1) |
|
| 86 | ! |
if (length(start.idx) == 0L) {
|
| 87 | ! |
lav_msg_stop(gettext("lavaan ERROR: model does not contain lavaan
|
| 88 | ! |
syntax (no operators found)")) |
| 89 |
} |
|
| 90 | ||
| 91 |
# check for lonely lhs modifiers (only efa() for now): |
|
| 92 |
# if found, remove the following start.idx |
|
| 93 | ! |
efa.idx <- grep("efa\\(", model.simple)
|
| 94 | ! |
op.idx <- grep(paste(operators, collapse = "|"), model.simple) |
| 95 | ! |
both.idx <- which(efa.idx %in% op.idx) |
| 96 | ! |
if (length(both.idx) > 0L) {
|
| 97 | ! |
efa.idx <- efa.idx[-which(efa.idx %in% op.idx)] |
| 98 |
} |
|
| 99 | ! |
if (length(efa.idx) > 0L) {
|
| 100 | ! |
start.idx <- start.idx[-(match(efa.idx, start.idx) + 1L)] |
| 101 |
} |
|
| 102 | ||
| 103 |
# check for non-empty string, without an operator in the first lines |
|
| 104 |
# (new in 0.6-1) |
|
| 105 | ! |
if (start.idx[1] > 1L) {
|
| 106 |
# two possibilities: |
|
| 107 |
# - we have an empty line (ok) |
|
| 108 |
# - the element contains no operator (warn!) |
|
| 109 | ! |
for (el in 1:(start.idx[1] - 1L)) {
|
| 110 |
# not empty? |
|
| 111 | ! |
if (nchar(model.simple[el]) > 0L) {
|
| 112 | ! |
lav_msg_warn(gettextf("lavaan WARNING: no operator found in this
|
| 113 | ! |
syntax line: ", model.simple[el], "\n", |
| 114 | ! |
" This syntax line will be ignored!")) |
| 115 |
} |
|
| 116 |
} |
|
| 117 |
} |
|
| 118 | ||
| 119 | ! |
end.idx <- c(start.idx[-1] - 1, length(model)) |
| 120 | ! |
model.orig <- model |
| 121 | ! |
model <- character(length(start.idx)) |
| 122 | ! |
for (i in seq_along(start.idx)) {
|
| 123 | ! |
model[i] <- paste(model.orig[start.idx[i]:end.idx[i]], collapse = "") |
| 124 |
} |
|
| 125 | ||
| 126 |
# ok, in all remaining lines, we should have an operator outside the "" |
|
| 127 | ! |
model.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", model)
|
| 128 | ! |
idx.wrong <- which(!grepl( |
| 129 | ! |
paste(operators, collapse = "|"), |
| 130 | ! |
model.simple |
| 131 |
)) |
|
| 132 |
# idx.wrong <- which(!grepl("[~=<>:|%]", model.simple))
|
|
| 133 | ! |
if (length(idx.wrong) > 0) {
|
| 134 | ! |
cat("lavaan: missing operator in formula(s):\n")
|
| 135 | ! |
print(model[idx.wrong]) |
| 136 | ! |
lav_msg_stop(gettext("lavaan ERROR: syntax error in lavaan model syntax"))
|
| 137 |
} |
|
| 138 | ||
| 139 |
# but perhaps we have a '+' as the first character? |
|
| 140 | ! |
idx.wrong <- which(grepl("^\\+", model))
|
| 141 | ! |
if (length(idx.wrong) > 0) {
|
| 142 | ! |
cat("lavaan: some formula(s) start with a plus (+) sign:\n")
|
| 143 | ! |
print(model[idx.wrong]) |
| 144 | ! |
lav_msg_stop(gettext("lavaan ERROR: syntax error in lavaan model syntax"))
|
| 145 |
} |
|
| 146 | ||
| 147 | ||
| 148 |
# main operation: flatten formulas into single bivariate pieces |
|
| 149 |
# with a left-hand-side (lhs), an operator (eg "=~"), and a |
|
| 150 |
# right-hand-side (rhs) |
|
| 151 |
# both lhs and rhs can have a modifier |
|
| 152 | ! |
FLAT.lhs <- character(0) |
| 153 | ! |
FLAT.op <- character(0) |
| 154 | ! |
FLAT.rhs <- character(0) |
| 155 | ! |
FLAT.rhs.mod.idx <- integer(0) |
| 156 | ! |
FLAT.block <- integer(0) # keep track of groups using ":" operator |
| 157 | ||
| 158 | ! |
FLAT.fixed <- character(0) # only for display purposes! |
| 159 | ! |
FLAT.start <- character(0) # only for display purposes! |
| 160 | ! |
FLAT.lower <- character(0) # only for display purposes! |
| 161 | ! |
FLAT.upper <- character(0) # only for display purposes! |
| 162 | ! |
FLAT.label <- character(0) # only for display purposes! |
| 163 | ! |
FLAT.prior <- character(0) |
| 164 | ! |
FLAT.efa <- character(0) |
| 165 | ! |
FLAT.rv <- character(0) |
| 166 | ! |
FLAT.idx <- 0L |
| 167 | ! |
MOD.idx <- 0L |
| 168 | ! |
CON.idx <- 0L |
| 169 | ! |
MOD <- vector("list", length = 0L)
|
| 170 | ! |
CON <- vector("list", length = 0L)
|
| 171 | ! |
BLOCK <- 1L |
| 172 | ! |
BLOCK_OP <- FALSE |
| 173 | ! |
for (i in seq_along(model)) {
|
| 174 | ! |
x <- model[i] |
| 175 | ! |
if (lav_debug()) {
|
| 176 | ! |
cat("formula to parse:\n")
|
| 177 | ! |
print(x) |
| 178 | ! |
cat("\n")
|
| 179 |
} |
|
| 180 | ||
| 181 |
# 1. which operator is used? |
|
| 182 | ! |
line.simple <- gsub("\\\".[^\\\"]*\\\"", "LABEL", x)
|
| 183 |
# "=~" operator? |
|
| 184 | ! |
if (grepl("=~", line.simple, fixed = TRUE)) {
|
| 185 | ! |
op <- "=~" |
| 186 |
# "<~" operator? |
|
| 187 | ! |
} else if (grepl("<~", line.simple, fixed = TRUE)) {
|
| 188 | ! |
op <- "<~" |
| 189 | ! |
} else if (grepl("~*~", line.simple, fixed = TRUE)) {
|
| 190 | ! |
op <- "~*~" |
| 191 |
# "~~" operator? |
|
| 192 | ! |
} else if (grepl("~~", line.simple, fixed = TRUE)) {
|
| 193 | ! |
op <- "~~" |
| 194 |
# "~" operator? |
|
| 195 | ! |
} else if (grepl("~", line.simple, fixed = TRUE)) {
|
| 196 | ! |
op <- "~" |
| 197 |
# "==" operator? |
|
| 198 | ! |
} else if (grepl("==", line.simple, fixed = TRUE)) {
|
| 199 | ! |
op <- "==" |
| 200 |
# "<" operator? |
|
| 201 | ! |
} else if (grepl("<", line.simple, fixed = TRUE)) {
|
| 202 | ! |
op <- "<" |
| 203 |
# ">" operator? |
|
| 204 | ! |
} else if (grepl(">", line.simple, fixed = TRUE)) {
|
| 205 | ! |
op <- ">" |
| 206 |
# ":=" operator? |
|
| 207 | ! |
} else if (grepl(":=", line.simple, fixed = TRUE)) {
|
| 208 | ! |
op <- ":=" |
| 209 |
# ":" operator? |
|
| 210 | ! |
} else if (grepl(":", line.simple, fixed = TRUE)) {
|
| 211 | ! |
op <- ":" |
| 212 |
# "|" operator? |
|
| 213 | ! |
} else if (grepl("|", line.simple, fixed = TRUE)) {
|
| 214 | ! |
op <- "|" |
| 215 |
# "%" operator? |
|
| 216 | ! |
} else if (grepl("%", line.simple, fixed = TRUE)) {
|
| 217 | ! |
op <- "%" |
| 218 |
} else {
|
|
| 219 | ! |
lav_msg_stop(gettext("unknown operator in ", model[i]))
|
| 220 |
} |
|
| 221 | ||
| 222 |
# 2. split by operator (only the *first* occurence!) |
|
| 223 |
# check first if equal/label modifier has been used on the LEFT! |
|
| 224 | ! |
if (substr(x, 1, 6) == "label(") {
|
| 225 | ! |
lav_msg_stop(gettext("label modifier can not be used on the left-hand side of the operator"))
|
| 226 |
} |
|
| 227 | ! |
if (op == "|") {
|
| 228 | ! |
op.idx <- regexpr("\\|", x)
|
| 229 | ! |
} else if (op == "~*~") {
|
| 230 | ! |
op.idx <- regexpr("~\\*~", x)
|
| 231 |
} else {
|
|
| 232 | ! |
op.idx <- regexpr(op, x) |
| 233 |
} |
|
| 234 | ! |
lhs <- substr(x, 1L, op.idx - 1L) |
| 235 | ||
| 236 |
# right-hand side string |
|
| 237 | ! |
rhs <- substr(x, op.idx + attr(op.idx, "match.length"), nchar(x)) |
| 238 | ||
| 239 |
# check if first character of rhs is '+'; if so, remove silently |
|
| 240 |
# (for those who copied multiline R input from a website/pdf) |
|
| 241 | ! |
if (substr(rhs, 1, 1) == "+") {
|
| 242 | ! |
rhs <- substr(rhs, 2, nchar(rhs)) |
| 243 |
} |
|
| 244 | ||
| 245 |
# 2b. if operator is "==" or "<" or ">" or ":=", put it in CON |
|
| 246 | ! |
if (op == "==" || op == "<" || op == ">" || op == ":=") {
|
| 247 |
# remove quotes, if any |
|
| 248 | ! |
lhs <- gsub("\\\"", "", lhs)
|
| 249 | ! |
rhs <- gsub("\\\"", "", rhs)
|
| 250 | ! |
CON.idx <- CON.idx + 1L |
| 251 | ! |
CON[[CON.idx]] <- list(op = op, lhs = lhs, rhs = rhs, user = 1L) |
| 252 | ! |
next |
| 253 |
} |
|
| 254 | ||
| 255 |
# 2c if operator is ":", put it in BLOCK |
|
| 256 | ! |
if (op == ":") {
|
| 257 |
# check if rhs is empty (new in 0.6-4) |
|
| 258 | ! |
if (nchar(rhs) == 0L) {
|
| 259 | ! |
lav_msg_stop(gettextf( |
| 260 | ! |
"syntax contains block identifier %s with missing number/label. The |
| 261 | ! |
correct syntax is: \"LHS: RHS\", where LHS is a block identifier (eg |
| 262 | ! |
group or level), and RHS is the group/level/block number or label.", |
| 263 | ! |
dQuote(lhs)) |
| 264 |
) |
|
| 265 |
} |
|
| 266 | ||
| 267 |
# check lhs (new in 0.6-4) - note: class is for nlsem |
|
| 268 | ! |
lhs.orig <- lhs |
| 269 | ! |
lhs <- tolower(lhs) |
| 270 | ! |
if (!lhs %in% c("group", "level", "block", "class")) {
|
| 271 | ! |
lav_msg_stop(gettextf( |
| 272 | ! |
"unknown block identifier: %s. Block identifier should be |
| 273 | ! |
group, level or block.", dQuote(lhs.orig)) |
| 274 |
) |
|
| 275 |
} |
|
| 276 | ||
| 277 | ! |
FLAT.idx <- FLAT.idx + 1L |
| 278 | ! |
FLAT.lhs[FLAT.idx] <- lhs |
| 279 | ! |
FLAT.op[FLAT.idx] <- op |
| 280 | ! |
FLAT.rhs[FLAT.idx] <- rhs |
| 281 | ! |
FLAT.fixed[FLAT.idx] <- "" |
| 282 | ! |
FLAT.start[FLAT.idx] <- "" |
| 283 | ! |
FLAT.lower[FLAT.idx] <- "" |
| 284 | ! |
FLAT.upper[FLAT.idx] <- "" |
| 285 | ! |
FLAT.label[FLAT.idx] <- "" |
| 286 | ! |
FLAT.prior[FLAT.idx] <- "" |
| 287 | ! |
FLAT.efa[FLAT.idx] <- "" |
| 288 | ! |
FLAT.rv[FLAT.idx] <- "" |
| 289 | ! |
FLAT.rhs.mod.idx[FLAT.idx] <- 0L |
| 290 | ! |
if (BLOCK_OP) {
|
| 291 | ! |
BLOCK <- BLOCK + 1L |
| 292 |
} |
|
| 293 | ! |
FLAT.block[FLAT.idx] <- BLOCK |
| 294 | ! |
BLOCK_OP <- TRUE |
| 295 | ! |
next |
| 296 |
} |
|
| 297 | ||
| 298 |
# 3. parse left hand |
|
| 299 | ||
| 300 |
# new in 0.6-3 |
|
| 301 |
# first check if all lhs names are valid (in R); see ?make.names |
|
| 302 |
# and ?reserved |
|
| 303 |
# for example, 'NA' is a reserved keyword, and should not be used |
|
| 304 |
# this usually only happens for latent variable names |
|
| 305 |
# |
|
| 306 |
# check should not come earlier, as we do not need it for :,==,<,>,:= |
|
| 307 | ! |
LHS <- strsplit(lhs, split = "+", fixed = TRUE)[[1]] |
| 308 |
# remove modifiers |
|
| 309 | ! |
LHS <- gsub("^\\S*\\*", "", LHS)
|
| 310 | ! |
if (!all(make.names(LHS) == LHS)) {
|
| 311 | ! |
lav_msg_stop(gettextf( |
| 312 | ! |
"lavaan ERROR: left hand side (lhs) of this formula: %1$s %2$s %3$s |
| 313 | ! |
contains either a reserved word (in R) or an illegal character: %4$s. |
| 314 | ! |
See ?reserved for a list of reserved words in R. Please use a variable |
| 315 | ! |
name that is not a reserved word in R and use only characters, digits, |
| 316 | ! |
or the dot symbol.", |
| 317 | ! |
lhs, op, rhs, dQuote(LHS[!make.names(LHS) == LHS]) |
| 318 |
)) |
|
| 319 |
} |
|
| 320 | ||
| 321 | ! |
lhs.formula <- as.formula(paste("~", lhs))
|
| 322 | ! |
lhs.out <- lav_syntax_parse_rhs(rhs = lhs.formula[[2L]], op = op) |
| 323 | ! |
lhs.names <- names(lhs.out) |
| 324 | ||
| 325 | ||
| 326 |
# new in 0.6-4 |
|
| 327 |
# handle LHS modifiers (if any) |
|
| 328 |
# if(sum(sapply(lhs.out, length)) > 0L) {
|
|
| 329 |
# warning("lavaan WARNING: left-hand side of formula below contains modifier:\n", x,"\n")
|
|
| 330 |
# } |
|
| 331 | ||
| 332 |
# 4. lav_syntax_parse_rhs (as rhs of a single-sided formula) |
|
| 333 | ||
| 334 |
# new 0.5-12: before we do this, replace '0.2?' by 'start(0.2)*' |
|
| 335 |
# requested by the simsem folks |
|
| 336 | ! |
rhs <- gsub("\\(?([-]?[0-9]*\\.?[0-9]*)\\)?\\?", "start(\\1)\\*", rhs)
|
| 337 | ||
| 338 | ||
| 339 | ||
| 340 | ||
| 341 |
# new in 0.6-6, check for rhs NAMES that are reserved names |
|
| 342 |
# like in foo =~ in + out |
|
| 343 | ! |
RHS <- strsplit(rhs, split = "+", fixed = TRUE)[[1]] |
| 344 | ! |
RHS.names <- gsub("^\\S*\\*", "", RHS)
|
| 345 | ! |
BAD <- c("if", "else", "repeat", "while", "function", "for", "in")
|
| 346 | ! |
if (any(RHS.names %in% c(BAD, "NA"))) { # "NA" added in 0.6-8
|
| 347 | ! |
lav_msg_stop(gettextf( |
| 348 | ! |
"lavaan ERROR: right hand side (rhs) of this formula:\n ", |
| 349 | ! |
lhs, " ", op, " ", rhs, |
| 350 | ! |
"\n contains either a reserved word (in R) or an illegal character: ", |
| 351 | ! |
dQuote(RHS.names[which(RHS.names %in% BAD)[1]]), |
| 352 | ! |
"\n See ?reserved for a list of reserved words in R", |
| 353 | ! |
"\n Please use a variable name that is not a reserved word in R", |
| 354 | ! |
"\n and use only characters, digits, or the dot symbol." |
| 355 |
)) |
|
| 356 |
} |
|
| 357 |
# new in 0.6-6, check for rhs LABELS that are reserved names |
|
| 358 |
# like in foo =~ in*bar |
|
| 359 | ! |
RHS <- strsplit(rhs, split = "+", fixed = TRUE)[[1]] |
| 360 | ! |
RHS.labels <- gsub("\\*\\S*$", "", RHS)
|
| 361 | ! |
if (any(RHS.labels %in% BAD)) {
|
| 362 | ! |
lav_msg_stop(gettextf( |
| 363 | ! |
"lavaan ERROR: right hand side (rhs) of this formula:\n ", |
| 364 | ! |
lhs, " ", op, " ", rhs, |
| 365 | ! |
"\n contains either a reserved word (in R) or an illegal character: ", |
| 366 | ! |
dQuote(RHS.names[which(RHS.labels %in% BAD)[1]]), |
| 367 | ! |
"\n See ?reserved for a list of reserved words in R", |
| 368 | ! |
"\n Please use a variable name that is not a reserved word in R", |
| 369 | ! |
"\n and use only characters, digits, or the dot symbol." |
| 370 |
)) |
|
| 371 |
} |
|
| 372 |
# new in 0.6-12: check for three-way interaction terms (which we do |
|
| 373 |
# NOT support) |
|
| 374 | ! |
if (any(grepl(":", RHS.names))) {
|
| 375 | ! |
ncolon <- sapply(gregexpr(":", RHS.names), length)
|
| 376 | ! |
if (any(ncolon > 1L)) {
|
| 377 | ! |
idx <- which(ncolon > 1L) |
| 378 | ! |
lav_msg_stop(gettext( |
| 379 | ! |
"Three-way or higher-order interaction terms (using |
| 380 | ! |
multiple colons) are not supported in the lavaan syntax; please manually |
| 381 | ! |
construct the product terms yourself in the data.frame, give them an |
| 382 | ! |
appropriate name, and then you can use these interaction variables as any |
| 383 | ! |
other (observed) variable in the model syntax. Problematic term is: "), |
| 384 | ! |
RHS.names[idx[1]] |
| 385 |
) |
|
| 386 |
} |
|
| 387 |
} |
|
| 388 | ||
| 389 | ||
| 390 | ! |
rhs.formula <- as.formula(paste("~", rhs))
|
| 391 | ! |
out <- lav_syntax_parse_rhs(rhs = rhs.formula[[2L]], op = op) |
| 392 | ||
| 393 | ! |
if (lav_debug()) print(out) |
| 394 | ||
| 395 |
# for each lhs element |
|
| 396 | ! |
for (l in seq_along(lhs.names)) {
|
| 397 |
# for each rhs element |
|
| 398 | ! |
for (j in seq_along(out)) {
|
| 399 |
# catch intercepts |
|
| 400 | ! |
if (names(out)[j] == "intercept") {
|
| 401 | ! |
if (op == "~") {
|
| 402 | ! |
rhs.name <- "" |
| 403 |
} else {
|
|
| 404 |
# either number (1), or reserved name? |
|
| 405 | ! |
lav_msg_stop(gettextf("lavaan ERROR: right-hand side of
|
| 406 | ! |
formula contains an invalid variable name:\n %s", x)) |
| 407 |
} |
|
| 408 | ! |
} else if (names(out)[j] == "..zero.." && op == "~") {
|
| 409 | ! |
rhs.name <- "" |
| 410 | ! |
} else if (names(out)[j] == "..constant.." && op == "~") {
|
| 411 | ! |
rhs.name <- "" |
| 412 |
} else {
|
|
| 413 | ! |
rhs.name <- names(out)[j] |
| 414 |
} |
|
| 415 | ||
| 416 |
# move this 'check' to post-parse |
|
| 417 |
# if(op == "|") {
|
|
| 418 |
# th.name <- paste("t", j, sep="")
|
|
| 419 |
# if(names(out)[j] != th.name) {
|
|
| 420 |
# stop("lavaan ERROR: threshold ", j, " of variable ",
|
|
| 421 |
# sQuote(lhs.names[1]), " should be named ", |
|
| 422 |
# sQuote(th.name), "; found ", |
|
| 423 |
# sQuote(names(out)[j]), "\n") |
|
| 424 |
# } |
|
| 425 |
# } |
|
| 426 | ||
| 427 |
# catch lhs = rhs and op = "=~" |
|
| 428 | ! |
if (op == "=~" && lhs.names[l] == names(out)[j]) {
|
| 429 | ! |
lav_msg_stop(gettextf("lavaan ERROR: latent variable `", lhs.names[l], "' can not be measured by itself"))
|
| 430 |
} |
|
| 431 | ||
| 432 |
# check if we not already have this combination (in this group) |
|
| 433 |
# 1. asymmetric (=~, ~, ~1) |
|
| 434 | ! |
if (op != "~~") {
|
| 435 | ! |
idx <- which(FLAT.lhs == lhs.names[l] & |
| 436 | ! |
FLAT.op == op & |
| 437 | ! |
FLAT.block == BLOCK & |
| 438 | ! |
FLAT.rhs == rhs.name) |
| 439 | ! |
if (length(idx) > 0L) {
|
| 440 | ! |
lav_msg_stop(gettextf("lavaan ERROR: duplicate model element in: ", model[i]))
|
| 441 |
} |
|
| 442 |
} else {
|
|
| 443 |
# 2. symmetric (~~) |
|
| 444 | ! |
idx <- which(FLAT.lhs == rhs.name & |
| 445 | ! |
FLAT.op == "~~" & |
| 446 | ! |
FLAT.block == BLOCK & |
| 447 | ! |
FLAT.rhs == lhs.names[l]) |
| 448 | ! |
if (length(idx) > 0L) {
|
| 449 | ! |
lav_msg_stop(gettextf("lavaan ERROR: duplicate model element in: ", model[i]))
|
| 450 |
} |
|
| 451 |
} |
|
| 452 | ||
| 453 |
# check if we have a self-loop (y ~ y) |
|
| 454 | ! |
if (op %in% c("~", "<~") && rhs.name == lhs.names[l]) {
|
| 455 |
# stop("lavaan ERROR: lhs and rhs are the same in: ",
|
|
| 456 |
# model[i]) |
|
| 457 |
# this breaks pompom package, example uSEM |
|
| 458 | ! |
lav_msg_warn(gettextf( |
| 459 | ! |
"lavaan WARNING: lhs and rhs are the same in: ", |
| 460 | ! |
model[i] |
| 461 |
)) |
|
| 462 |
} |
|
| 463 | ||
| 464 | ||
| 465 | ! |
FLAT.idx <- FLAT.idx + 1L |
| 466 | ! |
FLAT.lhs[FLAT.idx] <- lhs.names[l] |
| 467 | ! |
FLAT.op[FLAT.idx] <- op |
| 468 | ! |
FLAT.rhs[FLAT.idx] <- rhs.name |
| 469 | ! |
FLAT.block[FLAT.idx] <- BLOCK |
| 470 | ! |
FLAT.fixed[FLAT.idx] <- "" |
| 471 | ! |
FLAT.start[FLAT.idx] <- "" |
| 472 | ! |
FLAT.label[FLAT.idx] <- "" |
| 473 | ! |
FLAT.lower[FLAT.idx] <- "" |
| 474 | ! |
FLAT.upper[FLAT.idx] <- "" |
| 475 | ! |
FLAT.prior[FLAT.idx] <- "" |
| 476 | ! |
FLAT.efa[FLAT.idx] <- "" |
| 477 | ! |
FLAT.rv[FLAT.idx] <- "" |
| 478 | ||
| 479 | ! |
mod <- list() |
| 480 | ! |
rhs.mod <- 0L |
| 481 | ! |
if (length(lhs.out[[l]]$efa) > 0L) {
|
| 482 | ! |
mod$efa <- lhs.out[[l]]$efa |
| 483 | ! |
FLAT.efa[FLAT.idx] <- paste(mod$efa, collapse = ";") |
| 484 | ! |
rhs.mod <- 1L # despite being a LHS modifier |
| 485 |
} |
|
| 486 | ! |
if (length(out[[j]]$fixed) > 0L) {
|
| 487 | ! |
mod$fixed <- out[[j]]$fixed |
| 488 | ! |
FLAT.fixed[FLAT.idx] <- paste(mod$fixed, collapse = ";") |
| 489 | ! |
rhs.mod <- 1L |
| 490 |
} |
|
| 491 | ! |
if (length(out[[j]]$start) > 0L) {
|
| 492 | ! |
mod$start <- out[[j]]$start |
| 493 | ! |
FLAT.start[FLAT.idx] <- paste(mod$start, collapse = ";") |
| 494 | ! |
rhs.mod <- 1L |
| 495 |
} |
|
| 496 | ! |
if (length(out[[j]]$lower) > 0L) {
|
| 497 | ! |
mod$lower <- out[[j]]$lower |
| 498 | ! |
FLAT.lower[FLAT.idx] <- paste(mod$lower, collapse = ";") |
| 499 | ! |
rhs.mod <- 1L |
| 500 |
} |
|
| 501 | ! |
if (length(out[[j]]$upper) > 0L) {
|
| 502 | ! |
mod$upper <- out[[j]]$upper |
| 503 | ! |
FLAT.upper[FLAT.idx] <- paste(mod$upper, collapse = ";") |
| 504 | ! |
rhs.mod <- 1L |
| 505 |
} |
|
| 506 | ! |
if (length(out[[j]]$label) > 0L) {
|
| 507 | ! |
mod$label <- out[[j]]$label |
| 508 | ! |
FLAT.label[FLAT.idx] <- paste(mod$label, collapse = ";") |
| 509 | ! |
rhs.mod <- 1L |
| 510 |
} |
|
| 511 | ! |
if (length(out[[j]]$rv) > 0L) {
|
| 512 | ! |
mod$rv <- out[[j]]$rv |
| 513 | ! |
FLAT.rv[FLAT.idx] <- paste(mod$rv, collapse = ";") |
| 514 | ! |
rhs.mod <- 1L |
| 515 |
} |
|
| 516 | ! |
if (length(out[[j]]$prior) > 0L) {
|
| 517 | ! |
mod$prior <- out[[j]]$prior |
| 518 | ! |
FLAT.prior[FLAT.idx] <- paste(mod$prior, collapse = ";") |
| 519 | ! |
rhs.mod <- 1L |
| 520 |
} |
|
| 521 |
# if(op == "~1" && rhs == "0") {
|
|
| 522 |
# mod$fixed <- 0 |
|
| 523 |
# FLAT.fixed[FLAT.idx] <- paste(mod$fixed, collapse=";") |
|
| 524 |
# rhs.mod <- 1L |
|
| 525 |
# } |
|
| 526 | ! |
if (op == "=~" && rhs == "0") {
|
| 527 | ! |
mod$fixed <- 0 |
| 528 | ! |
FLAT.rhs[FLAT.idx] <- FLAT.lhs[FLAT.idx] |
| 529 | ! |
FLAT.fixed[FLAT.idx] <- paste(mod$fixed, collapse = ";") |
| 530 | ! |
rhs.mod <- 1L |
| 531 |
} |
|
| 532 | ||
| 533 | ! |
FLAT.rhs.mod.idx[FLAT.idx] <- rhs.mod |
| 534 | ||
| 535 | ! |
if (rhs.mod > 0L) {
|
| 536 | ! |
MOD.idx <- MOD.idx + 1L |
| 537 | ! |
MOD[[MOD.idx]] <- mod |
| 538 |
} |
|
| 539 |
} # rhs elements |
|
| 540 |
} # lhs elements |
|
| 541 |
} # model elements |
|
| 542 | ||
| 543 |
# enumerate modifier indices |
|
| 544 | ! |
mod.idx <- which(FLAT.rhs.mod.idx > 0L) |
| 545 | ! |
FLAT.rhs.mod.idx[mod.idx] <- seq_along(mod.idx) |
| 546 | ||
| 547 | ! |
FLAT <- list( |
| 548 | ! |
lhs = FLAT.lhs, op = FLAT.op, rhs = FLAT.rhs, |
| 549 | ! |
mod.idx = FLAT.rhs.mod.idx, block = FLAT.block, |
| 550 | ! |
fixed = FLAT.fixed, start = FLAT.start, |
| 551 | ! |
lower = FLAT.lower, upper = FLAT.upper, |
| 552 | ! |
label = FLAT.label, prior = FLAT.prior, |
| 553 | ! |
efa = FLAT.efa, rv = FLAT.rv |
| 554 |
) |
|
| 555 | ||
| 556 |
# change op for intercepts (for convenience only) |
|
| 557 | ! |
int.idx <- which(FLAT$op == "~" & FLAT$rhs == "") |
| 558 | ! |
if (length(int.idx) > 0L) {
|
| 559 | ! |
FLAT$op[int.idx] <- "~1" |
| 560 |
} |
|
| 561 | ||
| 562 |
# new in 0.6, reorder covariances here! |
|
| 563 | ! |
FLAT <- lav_partable_covariance_reorder(FLAT) |
| 564 | ||
| 565 | ! |
if (as.data.frame.) {
|
| 566 | ! |
FLAT <- as.data.frame(FLAT, stringsAsFactors = FALSE) |
| 567 |
} |
|
| 568 | ||
| 569 |
# new in 0.6-4: check for 'group' within 'level' |
|
| 570 | ! |
if (any(FLAT$op == ":")) {
|
| 571 | ! |
op.idx <- which(FLAT$op == ":") |
| 572 | ! |
if (length(op.idx) < 2L) {
|
| 573 |
# only 1 block identifier? this is weird -> give warning |
|
| 574 | ! |
lav_msg_warn(gettextf("lavaan WARNING: syntax contains only a single block identifier: ", FLAT$lhs[op.idx]))
|
| 575 |
} else {
|
|
| 576 | ! |
first.block <- FLAT$lhs[op.idx[1L]] |
| 577 | ! |
second.block <- FLAT$lhs[op.idx[2L]] |
| 578 | ! |
if (first.block == "level" && |
| 579 | ! |
second.block == "group") {
|
| 580 | ! |
lav_msg_stop(gettextf("lavaan ERROR: groups can not be nested within levels"))
|
| 581 |
} |
|
| 582 |
} |
|
| 583 |
} |
|
| 584 | ||
| 585 | ! |
attr(FLAT, "modifiers") <- MOD |
| 586 | ! |
attr(FLAT, "constraints") <- CON |
| 587 | ||
| 588 | ! |
FLAT |
| 589 |
} |
|
| 590 | ||
| 591 |
lav_syntax_parse_rhs <- function(rhs, op = "") {
|
|
| 592 |
# new version YR 15 dec 2011! |
|
| 593 |
# - no 'equal' field anymore (only labels!) |
|
| 594 |
# - every modifier is evaluated |
|
| 595 |
# - unquoted labels are allowed (eg. x1 + x2 + c(v1,v2,v3)*x3) |
|
| 596 | ||
| 597 |
# fill in rhs list |
|
| 598 | ! |
out <- list() |
| 599 | ! |
repeat {
|
| 600 | ! |
if (length(rhs) == 1L) { # last one and only a single element
|
| 601 | ! |
out <- c(vector("list", 1L), out)
|
| 602 | ! |
NAME <- all.vars(rhs) |
| 603 | ! |
if (length(NAME) > 0L) {
|
| 604 | ! |
names(out)[1L] <- NAME |
| 605 | ! |
} else { # intercept or zero?
|
| 606 | ! |
if (as.character(rhs) == "1") {
|
| 607 | ! |
names(out)[1L] <- "intercept" |
| 608 | ! |
} else if (as.character(rhs) == "0") {
|
| 609 | ! |
names(out)[1L] <- "..zero.." |
| 610 | ! |
out[[1L]]$fixed <- 0 |
| 611 |
} else {
|
|
| 612 | ! |
names(out)[1L] <- "..constant.." |
| 613 | ! |
out[[1L]]$fixed <- 0 |
| 614 |
} |
|
| 615 |
} |
|
| 616 | ! |
break |
| 617 | ! |
} else if (rhs[[1L]] == "*") { # last one, but with modifier
|
| 618 | ! |
out <- c(vector("list", 1L), out)
|
| 619 | ! |
NAME <- all.vars(rhs[[3L]]) |
| 620 | ||
| 621 | ! |
if (length(NAME) > 0L) { # not an intercept
|
| 622 |
# catch interaction term |
|
| 623 | ! |
rhs3.names <- all.names(rhs[[3L]]) |
| 624 | ! |
if (rhs3.names[1L] == ":") {
|
| 625 | ! |
if (length(NAME) == 1) {
|
| 626 | ! |
NAME <- paste(NAME[1L], ":", NAME[1L], sep = "") |
| 627 |
} else {
|
|
| 628 | ! |
NAME <- paste(NAME[1L], ":", NAME[2L], sep = "") |
| 629 |
} |
|
| 630 |
} |
|
| 631 | ! |
names(out)[1L] <- NAME |
| 632 | ! |
} else { # intercept
|
| 633 | ! |
names(out)[1L] <- "intercept" |
| 634 |
} |
|
| 635 | ! |
i.var <- all.vars(rhs[[2L]], unique = FALSE) |
| 636 | ! |
if (length(i.var) > 0L) {
|
| 637 |
# modifier are unquoted labels |
|
| 638 | ! |
out[[1L]]$label <- i.var |
| 639 |
} else {
|
|
| 640 |
# modifer is something else |
|
| 641 | ! |
out[[1L]] <- lav_syntax_get_modifier(rhs[[2L]]) |
| 642 |
} |
|
| 643 | ! |
break |
| 644 | ! |
} else if (rhs[[1L]] == ":") { # last one, but interaction term
|
| 645 | ! |
out <- c(vector("list", 1L), out)
|
| 646 | ! |
NAME <- all.vars(rhs) |
| 647 | ! |
if (length(NAME) == 1) {
|
| 648 | ! |
NAME <- paste(NAME[1L], ":", NAME[1L], sep = "") |
| 649 |
} else {
|
|
| 650 | ! |
NAME <- paste(NAME[1L], ":", NAME[2L], sep = "") |
| 651 |
} |
|
| 652 | ! |
names(out)[1L] <- NAME |
| 653 | ! |
break |
| 654 | ! |
} else if (rhs[[1L]] == "+") { # not last one!
|
| 655 | ||
| 656 |
# three possibilities: |
|
| 657 |
# 1. length(rhs[[3]] == 3), and rhs[[3L]][[1]] == "*" -> modifier |
|
| 658 |
# 2. length(rhs[[3]] == 3), and rhs[[3L]][[1]] == ":" -> interaction |
|
| 659 |
# 3. length(rhs[[3]] == 1) -> single element |
|
| 660 | ||
| 661 | ! |
out <- c(vector("list", 1L), out)
|
| 662 | ||
| 663 |
# modifier or not? |
|
| 664 | ! |
if (length(rhs[[3L]]) == 3L && rhs[[3L]][[1]] == "*") {
|
| 665 |
# modifier!! |
|
| 666 | ! |
NAME <- all.vars(rhs[[3L]][[3]]) |
| 667 | ||
| 668 | ! |
if (length(NAME) > 0L) { # not an intercept
|
| 669 |
# catch interaction term |
|
| 670 | ! |
rhs3.names <- all.names(rhs[[3L]][[3]]) |
| 671 | ! |
if (rhs3.names[1L] == ":") {
|
| 672 | ! |
if (length(NAME) == 1) {
|
| 673 | ! |
NAME <- paste(NAME[1L], ":", NAME[1L], sep = "") |
| 674 |
} else {
|
|
| 675 | ! |
NAME <- paste(NAME[1L], ":", NAME[2L], sep = "") |
| 676 |
} |
|
| 677 |
} |
|
| 678 | ! |
names(out)[1L] <- NAME |
| 679 | ! |
} else { # intercept
|
| 680 | ! |
names(out)[1L] <- "intercept" |
| 681 |
} |
|
| 682 | ! |
i.var <- all.vars(rhs[[3]][[2L]], unique = FALSE) |
| 683 | ! |
if (length(i.var) > 0L) {
|
| 684 |
# modifier are unquoted labels |
|
| 685 | ! |
out[[1L]]$label <- i.var |
| 686 |
} else {
|
|
| 687 |
# modifer is something else |
|
| 688 | ! |
out[[1L]] <- lav_syntax_get_modifier(rhs[[3]][[2L]]) |
| 689 |
} |
|
| 690 | ||
| 691 |
# interaction term? |
|
| 692 | ! |
} else if (length(rhs[[3L]]) == 3L && rhs[[3L]][[1]] == ":") {
|
| 693 |
# interaction term, without modifier |
|
| 694 | ! |
NAME <- all.vars(rhs[[3L]]) |
| 695 | ! |
if (length(NAME) == 1) {
|
| 696 | ! |
NAME <- paste(NAME[1L], ":", NAME[1L], sep = "") |
| 697 |
} else {
|
|
| 698 | ! |
NAME <- paste(NAME[1L], ":", NAME[2L], sep = "") |
| 699 |
} |
|
| 700 | ! |
names(out)[1L] <- NAME |
| 701 | ! |
} else { # no modifier!!
|
| 702 | ! |
NAME <- all.vars(rhs[[3]]) |
| 703 | ! |
if (length(NAME) > 0L) {
|
| 704 | ! |
names(out)[1L] <- NAME |
| 705 | ! |
} else { # intercept or zero?
|
| 706 | ! |
if (as.character(rhs[[3]]) == "1") {
|
| 707 | ! |
names(out)[1L] <- "intercept" |
| 708 | ! |
} else if (as.character(rhs[[3]]) == "0") {
|
| 709 | ! |
names(out)[1L] <- "..zero.." |
| 710 | ! |
out[[1L]]$fixed <- 0 |
| 711 |
} else {
|
|
| 712 | ! |
names(out)[1L] <- "..constant.." |
| 713 | ! |
out[[1L]]$fixed <- 0 |
| 714 |
} |
|
| 715 |
} |
|
| 716 |
} |
|
| 717 | ||
| 718 | ||
| 719 |
# next element |
|
| 720 | ! |
rhs <- rhs[[2L]] |
| 721 |
} else {
|
|
| 722 | ! |
lav_msg_stop(gettextf("lavaan ERROR: I'm confused parsing this line: ", rhs, "\n"))
|
| 723 |
} |
|
| 724 |
} |
|
| 725 | ||
| 726 |
# if multiple elements, check for duplicated elements and merge if found |
|
| 727 | ! |
if (length(out) > 1L) {
|
| 728 | ! |
rhs.names <- names(out) |
| 729 | ! |
while (!is.na(idx <- which(duplicated(rhs.names))[1L])) {
|
| 730 | ! |
dup.name <- rhs.names[idx] |
| 731 | ! |
orig.idx <- match(dup.name, rhs.names) |
| 732 | ! |
merged <- c(out[[orig.idx]], out[[idx]]) |
| 733 | ! |
if (!is.null(merged)) { # be careful, NULL will delete element
|
| 734 | ! |
out[[orig.idx]] <- merged |
| 735 |
} |
|
| 736 | ! |
out <- out[-idx] |
| 737 | ! |
rhs.names <- names(out) |
| 738 |
} |
|
| 739 |
} |
|
| 740 | ||
| 741 |
# if thresholds, check order and reorder if necessary |
|
| 742 |
# if(op == "|") {
|
|
| 743 |
# t.names <- names(out) |
|
| 744 |
# idx <- match(sort(t.names), t.names) |
|
| 745 |
# out <- out[idx] |
|
| 746 |
# } |
|
| 747 | ||
| 748 | ! |
out |
| 749 |
} |
|
| 750 | ||
| 751 | ||
| 752 |
lav_syntax_get_modifier <- function(mod) {
|
|
| 753 | ! |
if (length(mod) == 1L) {
|
| 754 |
# three possibilites: 1) numeric, 2) NA, or 3) quoted character |
|
| 755 | ! |
if (is.numeric(mod)) {
|
| 756 | ! |
return(list(fixed = mod)) |
| 757 |
} |
|
| 758 | ! |
if (is.na(mod)) {
|
| 759 | ! |
return(list(fixed = as.numeric(NA))) |
| 760 |
} |
|
| 761 | ! |
if (is.character(mod)) {
|
| 762 | ! |
return(list(label = mod)) |
| 763 |
} |
|
| 764 | ! |
} else if (mod[[1L]] == "start") {
|
| 765 | ! |
cof <- unlist(lapply(as.list(mod)[-1], |
| 766 | ! |
eval, |
| 767 | ! |
envir = NULL, enclos = NULL |
| 768 |
)) |
|
| 769 | ! |
return(list(start = cof)) |
| 770 | ! |
} else if (mod[[1L]] == "lower") {
|
| 771 | ! |
cof <- unlist(lapply(as.list(mod)[-1], |
| 772 | ! |
eval, |
| 773 | ! |
envir = NULL, enclos = NULL |
| 774 |
)) |
|
| 775 | ! |
return(list(lower = cof)) |
| 776 | ! |
} else if (mod[[1L]] == "upper") {
|
| 777 | ! |
cof <- unlist(lapply(as.list(mod)[-1], |
| 778 | ! |
eval, |
| 779 | ! |
envir = NULL, enclos = NULL |
| 780 |
)) |
|
| 781 | ! |
return(list(upper = cof)) |
| 782 | ! |
} else if (mod[[1L]] == "equal") {
|
| 783 | ! |
label <- unlist(lapply(as.list(mod)[-1], |
| 784 | ! |
eval, |
| 785 | ! |
envir = NULL, enclos = NULL |
| 786 |
)) |
|
| 787 | ! |
return(list(label = label)) |
| 788 | ! |
} else if (mod[[1L]] == "label") {
|
| 789 | ! |
label <- unlist(lapply(as.list(mod)[-1], |
| 790 | ! |
eval, |
| 791 | ! |
envir = NULL, enclos = NULL |
| 792 |
)) |
|
| 793 | ! |
label[is.na(label)] <- "" # catch 'NA' elements in a label |
| 794 | ! |
return(list(label = label)) |
| 795 | ! |
} else if (mod[[1L]] == "rv") {
|
| 796 | ! |
rv <- unlist(lapply(as.list(mod)[-1], |
| 797 | ! |
eval, |
| 798 | ! |
envir = NULL, enclos = NULL |
| 799 |
)) |
|
| 800 | ! |
if (anyNA(rv)) {
|
| 801 | ! |
lav_msg_stop(gettextf("lavaan ERROR: some rv() labels are NA"))
|
| 802 |
} |
|
| 803 | ! |
return(list(rv = rv)) |
| 804 | ! |
} else if (mod[[1L]] == "prior") {
|
| 805 | ! |
prior <- unlist(lapply(as.list(mod)[-1], |
| 806 | ! |
eval, |
| 807 | ! |
envir = NULL, enclos = NULL |
| 808 |
)) |
|
| 809 | ! |
return(list(prior = prior)) |
| 810 | ! |
} else if (mod[[1L]] == "efa") {
|
| 811 | ! |
efa <- unlist(lapply(as.list(mod)[-1], |
| 812 | ! |
eval, |
| 813 | ! |
envir = NULL, enclos = NULL |
| 814 |
)) |
|
| 815 | ! |
return(list(efa = efa)) |
| 816 | ! |
} else if (mod[[1L]] == "c") {
|
| 817 |
# vector: we allow numeric and character only! |
|
| 818 | ! |
cof <- unlist(lapply(as.list(mod)[-1], |
| 819 | ! |
eval, |
| 820 | ! |
envir = NULL, enclos = NULL |
| 821 |
)) |
|
| 822 | ! |
if (all(is.na(cof))) {
|
| 823 | ! |
return(list(fixed = rep(as.numeric(NA), length(cof)))) |
| 824 | ! |
} else if (is.numeric(cof)) {
|
| 825 | ! |
return(list(fixed = cof)) |
| 826 | ! |
} else if (is.character(cof)) {
|
| 827 | ! |
cof[is.na(cof)] <- "" # catch 'NA' elements in a label |
| 828 | ! |
return(list(label = cof)) |
| 829 |
} else {
|
|
| 830 | ! |
lav_msg_stop(gettextf("lavaan ERROR: can not parse modifier:", mod, "\n"))
|
| 831 |
} |
|
| 832 |
} else {
|
|
| 833 |
# unknown expression |
|
| 834 |
# as a final attempt, we will evaluate it and coerce it |
|
| 835 |
# to either a numeric or character (vector) |
|
| 836 | ! |
cof <- try(eval(mod, envir = NULL, enclos = NULL), silent = TRUE) |
| 837 | ! |
if (inherits(cof, "try-error")) {
|
| 838 | ! |
lav_msg_stop(gettextf( |
| 839 | ! |
"lavaan ERROR: evaluating modifier failed: ", |
| 840 | ! |
paste(as.character(mod)[[1]], "()*", sep = ""), "\n" |
| 841 |
)) |
|
| 842 | ! |
} else if (is.numeric(cof)) {
|
| 843 | ! |
return(list(fixed = cof)) |
| 844 | ! |
} else if (is.character(cof)) {
|
| 845 | ! |
return(list(label = cof)) |
| 846 |
} else {
|
|
| 847 | ! |
lav_msg_stop(gettextf( |
| 848 | ! |
"lavaan ERROR: can not parse modifier: ", |
| 849 | ! |
paste(as.character(mod)[[1]], "()*", sep = ""), "\n" |
| 850 |
)) |
|
| 851 |
} |
|
| 852 |
} |
|
| 853 |
} |
| 1 |
# check if the partable is complete/consistent |
|
| 2 |
# we may have added intercepts/variances (user = 0), fixed to zero |
|
| 3 |
lav_partable_check <- function(partable, categorical = FALSE) {
|
|
| 4 | 140x |
check <- TRUE |
| 5 | ||
| 6 |
# check for empy table - or should we WARN? |
|
| 7 | 140x |
if (length(partable$lhs) == 0) {
|
| 8 | ! |
return(check) |
| 9 |
} |
|
| 10 | ||
| 11 |
# get observed/latent variables |
|
| 12 | 140x |
ov.names <- lav_partable_vnames(partable, "ov.nox") # no need to specify exo?? |
| 13 | 140x |
lv.names <- lav_partable_vnames(partable, "lv") |
| 14 | 140x |
lv.names.c <- lav_partable_vnames(partable, "lv.composite") |
| 15 | 140x |
lv.names.noc <- lv.names[!lv.names %in% lv.names.c] |
| 16 | 140x |
all.names <- c(ov.names, lv.names.noc) |
| 17 | 140x |
ov.names.ord <- lav_partable_vnames(partable, "ov.ord") |
| 18 | ||
| 19 | 140x |
nlevels <- lav_partable_nlevels(partable) |
| 20 | ||
| 21 |
# if categorical, we should have some ov.names.ord |
|
| 22 | 140x |
if (categorical && length(ov.names.ord) == 0L) {
|
| 23 | ! |
check <- FALSE |
| 24 | ! |
lav_msg_warn(gettext("parameter table does not contain thresholds"))
|
| 25 |
} |
|
| 26 | ||
| 27 |
# we should have a (residual) variance for *each* ov/lv |
|
| 28 |
# note: if lav_model_partable() has been used, this is always TRUE |
|
| 29 | 140x |
var.idx <- which(partable$op == "~~" & |
| 30 | 140x |
partable$lhs == partable$rhs & !partable$lhs %in% lv.names.c) |
| 31 | 140x |
missing.idx <- which(is.na(match(all.names, partable$lhs[var.idx]))) |
| 32 | 140x |
if (length(missing.idx) > 0L) {
|
| 33 | ! |
check <- FALSE |
| 34 | ! |
lav_msg_warn(gettextf( |
| 35 | ! |
"parameter table does not contain (residual) variances for |
| 36 | ! |
one or more variables: %s", |
| 37 | ! |
lav_msg_view(all.names[missing.idx]))) |
| 38 |
} |
|
| 39 | ||
| 40 |
# meanstructure? |
|
| 41 | 140x |
meanstructure <- any(partable$op == "~1") |
| 42 | ||
| 43 |
# if meanstructure, check for missing intercepts |
|
| 44 |
# note if lav_model_partable() has been used, this is always TRUE |
|
| 45 | 140x |
if (meanstructure) {
|
| 46 |
# we should have a intercept for *each* ov/lv |
|
| 47 | 94x |
int.idx <- which(partable$op == "~1") |
| 48 | 94x |
missing.idx <- which(is.na(match(all.names, partable$lhs[int.idx]))) |
| 49 | 94x |
if (length(missing.idx) > 0L) {
|
| 50 | ! |
check <- FALSE |
| 51 | ! |
lav_msg_warn(gettextf( |
| 52 | ! |
"parameter table does not contain intercepts |
| 53 | ! |
for one or more variables: %s", |
| 54 | ! |
lav_msg_view(all.names[missing.idx]))) |
| 55 |
} |
|
| 56 |
} |
|
| 57 | ||
| 58 |
# ok, now the 'real' checks |
|
| 59 | ||
| 60 |
# do we have added (residual) variances (user = 0) that are fixed to zero? |
|
| 61 |
# this is not necessarily problematic! |
|
| 62 |
# eg. in latent change score models |
|
| 63 |
# therefore, we do NOT give a warning |
|
| 64 | ||
| 65 |
# var.fixed <- which(partable$op == "~~" & |
|
| 66 |
# partable$lhs == partable$rhs & |
|
| 67 |
# partable$user == 0 & |
|
| 68 |
# partable$free == 0) |
|
| 69 |
# if(length(var.fixed) > 0L) {
|
|
| 70 |
# check <- FALSE |
|
| 71 |
# if(warn) {
|
|
| 72 |
# warning("lavaan WARNING: missing (residual) variances are set to",
|
|
| 73 |
# " zero: [", paste(partable$lhs[var.fixed], collapse = " "), "]") |
|
| 74 |
# } |
|
| 75 |
# } |
|
| 76 | ||
| 77 |
# do we have added intercepts (user = 0) that are fixed to zero? |
|
| 78 |
# this is not necessarily problematic; perhaps only for |
|
| 79 |
# exogenous variables? |
|
| 80 | 140x |
ov.ind <- unique(partable$rhs[partable$op == "=~"]) |
| 81 | 140x |
lv.names <- unique(partable$lhs[partable$op == "=~"]) |
| 82 | 140x |
int.fixed <- which(partable$op == "~1" & |
| 83 | 140x |
partable$user == 0L & |
| 84 | 140x |
partable$free == 0L & |
| 85 | 140x |
partable$ustart == 0L & |
| 86 |
# ignore block/group 1 -- typically within level exo |
|
| 87 | 140x |
!(partable$block %% nlevels == 1L) & |
| 88 |
# do not include factors |
|
| 89 | 140x |
!partable$lhs %in% lv.names & |
| 90 |
# do not include ordered variables |
|
| 91 | 140x |
!partable$lhs %in% ov.names.ord & |
| 92 |
# do not include indicators |
|
| 93 | 140x |
!partable$lhs %in% ov.ind) |
| 94 | ||
| 95 | 140x |
if (length(int.fixed) > 0L) {
|
| 96 | ! |
check <- FALSE |
| 97 | ! |
lav_msg_warn(gettext("automatically added intercepts are set to zero:"),
|
| 98 | ! |
lav_msg_view(partable$lhs[int.fixed])) |
| 99 |
} |
|
| 100 | ||
| 101 |
# return check code |
|
| 102 | 140x |
check |
| 103 |
} |
| 1 |
# special functions for the one-factor model |
|
| 2 |
# YR 24 June 2018 |
|
| 3 | ||
| 4 |
# 1-factor model with (only) three indicators: |
|
| 5 |
# no iterations needed; can be solved analytically |
|
| 6 | ||
| 7 |
# denote s11, s22, s33 the diagonal elements, and |
|
| 8 |
# s21, s31, s32 the off-diagonal elements |
|
| 9 | ||
| 10 |
# under the 1-factor model; typically, either psi == 1, or l1 == 1 |
|
| 11 |
# - s11 == l1^2*psi + theta1 |
|
| 12 |
# - s22 == l2^2*psi + theta2 |
|
| 13 |
# - s33 == l3^2*psi + theta3 |
|
| 14 |
# - s21 == l2*l1*psi |
|
| 15 |
# - s31 == l3*l1*psi |
|
| 16 |
# - s32 == l3*l2*psi |
|
| 17 |
# 6 unknowns, 6 knowns |
|
| 18 | ||
| 19 |
# note: if the triad of covariances is negative, there is no |
|
| 20 |
# `valid' solution, for example: |
|
| 21 |
# |
|
| 22 |
# > S |
|
| 23 |
# [,1] [,2] [,3] |
|
| 24 |
# [1,] 1.0 0.6 0.3 |
|
| 25 |
# [2,] 0.6 1.0 -0.1 |
|
| 26 |
# [3,] 0.3 -0.1 1.0 |
|
| 27 |
# |
|
| 28 |
# (note: all eigenvalues are positive) |
|
| 29 | ||
| 30 |
lav_cfa_1fac_3ind <- function(sample.cov, std.lv = FALSE, |
|
| 31 |
warn.neg.triad = TRUE, bounds = TRUE) {
|
|
| 32 |
# check sample cov |
|
| 33 | 57x |
stopifnot(is.matrix(sample.cov)) |
| 34 | 57x |
nRow <- NROW(sample.cov) |
| 35 | 57x |
nCol <- NCOL(sample.cov) |
| 36 | 57x |
stopifnot(nRow == nCol, nRow < 4L, nCol < 4L) |
| 37 | 57x |
nvar <- nRow |
| 38 | ||
| 39 |
# we expect a 3x3 sample covariance matrix |
|
| 40 |
# however, if we get a 2x2 (or 1x1 covariance matrix), do something |
|
| 41 |
# useful anyways... |
|
| 42 | 57x |
if (nvar == 1L) {
|
| 43 |
# lambda = 1, theta = 0, psi = sample.cov[1,1] |
|
| 44 |
# lambda = 1, theta = 0, psi = 1 (for now, until NlsyLinks is fixed) |
|
| 45 | ! |
sample.cov <- matrix(1, 3L, 3L) * 1.0 |
| 46 | 57x |
} else if (nvar == 2L) {
|
| 47 |
# hm, we could force both lambda's to be 1, but if the second |
|
| 48 |
# one is negative, this will surely lead to non-convergence issues |
|
| 49 |
# |
|
| 50 |
# just like lavaan < 0.6.2, we will use the regression of y=marker |
|
| 51 |
# on x=item2 |
|
| 52 | 12x |
mean.2var <- mean(diag(sample.cov)) |
| 53 | 12x |
max.var <- max(diag(sample.cov)) |
| 54 | 12x |
extra <- c(mean.2var, sample.cov[2, 1]) |
| 55 | 12x |
sample.cov <- rbind(cbind(sample.cov, extra, deparse.level = 0), |
| 56 | 12x |
c(extra, max.var), |
| 57 | 12x |
deparse.level = 0 |
| 58 |
) |
|
| 59 |
} |
|
| 60 | ||
| 61 | 57x |
s11 <- sample.cov[1, 1] |
| 62 | 57x |
s22 <- sample.cov[2, 2] |
| 63 | 57x |
s33 <- sample.cov[3, 3] |
| 64 | 57x |
stopifnot(s11 > 0, s22 > 0, s33 > 0) |
| 65 | ||
| 66 | 57x |
s21 <- sample.cov[2, 1] |
| 67 | 57x |
s31 <- sample.cov[3, 1] |
| 68 | 57x |
s32 <- sample.cov[3, 2] |
| 69 |
# note: s21*s31*s32 should be positive! |
|
| 70 | 57x |
neg.triad <- FALSE |
| 71 | 57x |
if (s21 * s31 * s32 < 0) {
|
| 72 | ! |
neg.triad <- TRUE |
| 73 | ! |
if (warn.neg.triad) {
|
| 74 | ! |
lav_msg_warn(gettext("product of the three covariances is negative!"))
|
| 75 |
} |
|
| 76 |
} |
|
| 77 | ||
| 78 |
# first, we assume l1 = 1 |
|
| 79 | 57x |
psi <- (s21 * s31) / s32 # note that we assume |s32|>0 |
| 80 | 57x |
l1 <- 1 |
| 81 | 57x |
l2 <- s32 / s31 # l2 <- s21/psi |
| 82 | 57x |
l3 <- s32 / s21 # l3 <- s31/psi |
| 83 | 57x |
theta1 <- s11 - psi |
| 84 | 57x |
theta2 <- s22 - l2 * l2 * psi |
| 85 | 57x |
theta3 <- s33 - l3 * l3 * psi |
| 86 | ||
| 87 |
# sanity check (new in 0.6-11): apply standard bounds |
|
| 88 | 57x |
if (bounds) {
|
| 89 | 57x |
lower.psi <- s11 - (1 - 0.1) * s11 # we assume REL(y1) >= 0.1 |
| 90 | 57x |
psi <- min(max(psi, lower.psi), s11) |
| 91 | ||
| 92 | 57x |
l2.bound <- sqrt(s22 / lower.psi) |
| 93 | 57x |
l2 <- min(max(-l2.bound, l2), l2.bound) |
| 94 | 57x |
l3.bound <- sqrt(s33 / lower.psi) |
| 95 | 57x |
l3 <- min(max(-l3.bound, l3), l3.bound) |
| 96 | ||
| 97 | 57x |
theta1 <- min(max(theta1, 0), s11) |
| 98 | 57x |
theta2 <- min(max(theta2, 0), s22) |
| 99 | 57x |
theta3 <- min(max(theta3, 0), s33) |
| 100 |
} |
|
| 101 | ||
| 102 | 57x |
lambda <- c(l1, l2, l3) |
| 103 | 57x |
theta <- c(theta1, theta2, theta3) |
| 104 | ||
| 105 | ||
| 106 |
# std.lv? |
|
| 107 | 57x |
if (std.lv) {
|
| 108 |
# we allow for negative psi (if bounds = FALSE) |
|
| 109 | 2x |
lambda <- lambda * sign(psi) * sqrt(abs(psi)) |
| 110 | 2x |
psi <- 1 |
| 111 |
} |
|
| 112 | ||
| 113 |
# special cases |
|
| 114 | 57x |
if (nvar == 1L) {
|
| 115 | ! |
lambda <- lambda[1] |
| 116 | ! |
theta <- theta[1] |
| 117 | 57x |
} else if (nvar == 2L) {
|
| 118 | 12x |
lambda <- lambda[1:2] |
| 119 | 12x |
theta <- theta[1:2] |
| 120 | 12x |
psi <- psi / 2 # smaller works better? |
| 121 |
} |
|
| 122 | ||
| 123 | 57x |
list(lambda = lambda, theta = theta, psi = psi, neg.triad = neg.triad) |
| 124 |
} |
|
| 125 | ||
| 126 |
# FABIN (Hagglund, 1982) |
|
| 127 |
# 1-factor only |
|
| 128 |
lav_cfa_1fac_fabin <- function(S, lambda.only = FALSE, method = "fabin3", |
|
| 129 |
std.lv = FALSE, bounds = TRUE) {
|
|
| 130 |
# check arguments |
|
| 131 | 83x |
if (std.lv) {
|
| 132 | 2x |
lambda.only <- FALSE # we need psi |
| 133 |
} |
|
| 134 | ||
| 135 | 83x |
nvar <- NCOL(S) |
| 136 | ||
| 137 |
# catch nvar < 4 |
|
| 138 | 83x |
if (nvar < 4L) {
|
| 139 | 57x |
out <- lav_cfa_1fac_3ind( |
| 140 | 57x |
sample.cov = S, std.lv = std.lv, |
| 141 | 57x |
warn.neg.triad = FALSE |
| 142 |
) |
|
| 143 | 57x |
return(out) |
| 144 |
} |
|
| 145 | ||
| 146 |
# 1. lambda |
|
| 147 | 26x |
lambda <- numeric(nvar) |
| 148 | 26x |
lambda[1L] <- 1.0 |
| 149 | 26x |
for (i in 2:nvar) {
|
| 150 | 86x |
idx3 <- (1:nvar)[-c(i, 1L)] |
| 151 | 86x |
s23 <- S[i, idx3] |
| 152 | 86x |
S31 <- S13 <- S[idx3, 1L] |
| 153 | 86x |
if (method == "fabin3") {
|
| 154 | 86x |
S33 <- S[idx3, idx3] |
| 155 | 86x |
tmp <- try(solve(S33, S31), silent = TRUE) # GaussJordanPivot is |
| 156 |
# slighty more efficient |
|
| 157 | 86x |
if (inherits(tmp, "try-error")) {
|
| 158 | 20x |
lambda[i] <- sum(s23 * S31) / sum(S13^2) |
| 159 |
} else {
|
|
| 160 | 66x |
lambda[i] <- sum(s23 * tmp) / sum(S13 * tmp) |
| 161 |
} |
|
| 162 |
} else {
|
|
| 163 | ! |
lambda[i] <- sum(s23 * S31) / sum(S13^2) |
| 164 |
} |
|
| 165 |
} |
|
| 166 | ||
| 167 |
# bounds? (new in 0.6-11) |
|
| 168 | 26x |
if (bounds) {
|
| 169 | 26x |
s11 <- S[1, 1] |
| 170 | 26x |
lower.psi <- s11 - (1 - 0.1) * s11 # we assume REL(y1) >= 0.1 |
| 171 | 26x |
for (i in 2:nvar) {
|
| 172 | 86x |
l.bound <- sqrt(S[i, i] / lower.psi) |
| 173 | 86x |
lambda[i] <- min(max(-l.bound, lambda[i]), l.bound) |
| 174 |
} |
|
| 175 |
} |
|
| 176 | ||
| 177 | 26x |
if (lambda.only) {
|
| 178 | 26x |
return(list( |
| 179 | 26x |
lambda = lambda, psi = as.numeric(NA), |
| 180 | 26x |
theta = rep(as.numeric(NA), nvar) |
| 181 |
)) |
|
| 182 |
} |
|
| 183 | ||
| 184 |
# 2. theta |
|
| 185 | ||
| 186 |
# GLS version |
|
| 187 |
# W <- solve(S) |
|
| 188 |
# LAMBDA <- as.matrix(lambda) |
|
| 189 |
# A1 <- solve(t(LAMBDA) %*% W %*% LAMBDA) %*% t(LAMBDA) %*% W |
|
| 190 |
# A2 <- W %*% LAMBDA %*% A1 |
|
| 191 | ||
| 192 |
# tmp1 <- W*W - A2*A2 |
|
| 193 |
# tmp2 <- diag( W %*% S %*% W - A2 %*% S %*% A2 ) |
|
| 194 |
# theta.diag <- solve(tmp1, tmp2) |
|
| 195 | ||
| 196 |
# 'least squares' version, assuming W = I |
|
| 197 | ! |
D <- tcrossprod(lambda) / sum(lambda^2) |
| 198 | ! |
theta <- solve(diag(nvar) - D * D, diag(S - (D %*% S %*% D))) |
| 199 | ||
| 200 |
# 3. psi (W=I) |
|
| 201 | ! |
S1 <- S - diag(theta) |
| 202 | ! |
l2 <- sum(lambda^2) |
| 203 | ! |
psi <- sum(colSums(as.numeric(lambda) * S1) * lambda) / (l2 * l2) |
| 204 | ||
| 205 |
# std.lv? |
|
| 206 | ! |
if (std.lv) {
|
| 207 |
# we allow for negative psi |
|
| 208 | ! |
lambda <- lambda * sign(psi) * sqrt(abs(psi)) |
| 209 | ! |
psi <- 1 |
| 210 |
} |
|
| 211 | ||
| 212 | ! |
list(lambda = lambda, theta = theta, psi = psi) |
| 213 |
} |
| 1 |
## STEP 1b: compute Var(eta) and E(eta) per block |
|
| 2 |
## only needed for local/fsr approach! |
|
| 3 |
lav_sam_step1_local <- function(STEP1 = NULL, FIT = NULL, Y = NULL, |
|
| 4 |
sam.method = "local", |
|
| 5 |
local.options = list( |
|
| 6 |
M.method = "ML", |
|
| 7 |
lambda.correction = TRUE, |
|
| 8 |
alpha.correction = 0L, |
|
| 9 |
twolevel.method = "h1" |
|
| 10 |
), |
|
| 11 |
return.cov.iveta2 = TRUE, |
|
| 12 |
return.FS = FALSE) {
|
|
| 13 |
# local.M.method |
|
| 14 | ! |
local.M.method <- toupper(local.options[["M.method"]]) |
| 15 | ! |
if (!local.M.method %in% c("GLS", "ML", "ULS")) {
|
| 16 | ! |
lav_msg_stop(gettext( |
| 17 | ! |
"local option M.method should be one of ML, GLS or ULS.")) |
| 18 |
} |
|
| 19 | ||
| 20 | ! |
lavoptions <- FIT@Options |
| 21 | ! |
lavpta <- FIT@pta |
| 22 | ! |
nblocks <- lavpta$nblocks |
| 23 | ||
| 24 |
# flags |
|
| 25 | ! |
lv.interaction.flag <- FALSE |
| 26 | ! |
lv.higherorder.flag <- FALSE |
| 27 | ! |
if (length(unlist(lavpta$vnames$lv.interaction)) > 0L) {
|
| 28 | ! |
lv.interaction.flag <- TRUE |
| 29 |
} |
|
| 30 | ! |
if (length(unlist(lavpta$vnames$lv.ind)) > 0L) {
|
| 31 | ! |
lv.higherorder.flag <- TRUE |
| 32 |
} |
|
| 33 | ||
| 34 | ! |
if (lav_verbose()) {
|
| 35 | ! |
cat("Constructing the mapping matrix using the ",
|
| 36 | ! |
local.M.method, " method ... ", |
| 37 | ! |
sep = "" |
| 38 |
) |
|
| 39 |
} |
|
| 40 | ||
| 41 |
# all the measurement parameters are already stored in PT |
|
| 42 | ! |
PT <- STEP1$PT |
| 43 | ! |
if (FIT@Model@ceq.simple.only) {
|
| 44 | ! |
x.free <- PT$est[PT$free > 0 & !duplicated(PT$free)] |
| 45 |
} else {
|
|
| 46 | ! |
x.free <- PT$est[PT$free > 0] |
| 47 |
} |
|
| 48 |
# check for NA values (eg in BETA); set them to zero |
|
| 49 | ! |
x.free[!is.finite(x.free)] <- 0 |
| 50 | ||
| 51 | ! |
lavmodel.tmp <- lav_model_set_parameters(FIT@Model, x = x.free) |
| 52 | ! |
LAMBDA <- THETA <- BETA <- PSI <- NU <- DELTA <- NULL |
| 53 | ||
| 54 |
# create LAMBDA |
|
| 55 | ! |
lambda.idx <- which(names(FIT@Model@GLIST) == "lambda") |
| 56 | ! |
LAMBDA <- lavmodel.tmp@GLIST[lambda.idx] |
| 57 | ||
| 58 |
# create THETA |
|
| 59 | ! |
theta.idx <- which(names(FIT@Model@GLIST) == "theta") |
| 60 | ! |
THETA <- lavmodel.tmp@GLIST[theta.idx] |
| 61 | ||
| 62 |
# NU |
|
| 63 | ! |
if (FIT@Model@meanstructure) {
|
| 64 | ! |
nu.idx <- which(names(FIT@Model@GLIST) == "nu") |
| 65 | ! |
NU <- lavmodel.tmp@GLIST[nu.idx] |
| 66 |
} |
|
| 67 | ||
| 68 |
# DELTA |
|
| 69 | ! |
if (FIT@Model@categorical || FIT@Model@correlation) {
|
| 70 | ! |
delta.idx <- which(names(FIT@Model@GLIST) == "delta") |
| 71 | ! |
DELTA <- lavmodel.tmp@GLIST[delta.idx] |
| 72 |
} |
|
| 73 | ||
| 74 |
# BETA/PSI |
|
| 75 | ! |
if (lv.higherorder.flag) {
|
| 76 | ! |
beta.idx <- which(names(FIT@Model@GLIST) == "beta") |
| 77 | ! |
BETA <- lavmodel.tmp@GLIST[beta.idx] |
| 78 | ! |
psi.idx <- which(names(FIT@Model@GLIST) == "psi") |
| 79 | ! |
PSI <- lavmodel.tmp@GLIST[psi.idx] |
| 80 |
} |
|
| 81 | ||
| 82 |
# GAMMA (only for names, if conditional.x) |
|
| 83 |
#if (FIT@Model@conditional.x) {
|
|
| 84 |
# gamma.idx <- which(names(FIT@Model@GLIST) == "gamma") |
|
| 85 |
#} |
|
| 86 | ||
| 87 |
# handle dummy's + higher-order + rank-deficient |
|
| 88 | ! |
lsam.analytic.flag <- rep(TRUE, nblocks) |
| 89 | ! |
L.veta <- vector("list", length = nblocks)
|
| 90 | ! |
for (b in seq_len(nblocks)) {
|
| 91 |
# new in 0.6-10: check if any indicators are also involved |
|
| 92 |
# in the structural part; if so, set THETA row/col to zero |
|
| 93 |
# and make sure LAMBDA element is correctly set |
|
| 94 |
# (we also need to adjust M) |
|
| 95 | ! |
dummy.ov.idx <- FIT@Model@ov.y.dummy.ov.idx[[b]] |
| 96 | ! |
dummy.lv.idx <- FIT@Model@ov.y.dummy.lv.idx[[b]] |
| 97 | ! |
if (length(dummy.ov.idx)) {
|
| 98 | ! |
THETA[[b]][dummy.ov.idx, ] <- 0 |
| 99 | ! |
THETA[[b]][, dummy.ov.idx] <- 0 |
| 100 | ! |
LAMBDA[[b]][dummy.ov.idx, ] <- 0 |
| 101 | ! |
LAMBDA[[b]][cbind(dummy.ov.idx, dummy.lv.idx)] <- 1 |
| 102 |
} |
|
| 103 | ! |
if (FIT@Model@meanstructure) {
|
| 104 | ! |
if (length(dummy.ov.idx)) {
|
| 105 | ! |
NU[[b]][dummy.ov.idx, 1] <- 0 |
| 106 |
} |
|
| 107 |
} |
|
| 108 | ||
| 109 |
# get ALL lv names (including dummy ov.x/ov.y) |
|
| 110 | ! |
lv.names <- FIT@Model@dimNames[[lambda.idx[b]]][[2L]] |
| 111 | ||
| 112 |
# if conditional.x, we must add the ov.names.x manually |
|
| 113 |
# if (FIT@Model@conditional.x) {
|
|
| 114 |
# exo.names <- FIT@Model@dimNames[[gamma.idx[b]]][[2L]] |
|
| 115 |
# lv.names <- c(lv.names, exo.names) |
|
| 116 |
# } |
|
| 117 | ||
| 118 |
# handle higher-order factors here |
|
| 119 | ! |
if (length(lavpta$vidx$lv.ind[[b]]) > 0L) {
|
| 120 | ! |
lv.ind.names <- lavpta$vnames$lv.ind[[b]] |
| 121 | ! |
lv.target <- lv.names[!lv.names %in% lv.ind.names] |
| 122 | ||
| 123 | ! |
target.idx <- match(lv.target, lv.names) |
| 124 | ! |
other.idx <- seq_len(length(lv.names))[-target.idx] |
| 125 | ||
| 126 | ! |
this.beta <- BETA[[b]] |
| 127 | ! |
this.beta[is.na(this.beta)] <- 0 |
| 128 | ||
| 129 | ! |
IB <- diag(nrow(this.beta)) - this.beta |
| 130 | ! |
IB.inv <- solve(IB) |
| 131 | ! |
LB.inv <- LAMBDA[[b]] %*% IB.inv |
| 132 | ||
| 133 |
# replace LAMBDA |
|
| 134 | ! |
LAMBDA[[b]] <- LB.inv[,target.idx,drop = FALSE] |
| 135 | ||
| 136 | ! |
PSI.other <- PSI[[b]][other.idx, other.idx, drop = FALSE] |
| 137 | ! |
LB.inv2 <- LB.inv[, other.idx, drop = FALSE] |
| 138 | ||
| 139 |
# replace THETA |
|
| 140 | ! |
THETA[[b]] <- LB.inv2 %*% PSI.other %*% t(LB.inv2) + THETA[[b]] |
| 141 |
} |
|
| 142 | ||
| 143 |
# check if LAMBDA has full column rank |
|
| 144 | ! |
this.lambda <- LAMBDA[[b]] |
| 145 | ! |
if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
|
| 146 | ! |
if (length(lavpta$vidx$lv.ind[[b]]) > 0L) {
|
| 147 | ! |
rm.idx <- c(match(lavpta$vnames$lv.ind[[b]], lv.names), |
| 148 | ! |
match(lavpta$vnames$lv.interaction[[b]], lv.names)) |
| 149 | ! |
this.lambda <- this.lambda[, -rm.idx, drop = FALSE] |
| 150 |
} else {
|
|
| 151 | ! |
rm.idx <- match(lavpta$vnames$lv.interaction[[b]], lv.names) |
| 152 | ! |
this.lambda <- this.lambda[, -rm.idx, drop = FALSE] |
| 153 |
} |
|
| 154 |
} |
|
| 155 | ! |
if (qr(this.lambda)$rank < ncol(this.lambda)) {
|
| 156 | ! |
if (sam.method == "local" && !lv.interaction.flag) {
|
| 157 | ! |
lsam.analytic.flag[b] <- FALSE |
| 158 |
# we will try an iterative solution |
|
| 159 |
} else {
|
|
| 160 |
# eg cfsr or lv interactions: no idea what to do here (yet) |
|
| 161 | ! |
print(this.lambda) |
| 162 | ! |
lav_msg_stop(gettext( |
| 163 | ! |
"LAMBDA has no full column rank. Please use sam.method = global")) |
| 164 |
} |
|
| 165 |
} |
|
| 166 | ||
| 167 |
# if lambda has full rank, check if cov.lv is unrestricted |
|
| 168 | ! |
if (!lsam.analytic.flag[b]) {
|
| 169 | ! |
VETA.symbolic <- lav_sam_veta_partable(FIT, block = b) |
| 170 |
# this is the tricky thing: which rows/cols should we remove? |
|
| 171 |
# none for now |
|
| 172 | ! |
if (FIT@Options$std.lv) {
|
| 173 | ! |
veta.symbolic <- lav_matrix_vech(VETA.symbolic, diagonal = FALSE) |
| 174 |
} else {
|
|
| 175 | ! |
veta.symbolic <- lav_matrix_vech(VETA.symbolic, diagonal = TRUE) |
| 176 |
} |
|
| 177 | ! |
if (any(veta.symbolic == 0)) {
|
| 178 | ! |
lsam.analytic.flag[b] <- FALSE |
| 179 | ! |
nfac <- ncol(VETA.symbolic) |
| 180 | ! |
m.free <- which(VETA.symbolic != 0) |
| 181 | ! |
tmp <- lav_matrix_vech_reverse(lav_matrix_vech_idx(nfac)) |
| 182 | ! |
x.free <- tmp[which(VETA.symbolic != 0)] |
| 183 | ! |
unique.idx <- unique(x.free) |
| 184 | ! |
row.idx <- match(x.free, unique.idx) |
| 185 | ! |
L.psi <- matrix(0L, nrow = nfac * nfac, ncol = length(unique.idx)) |
| 186 | ! |
IDX <- cbind(m.free, row.idx) |
| 187 | ! |
L.psi[IDX] <- 1L |
| 188 | ! |
L.veta[[b]] <- L.psi |
| 189 |
} |
|
| 190 |
} |
|
| 191 |
} # b |
|
| 192 | ||
| 193 |
# store LAMBDA/THETA/NU per block |
|
| 194 | ! |
STEP1$LAMBDA <- LAMBDA |
| 195 | ! |
STEP1$THETA <- THETA |
| 196 | ! |
if (FIT@Model@meanstructure) {
|
| 197 | ! |
STEP1$NU <- NU |
| 198 |
} |
|
| 199 | ! |
if (FIT@Model@categorical || FIT@Model@correlation) {
|
| 200 | ! |
STEP1$DELTA <- DELTA |
| 201 |
} |
|
| 202 | ||
| 203 | ! |
VETA <- vector("list", nblocks)
|
| 204 | ! |
MSM.. <- vector("list", nblocks)
|
| 205 | ! |
MTM.. <- vector("list", nblocks)
|
| 206 | ! |
FS.mean <- vector("list", nblocks)
|
| 207 |
#FS.gamma <- vector("list", nblocks)
|
|
| 208 | ! |
FS <- vector("list", nblocks)
|
| 209 | ! |
COV.IVETA2 <- vector("list", nblocks)
|
| 210 | ! |
REL <- vector("list", nblocks)
|
| 211 | ! |
alpha <- vector("list", nblocks)
|
| 212 | ! |
lambda <- vector("list", nblocks)
|
| 213 | ! |
if (lavoptions$meanstructure) {
|
| 214 | ! |
EETA <- vector("list", nblocks)
|
| 215 |
} else {
|
|
| 216 | ! |
EETA <- NULL |
| 217 |
} |
|
| 218 |
#fs.outlier.idx <- vector("list", nblocks)
|
|
| 219 | ! |
M <- vector("list", nblocks)
|
| 220 | ! |
LV.NAMES <- vector("list", nblocks)
|
| 221 | ||
| 222 |
# if (lv.interaction.flag && is.null(FS)) {
|
|
| 223 |
# # compute Bartlett factor scores |
|
| 224 |
# FS <- vector("list", nblocks)
|
|
| 225 |
# # FS.mm <- lapply(STEP1$MM.FIT, lav_predict_eta_bartlett) |
|
| 226 |
# FS.mm <- lapply(STEP1$MM.FIT, lavPredict, |
|
| 227 |
# method = "Bartlett", |
|
| 228 |
# drop.list.single.group = FALSE |
|
| 229 |
# ) |
|
| 230 |
# for (b in seq_len(nblocks)) {
|
|
| 231 |
# tmp <- lapply( |
|
| 232 |
# 1:length(STEP1$MM.FIT), |
|
| 233 |
# function(x) FS.mm[[x]][[b]] |
|
| 234 |
# ) |
|
| 235 |
# LABEL <- unlist(lapply(tmp, colnames)) |
|
| 236 |
# FS[[b]] <- do.call("cbind", tmp)
|
|
| 237 |
# colnames(FS[[b]]) <- LABEL |
|
| 238 |
# FS[[b]] <- FIT@Data@X[[b]] %*% |
|
| 239 | ||
| 240 |
# # dummy lv's? (both 'x' and 'y'!) |
|
| 241 |
# dummy.ov.idx <- c(FIT@Model@ov.y.dummy.ov.idx[[b]], |
|
| 242 |
# FIT@Model@ov.x.dummy.ov.idx[[b]]) |
|
| 243 |
# dummy.lv.idx <- c(FIT@Model@ov.y.dummy.lv.idx[[b]], |
|
| 244 |
# FIT@Model@ov.x.dummy.lv.idx[[b]]) |
|
| 245 |
# if (length(dummy.lv.idx) > 0L) {
|
|
| 246 |
# FS.obs <- FIT@Data@X[[b]][, dummy.ov.idx, drop = FALSE] |
|
| 247 |
# colnames(FS.obs) <- FIT@Data@ov.names[[b]][dummy.ov.idx] |
|
| 248 |
# FS[[b]] <- cbind(FS[[b]], FS.obs) |
|
| 249 |
# } |
|
| 250 |
# } |
|
| 251 |
# } |
|
| 252 | ||
| 253 |
# compute VETA/EETA per block |
|
| 254 | ! |
for (b in seq_len(nblocks)) {
|
| 255 | ||
| 256 |
# which group is this? |
|
| 257 | ! |
this.group <- floor(b / FIT@Data@nlevels + 0.5) |
| 258 | ||
| 259 |
# lv.names, including dummy-lv covariates |
|
| 260 | ! |
psi.idx <- which(names(FIT@Model@GLIST) == "psi")[b] |
| 261 | ! |
lv.names.b <- FIT@Model@dimNames[[psi.idx]][[1L]] # including dummy/inter. |
| 262 |
# if (FIT@Model@conditional.x) {
|
|
| 263 |
# exo.names <- FIT@Model@dimNames[[gamma.idx[b]]][[2L]] |
|
| 264 |
# lv.names.b <- c(lv.names.b, exo.names) |
|
| 265 |
# } |
|
| 266 | ! |
rm.idx <- integer(0L) |
| 267 | ||
| 268 |
# higher-order? remove lower-order factors |
|
| 269 | ! |
if (lv.higherorder.flag && length(lavpta$vnames$lv.ind[[b]]) > 0L) {
|
| 270 | ! |
rm.idx <- c(rm.idx, match(lavpta$vnames$lv.ind[[b]], lv.names.b)) |
| 271 |
} |
|
| 272 | ||
| 273 |
# interaction terms? remove them for VETA |
|
| 274 | ! |
if (lv.interaction.flag && length(lavpta$vnames$lv.interaction[[b]]) > 0L) {
|
| 275 | ! |
rm.idx <- c(rm.idx, match(lavpta$vnames$lv.interaction[[b]], lv.names.b)) |
| 276 | ! |
lv.int.names <- lavpta$vnames$lv.interaction[[b]] |
| 277 |
} |
|
| 278 | ||
| 279 |
# final names for EETA/VETA (not including interaction terms!) |
|
| 280 | ! |
lv.names1 <- lv.names.b |
| 281 | ! |
if (length(rm.idx) > 0L) {
|
| 282 | ! |
lv.names1 <- lv.names.b[-rm.idx] |
| 283 |
} |
|
| 284 | ! |
LV.NAMES[[b]] <- lv.names1 |
| 285 | ||
| 286 |
# get sample statistics for this block |
|
| 287 | ! |
COV <- STEP1$COV[[b]] |
| 288 | ! |
YBAR <- drop(STEP1$YBAR[[b]]) |
| 289 | ||
| 290 |
# rescale COV? |
|
| 291 | ! |
if (FIT@Data@nlevels == 1L && |
| 292 | ! |
(FIT@Model@categorical || FIT@Model@correlation)) {
|
| 293 | ! |
SCALE.vector <- 1 / (drop(DELTA[[b]])) |
| 294 | ! |
COV <- SCALE.vector * COV * rep(SCALE.vector, each = ncol(COV)) |
| 295 | ! |
YBAR <- SCALE.vector * YBAR # Checkme! |
| 296 |
} |
|
| 297 | ||
| 298 |
# do we need ICOV? |
|
| 299 | ! |
if (local.M.method == "GLS") {
|
| 300 | ! |
if (FIT@Options$sample.cov.rescale) {
|
| 301 |
# get unbiased S |
|
| 302 | ! |
N <- FIT@SampleStats@nobs[[this.group]] |
| 303 | ! |
COV.unbiased <- COV * N / (N - 1) |
| 304 | ! |
ICOV <- solve(COV.unbiased) |
| 305 |
} else {
|
|
| 306 | ! |
ICOV <- solve(COV) |
| 307 |
} |
|
| 308 |
} |
|
| 309 | ||
| 310 |
# compute mapping matrix 'M' |
|
| 311 | ! |
this.lambda <- LAMBDA[[b]] |
| 312 | ! |
if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
|
| 313 | ! |
this.lambda <- this.lambda[, -lavpta$vidx$lv.interaction[[b]]] |
| 314 |
} |
|
| 315 | ! |
if (lsam.analytic.flag[b]) {
|
| 316 | ! |
Mb <- lav_sam_mapping_matrix( |
| 317 | ! |
LAMBDA = this.lambda, |
| 318 | ! |
THETA = THETA[[b]], |
| 319 | ! |
S = COV, S.inv = ICOV, |
| 320 | ! |
method = local.M.method |
| 321 |
) |
|
| 322 |
} else {
|
|
| 323 | ! |
Mb <- matrix(as.numeric(NA), ncol(this.lambda), nrow(this.lambda)) |
| 324 |
} |
|
| 325 | ! |
if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
|
| 326 | ! |
tmp <- Mb |
| 327 | ! |
Mb <- matrix(0, nrow = ncol(LAMBDA[[b]]), ncol = nrow(LAMBDA[[b]])) |
| 328 | ! |
Mb[-lavpta$vidx$lv.interaction[[b]], ] <- tmp |
| 329 |
} |
|
| 330 | ||
| 331 |
# handle observed-only variables (needed?) |
|
| 332 | ! |
dummy.ov.idx <- c( |
| 333 | ! |
FIT@Model@ov.x.dummy.ov.idx[[b]], |
| 334 | ! |
FIT@Model@ov.y.dummy.ov.idx[[b]] |
| 335 |
) |
|
| 336 | ! |
dummy.lv.idx <- c( |
| 337 | ! |
FIT@Model@ov.x.dummy.lv.idx[[b]], |
| 338 | ! |
FIT@Model@ov.y.dummy.lv.idx[[b]] |
| 339 |
) |
|
| 340 | ||
| 341 |
# handle conditional.x |
|
| 342 |
# if (FIT@Model@conditional.x) {
|
|
| 343 |
# I0 <- diag(x = 0, nrow = length(exo.names)) |
|
| 344 |
# I1 <- diag(x = 1, nrow = length(exo.names)) |
|
| 345 |
# Mb <- lav_matrix_bdiag(Mb, I1) |
|
| 346 |
# LAMBDA[[b]] <- lav_matrix_bdiag(LAMBDA[[b]], I1) |
|
| 347 |
# THETA[[b]] <- lav_matrix_bdiag(THETA[[b]], I0) |
|
| 348 |
# NU[[b]] <- c(drop(NU[[b]]), numeric(length(exo.names))) |
|
| 349 |
# } |
|
| 350 | ||
| 351 |
# fix dummy.lv.idx if we have higher-order factors! |
|
| 352 | ! |
if (lv.higherorder.flag) {
|
| 353 | ! |
dummy.lv.idx <- match(lv.names.b[dummy.lv.idx], lv.names1) |
| 354 |
} |
|
| 355 | ||
| 356 | ! |
if (length(dummy.ov.idx)) {
|
| 357 | ! |
Mb[dummy.lv.idx, ] <- 0 |
| 358 | ! |
Mb[cbind(dummy.lv.idx, dummy.ov.idx)] <- 1 |
| 359 |
} |
|
| 360 | ||
| 361 |
# here, we remove the lv.interaction row(s) from Mb |
|
| 362 |
# FIXME: if we have higher order factors! |
|
| 363 | ! |
if (length(lavpta$vidx$lv.interaction[[b]]) > 0L) {
|
| 364 | ! |
Mb <- Mb[-lavpta$vidx$lv.interaction[[b]], ] |
| 365 |
} |
|
| 366 | ||
| 367 |
# compute EETA |
|
| 368 | ! |
if (lavoptions$meanstructure) {
|
| 369 | ! |
if (lsam.analytic.flag[b]) {
|
| 370 | ! |
EETA[[b]] <- lav_sam_eeta(M = Mb, YBAR = YBAR, NU = NU[[b]]) |
| 371 |
} else {
|
|
| 372 |
# EETA is constrained somehow |
|
| 373 | ! |
lav_msg_stop(gettext("not ready yet"))
|
| 374 |
# EETA[[b]] <- lav_sam_eeta_con(YBAR = YBAR, LAMBDA = LAMBDA[[b]], |
|
| 375 |
# THETA = THETA[[b]], |
|
| 376 |
# L.veta = L.veta[[b]]) |
|
| 377 | ||
| 378 |
} |
|
| 379 | ! |
FS.mean[[b]] <- EETA[[b]] # ok if no interaction |
| 380 |
} |
|
| 381 | ||
| 382 |
# compute VETA |
|
| 383 | ! |
if (sam.method == "local") {
|
| 384 | ! |
if (lsam.analytic.flag[b]) {
|
| 385 | ! |
tmp <- lav_sam_veta( |
| 386 | ! |
M = Mb, S = COV, THETA = THETA[[b]], |
| 387 | ! |
alpha.correction = local.options[["alpha.correction"]], |
| 388 | ! |
lambda.correction = local.options[["lambda.correction"]], |
| 389 | ! |
N <- FIT@SampleStats@nobs[[this.group]], |
| 390 | ! |
dummy.lv.idx = dummy.lv.idx, |
| 391 | ! |
extra = TRUE |
| 392 |
) |
|
| 393 | ! |
VETA[[b]] <- tmp[, , drop = FALSE] # drop attributes |
| 394 | ! |
alpha[[b]] <- attr(tmp, "alpha") |
| 395 | ! |
lambda[[b]] <- attr(tmp, "lambda.star") |
| 396 | ! |
MSM..[[b]] <- attr(tmp, "MSM") |
| 397 | ! |
MTM..[[b]] <- attr(tmp, "MTM") |
| 398 |
} else {
|
|
| 399 |
# VETA is constrained somehow |
|
| 400 | ! |
VETA[[b]] <- lav_sam_veta_con(S = COV, LAMBDA = LAMBDA[[b]], |
| 401 | ! |
THETA = THETA[[b]], L.veta = L.veta[[b]], |
| 402 | ! |
local.M.method = local.M.method) |
| 403 | ! |
alpha[[b]] <- as.numeric(NA) |
| 404 | ! |
lambda[[b]] <- as.numeric(NA) |
| 405 | ! |
MSM..[[b]] <- matrix(0, 0, 0) |
| 406 | ! |
MTM..[[b]] <- matrix(0, 0, 0) |
| 407 |
} |
|
| 408 | ! |
} else if (sam.method == "cfsr") {
|
| 409 |
# first, we need to 'true' VETA (to get Sigma) |
|
| 410 | ! |
tmp <- lav_sam_veta( |
| 411 | ! |
M = Mb, S = COV, THETA = THETA[[b]], |
| 412 | ! |
alpha.correction = 0L, |
| 413 | ! |
lambda.correction = local.options[["lambda.correction"]], |
| 414 | ! |
N <- FIT@SampleStats@nobs[[this.group]], |
| 415 | ! |
dummy.lv.idx = dummy.lv.idx, |
| 416 | ! |
extra = FALSE |
| 417 |
) |
|
| 418 | ! |
VETA[[b]] <- tmp[, , drop = FALSE] |
| 419 |
# compute 'Sigma' |
|
| 420 | ! |
Sigma <- this.lambda %*% VETA[[b]] %*% t(this.lambda) + THETA[[b]] |
| 421 | ! |
tmat <- lav_predict_tmat_det_internal(Sigma = Sigma, Veta = VETA[[b]], |
| 422 | ! |
Lambda = this.lambda) |
| 423 | ! |
A <- tmat %*% Mb |
| 424 | ! |
VETA[[b]] <- A %*% COV %*% t(A) |
| 425 |
} else {
|
|
| 426 |
# FSR -- no correction |
|
| 427 | ! |
VETA[[b]] <- Mb %*% COV %*% t(Mb) |
| 428 |
} |
|
| 429 | ||
| 430 |
# standardize? not really needed, but we may have 1.0000001 |
|
| 431 |
# as variances, and this may lead to false convergence |
|
| 432 | ! |
if (FIT@Options$std.lv) {
|
| 433 |
# warning: we should only do this for the LVs, not the |
|
| 434 |
# observed variables |
|
| 435 | ! |
if (length(dummy.lv.idx) == 0L) {
|
| 436 | ! |
VETA[[b]] <- stats::cov2cor(VETA[[b]]) |
| 437 |
} else {
|
|
| 438 | ! |
tmp <- VETA[[b]] |
| 439 | ! |
tmp.lv <- stats::cov2cor(VETA[[b]][-dummy.lv.idx, |
| 440 | ! |
-dummy.lv.idx, drop = FALSE]) |
| 441 | ! |
VETA[[b]][-dummy.lv.idx, -dummy.lv.idx] <- tmp.lv |
| 442 |
} |
|
| 443 |
} |
|
| 444 | ! |
colnames(VETA[[b]]) <- rownames(VETA[[b]]) <- lv.names1 |
| 445 | ||
| 446 |
# compute model-based RELiability |
|
| 447 |
# REL[[b]] <- diag(VETA[[b]]] %*% solve(MSM..[[b]])) # CHECKme! -> done, must be: |
|
| 448 | ! |
if (lsam.analytic.flag[b]) {
|
| 449 | ! |
REL[[b]] <- diag(VETA[[b]]) / diag(MSM..[[b]]) #! |
| 450 |
} else {
|
|
| 451 | ! |
REL[[b]] <- as.numeric(NA) |
| 452 |
} |
|
| 453 | ||
| 454 |
# check for lv.interactions |
|
| 455 | ! |
if (lv.interaction.flag && length(lv.int.names) > 0L) {
|
| 456 | ! |
if (FIT@Model@categorical || FIT@Model@correlation) {
|
| 457 | ! |
lav_msg_stop(gettext("SAM + lv interactions do not work (yet) if
|
| 458 | ! |
correlation structures are used.")) |
| 459 |
} |
|
| 460 | ||
| 461 |
# compute Bartlett factor scores here |
|
| 462 | ! |
if (is.null(Y)) {
|
| 463 | ! |
Yb <- FIT@Data@X[[b]] |
| 464 |
} else {
|
|
| 465 | ! |
Yb <- Y[[b]] |
| 466 |
} |
|
| 467 |
# center |
|
| 468 | ! |
Yb.c <- t( t(Yb) - drop(NU[[b]]) ) |
| 469 | ! |
FS.b <- Yb.c %*% t(Mb) |
| 470 | ! |
colnames(FS.b) <- lv.names1 |
| 471 |
# FIXME: what about observed covariates? |
|
| 472 | ||
| 473 |
# get (approximate) indices with outliers |
|
| 474 |
#fs.outlier.idx[[b]] <- lav_sample_outlier_idx(lav_sample_mdist(FS.b), coef = 1.5) |
|
| 475 | ||
| 476 |
# EETA2 |
|
| 477 | ! |
EETA1 <- EETA[[b]] |
| 478 | ! |
EETA[[b]] <- lav_sam_eeta2( |
| 479 | ! |
EETA = EETA1, VETA = VETA[[b]], |
| 480 | ! |
lv.names = lv.names1, |
| 481 | ! |
lv.int.names = lv.int.names |
| 482 |
) |
|
| 483 | ||
| 484 |
# VETA2 |
|
| 485 | ! |
if (sam.method == "local") {
|
| 486 | ! |
tmp <- lav_sam_veta2( |
| 487 | ! |
FS = FS.b, M = Mb, |
| 488 | ! |
VETA = VETA[[b]], EETA = EETA1, |
| 489 | ! |
THETA = THETA[[b]], |
| 490 | ! |
lv.names = lv.names1, |
| 491 | ! |
lv.int.names = lv.int.names, |
| 492 | ! |
dummy.lv.names = lv.names.b[dummy.lv.idx], |
| 493 | ! |
alpha.correction = local.options[["alpha.correction"]], |
| 494 | ! |
lambda.correction = local.options[["lambda.correction"]], |
| 495 |
#fs.outlier.idx = fs.outlier.idx[[b]], |
|
| 496 | ! |
return.FS = return.FS, |
| 497 | ! |
return.cov.iveta2 = return.cov.iveta2, |
| 498 | ! |
extra = TRUE |
| 499 |
) |
|
| 500 | ! |
VETA[[b]] <- tmp[, , drop = FALSE] # drop attributes |
| 501 | ! |
alpha[[b]] <- attr(tmp, "alpha") |
| 502 | ! |
lambda[[b]] <- attr(tmp, "lambda.star") |
| 503 | ! |
MSM..[[b]] <- attr(tmp, "MSM") |
| 504 | ! |
MTM..[[b]] <- attr(tmp, "MTM") |
| 505 | ! |
FS.mean[[b]] <- attr(tmp, "FS.mean") |
| 506 | ! |
if (return.FS) {
|
| 507 | ! |
FS[[b]] <- attr(tmp, "FS") |
| 508 |
} |
|
| 509 | ! |
if (return.cov.iveta2) {
|
| 510 | ! |
COV.IVETA2[[b]] <- attr(tmp, "cov.iveta2") |
| 511 |
} |
|
| 512 |
#FS.gamma[[b]] <- attr(tmp, "FS.gamma") |
|
| 513 |
} else {
|
|
| 514 | ! |
lav_msg_fixme("not ready yet!")
|
| 515 |
# FSR -- no correction |
|
| 516 | ! |
VETA[[b]] <- lav_sam_fs2( |
| 517 | ! |
FS = FS.b, |
| 518 | ! |
lv.names = lv.names1, lv.int.names = lv.int.names |
| 519 |
) |
|
| 520 |
} |
|
| 521 |
} |
|
| 522 | ||
| 523 |
# store Mapping matrix for this block |
|
| 524 | ! |
M[[b]] <- Mb |
| 525 |
} # blocks |
|
| 526 | ||
| 527 |
# label blocks |
|
| 528 | ! |
if (nblocks > 1L) {
|
| 529 | ! |
names(EETA) <- FIT@Data@block.label |
| 530 | ! |
names(VETA) <- FIT@Data@block.label |
| 531 | ! |
names(REL) <- FIT@Data@block.label |
| 532 | ! |
names(MSM..) <- FIT@Data@block.label |
| 533 | ! |
names(MTM..) <- FIT@Data@block.label |
| 534 | ! |
names(FS.mean) <- FIT@Data@block.label |
| 535 | ! |
names(FS) <- FIT@Data@block.label |
| 536 | ! |
names(COV.IVETA2) <- FIT@Data@block.label |
| 537 |
#names(fs.outlier.idx) <- FIT@Data@block.label |
|
| 538 |
#names(FS.gamma) <- FIT@Data@block.label |
|
| 539 |
} |
|
| 540 | ||
| 541 |
# handle conditional.x: add res.slopes, cov.x and mean.x |
|
| 542 | ! |
if (FIT@Model@conditional.x) {
|
| 543 | ! |
res.slopes <- vector("list", length = nblocks)
|
| 544 | ! |
for (b in seq_len(nblocks)) {
|
| 545 | ! |
res.slopes[[b]] <- M[[b]] %*% FIT@h1$implied$res.slopes[[b]] |
| 546 |
} |
|
| 547 | ! |
attr(VETA, "res.slopes") <- res.slopes |
| 548 | ! |
attr(VETA, "cov.x") <- FIT@h1$implied$cov.x |
| 549 | ! |
attr(VETA, "mean.x") <- FIT@h1$implied$mean.x |
| 550 |
} |
|
| 551 | ||
| 552 |
# store EETA/VETA/M/alpha/lambda |
|
| 553 | ! |
STEP1$VETA <- VETA |
| 554 | ! |
STEP1$EETA <- EETA |
| 555 | ! |
STEP1$REL <- REL |
| 556 | ! |
STEP1$M <- M |
| 557 | ! |
STEP1$lambda <- lambda |
| 558 | ! |
STEP1$alpha <- alpha |
| 559 | ! |
STEP1$MSM <- MSM.. |
| 560 | ! |
STEP1$MTM <- MTM.. |
| 561 | ! |
STEP1$FS.mean <- FS.mean |
| 562 | ! |
STEP1$FS <- FS |
| 563 | ! |
STEP1$COV.IVETA2 <- COV.IVETA2 |
| 564 |
#STEP1$fs.outlier.idx <- fs.outlier.idx |
|
| 565 |
#STEP1$FS.gamma <- FS.gamma |
|
| 566 | ! |
STEP1$LV.NAMES <- LV.NAMES |
| 567 |
# store also sam.method and local.options |
|
| 568 | ! |
STEP1$sam.method <- sam.method |
| 569 | ! |
STEP1$local.options <- local.options |
| 570 | ||
| 571 | ! |
if (lav_verbose()) {
|
| 572 | ! |
cat("done.\n")
|
| 573 |
} |
|
| 574 | ||
| 575 | ! |
STEP1 |
| 576 |
} |
|
| 577 | ||
| 578 | ||
| 579 |
lav_sam_step1_local_jac <- function(STEP1 = NULL, FIT = NULL, P.only = FALSE, |
|
| 580 |
return.jac = FALSE) {
|
|
| 581 | ||
| 582 | ! |
lavdata <- FIT@Data |
| 583 | ! |
lavsamplestats <- FIT@SampleStats |
| 584 | ! |
lavmodel <- FIT@Model |
| 585 | ! |
lavpta <- FIT@pta |
| 586 | ! |
nblocks <- lavpta$nblocks |
| 587 | ||
| 588 | ! |
local.options <- STEP1$local.options |
| 589 | ! |
sam.method <- STEP1$sam.method |
| 590 | ||
| 591 | ! |
ngroups <- lavdata@ngroups |
| 592 | ! |
if (ngroups > 1L) {
|
| 593 | ! |
lav_msg_stop(gettext("IJ local SEs: not available with multiple groups!\n"))
|
| 594 |
# if multiple groups: |
|
| 595 |
# - we have a separate Gamma, h1.expected, delta matrix per group |
|
| 596 |
# - but we have only 1 observed information matrix, reflecting possible |
|
| 597 |
# across-group equality constraints |
|
| 598 |
# - we may need to use the same procedure as for robust test statistics: |
|
| 599 |
# create a (huge) block-diagonal Gamma matrix, and one big 'JAC' |
|
| 600 |
# matrix... |
|
| 601 |
} |
|
| 602 | ! |
g <- 1L |
| 603 | ! |
if (lavmodel@categorical) {
|
| 604 | ! |
lav_msg_stop(gettext("IJ local SEs: not available for the categorical setting (yet)!\n"))
|
| 605 |
} |
|
| 606 | ! |
nMMblocks <- length(STEP1$MM.FIT) |
| 607 | ||
| 608 |
# JAC = (JACc %*% JACa) + JACb |
|
| 609 |
# - rows are the elements of vech(VETA) |
|
| 610 |
# - cols are the elements of vech(S) |
|
| 611 | ||
| 612 |
# JACa: mm.theta x vech(S) |
|
| 613 |
# JACc: vech(VETA) x mm.theta (keeping S fixed) |
|
| 614 |
# JACb: vech(VETA) x vech(S) (keeping mm.theta fixed) |
|
| 615 | ||
| 616 |
# JACa: jacobian of theta.mm = f(vech(S)) |
|
| 617 | ! |
JACa <- matrix(0, nrow = length(FIT@ParTable$lhs), # we select later |
| 618 | ! |
ncol = length(FIT@SampleStats@WLS.obs[[g]])) |
| 619 | ! |
for (mm in seq_len(nMMblocks)) {
|
| 620 | ! |
fit.mm.block <- STEP1$MM.FIT[[mm]] |
| 621 | ! |
mm.h1.expected <- lavTech(fit.mm.block, "h1.information.expected") |
| 622 | ! |
mm.delta <- lavTech(fit.mm.block, "Delta") |
| 623 | ! |
if (P.only && FIT@Options$information[1] == "expected") {
|
| 624 |
# for twostep.robust |
|
| 625 | ! |
mm.inv.observed <- lavTech(fit.mm.block, "inverted.information.expected") |
| 626 |
} else {
|
|
| 627 | ! |
mm.inv.observed <- lavTech(fit.mm.block, "inverted.information.observed") |
| 628 |
} |
|
| 629 | ||
| 630 |
#h1.info <- matrix(0, nrow(mm.h1.expected[[1]]), ncol(mm.h1.expected[[1]])) |
|
| 631 |
#for (g in seq_len(ngroups)) {
|
|
| 632 |
# fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
|
| 633 |
# tmp <- fg * (mm.h1.expected[[g]] %*% mm.delta[[g]]) |
|
| 634 |
# h1.info <- h1.info + tmp |
|
| 635 |
#} |
|
| 636 | ! |
mm.jac <- t(mm.h1.expected[[g]] %*% mm.delta[[g]] %*% mm.inv.observed) |
| 637 |
# keep only rows that are also in FIT@ParTable |
|
| 638 | ! |
mm.keep.idx <- fit.mm.block@ParTable$free[STEP1$block.ptm.idx[[mm]]] |
| 639 | ! |
mm.jac <- mm.jac[mm.keep.idx, , drop = FALSE] |
| 640 | ||
| 641 |
# select 'S' elements (row index) |
|
| 642 | ! |
mm.ov.idx <- match(STEP1$MM.FIT[[mm]]@Data@ov.names[[g]], |
| 643 | ! |
lavdata@ov.names[[g]]) |
| 644 | ! |
mm.nvar <- length(lavdata@ov.names[[g]]) |
| 645 | ! |
mm.col.idx <- lav_matrix_vech_which_idx(mm.nvar, idx = mm.ov.idx, |
| 646 | ! |
add.idx.at.start = lavmodel@meanstructure) |
| 647 | ! |
mm.row.idx <- STEP1$block.mm.idx[[mm]][STEP1$block.ptm.idx[[mm]]] |
| 648 | ! |
JACa[mm.row.idx, mm.col.idx] <- mm.jac |
| 649 |
} |
|
| 650 | ||
| 651 |
# keep only 'LAMBDA/THETA' parameters |
|
| 652 | ! |
PT <- STEP1$PT |
| 653 |
# only ov.names that are actually used in the measurement models |
|
| 654 | ! |
ov.names <- unique(unlist(lapply(STEP1$MM.FIT, lav_object_vnames, "ov"))) |
| 655 | ! |
lambda.idx <- which(PT$op == "=~" & PT$free > 0L & !duplicated(PT$free)) |
| 656 | ! |
theta.idx <- which(PT$op == "~~" & PT$free > 0L & !duplicated(PT$free) & |
| 657 | ! |
PT$lhs %in% ov.names & PT$rhs %in% ov.names) |
| 658 | ! |
nu.idx <- integer(0L) |
| 659 | ! |
if (lavmodel@meanstructure) {
|
| 660 | ! |
nu.idx <- which(PT$op == "~1" & PT$free > 0L & !duplicated(PT$free) & |
| 661 | ! |
PT$lhs %in% ov.names) |
| 662 |
} |
|
| 663 | ! |
delta.idx <- integer(0L) |
| 664 | ! |
if (lavmodel@categorical || lavmodel@correlation) {
|
| 665 | ! |
delta.idx <- which(PT$op == "~*~" & PT$free > 0L & !duplicated(PT$free)) |
| 666 |
} |
|
| 667 | ! |
beta.idx <- psi.idx <- integer(0L) |
| 668 | ! |
lv.ind <- unlist(lavpta$vnames$lv.ind) |
| 669 | ! |
if (length(lv.ind) > 0L) {
|
| 670 | ! |
beta.idx <- which(PT$op == "=~" & PT$free > 0L & !duplicated(PT$free) & |
| 671 | ! |
PT$rhs %in% lv.ind) |
| 672 | ! |
psi.idx <- which(PT$op == "~~" & PT$free > 0L & !duplicated(PT$free) & |
| 673 | ! |
PT$rhs %in% lv.ind & PT$lhs %in% lv.ind) |
| 674 |
} |
|
| 675 |
# keep only these free parameters (measurement only) |
|
| 676 | ! |
keep.idx <- sort(c(lambda.idx, theta.idx, nu.idx, |
| 677 | ! |
delta.idx, beta.idx, psi.idx)) |
| 678 | ! |
JACa <- JACa[keep.idx, ,drop = FALSE] |
| 679 | ! |
if (P.only) {
|
| 680 | ! |
return(JACa) |
| 681 |
} |
|
| 682 | ||
| 683 |
# JACb: jacobian of the function vech(VETA) = f(vech(S), theta.mm) |
|
| 684 |
# (treating theta.mm as fixed) |
|
| 685 | ! |
if (length(unlist(lavpta$vnames$lv.interaction)) > 0L) {
|
| 686 | ! |
ffb <- function(x) {
|
| 687 | ! |
if (lavmodel@meanstructure) {
|
| 688 | ! |
nvar <- nrow(FIT@h1$implied$cov[[g]]) |
| 689 | ! |
this.ybar <- x[seq_len(nvar)] |
| 690 | ! |
this.cov <- lav_matrix_vech_reverse(x[-seq_len(nvar)]) |
| 691 |
} else {
|
|
| 692 | ! |
this.ybar <- FIT@h1$implied$mean[[g]] |
| 693 | ! |
this.cov <- lav_matrix_vech_reverse(x) |
| 694 |
} |
|
| 695 | ||
| 696 |
# change COV/YBAR |
|
| 697 | ! |
step1 <- STEP1 |
| 698 | ! |
step1$COV[[1]] <- this.cov |
| 699 | ! |
if (lavmodel@meanstructure) {
|
| 700 | ! |
step1$YBAR[[1]] <- this.ybar |
| 701 |
} |
|
| 702 | ||
| 703 |
# transform data to comply with the new COV/YBAR |
|
| 704 | ! |
Y <- FIT@Data@X[[1]] |
| 705 | ! |
Ytrans <- vector("list", nblocks)
|
| 706 | ! |
Ytrans[[1]] <- lav_matrix_transform_mean_cov(Y, target.mean = this.ybar, |
| 707 | ! |
target.cov = this.cov) |
| 708 | ! |
colnames(Ytrans[[1]]) <- FIT@pta$vnames$ov[[1]] |
| 709 | ||
| 710 | ! |
step1 <- lav_sam_step1_local(STEP1 = step1, FIT = FIT, Y = Ytrans, |
| 711 | ! |
sam.method = STEP1$sam.method, local.options = STEP1$local.options) |
| 712 | ! |
if (lavmodel@meanstructure) {
|
| 713 | ! |
out <- c(step1$EETA[[1]], lav_matrix_vech(step1$VETA[[1]])) |
| 714 |
} else {
|
|
| 715 | ! |
out <- lav_matrix_vech(step1$VETA[[1]]) |
| 716 |
} |
|
| 717 | ! |
out |
| 718 |
} |
|
| 719 |
# shut off verbose |
|
| 720 | ! |
verbose.flag <- lav_verbose() |
| 721 | ! |
lav_verbose(FALSE) |
| 722 | ! |
this.x <- lav_matrix_vech(FIT@h1$implied$cov[[g]]) |
| 723 | ! |
if (lavmodel@meanstructure) {
|
| 724 | ! |
this.x <- c(FIT@h1$implied$mean[[g]], this.x) |
| 725 |
} |
|
| 726 | ! |
JACb <- numDeriv::jacobian(func = ffb, x = this.x) |
| 727 | ! |
lav_verbose(verbose.flag) |
| 728 |
# lv.names1 <- STEP1$LV.NAMES[[g]] |
|
| 729 |
# lv.int.names <- FIT@pta$vnames$lv.interaction[[g]] |
|
| 730 |
# nfac <- length(lv.names1) |
|
| 731 | ||
| 732 |
# idx1 <- rep(seq_len(nfac), each = nfac) |
|
| 733 |
# idx2 <- rep(seq_len(nfac), times = nfac) |
|
| 734 | ||
| 735 |
# NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":") |
|
| 736 | ||
| 737 | ||
| 738 | ||
| 739 |
# JACb <- lav_sam_step1_local_jac_var2(ybar = STEP1$YBAR[[g]], |
|
| 740 |
# S = STEP1$COV[[g]], M = STEP1$M[[g]], NU = STEP1$NU[[g]]) |
|
| 741 |
# JACb <- JACb[STEP1$lv.keep2, , drop = FALSE] |
|
| 742 |
# if (lavmodel@meanstructure) {
|
|
| 743 |
# tmp <- lav_sam_step1_local_jac_mean2(ybar = STEP1$YBAR[[g]], |
|
| 744 |
# M = STEP1$M[[g]], NU = STEP1$NU[[g]]) |
|
| 745 |
# dd |
|
| 746 |
# JACb <- lav_matrix_bdiag(tmp, JACb) |
|
| 747 |
# } |
|
| 748 | ||
| 749 |
} else { # no latent interactions
|
|
| 750 | ! |
Mb <- STEP1$M[[g]] |
| 751 | ! |
MbxMb <- Mb %x% Mb |
| 752 | ! |
row.idx <- lav_matrix_vech_idx(nrow(Mb)) |
| 753 | ! |
JACb <- lav_matrix_duplication_post(MbxMb)[row.idx,,drop = FALSE] |
| 754 | ! |
if (lavmodel@meanstructure) {
|
| 755 | ! |
JACb <- lav_matrix_bdiag(Mb, JACb) |
| 756 |
} |
|
| 757 |
} |
|
| 758 | ||
| 759 |
# JACc: jacobian of the function vech(VETA) = f(theta.mm, vech(S)) |
|
| 760 |
# (treating vech(S) as fixed) |
|
| 761 | ||
| 762 |
# ffc <- function(x, YBAR = NULL, COV = NULL, b = 1L) {
|
|
| 763 |
# # x only contains the LAMBDA/THETA/NU elements |
|
| 764 |
# PT$est[keep.idx] <- x |
|
| 765 |
# # get all free parameters (for lav_model_set_parameters) |
|
| 766 |
# x.free <- PT$est[PT$free > 0L & !duplicated(PT$free)] |
|
| 767 |
# this.model <- lav_model_set_parameters(lavmodel, x = x.free) |
|
| 768 |
# lambda.idx <- which(names(this.model@GLIST) == "lambda")[b] |
|
| 769 |
# theta.idx <- which(names(this.model@GLIST) == "theta")[b] |
|
| 770 |
# LAMBDA <- this.model@GLIST[[lambda.idx]] |
|
| 771 |
# THETA <- this.model@GLIST[[ theta.idx]] |
|
| 772 |
# Mb <- lav_sam_mapping_matrix(LAMBDA = LAMBDA, |
|
| 773 |
# THETA = THETA, S = COV, |
|
| 774 |
# method = local.options$M.method) |
|
| 775 |
# # handle observed-only variables |
|
| 776 |
# dummy.ov.idx <- c( |
|
| 777 |
# FIT@Model@ov.x.dummy.ov.idx[[b]], |
|
| 778 |
# FIT@Model@ov.y.dummy.ov.idx[[b]] |
|
| 779 |
# ) |
|
| 780 |
# dummy.lv.idx <- c( |
|
| 781 |
# FIT@Model@ov.x.dummy.lv.idx[[b]], |
|
| 782 |
# FIT@Model@ov.y.dummy.lv.idx[[b]] |
|
| 783 |
# ) |
|
| 784 |
# if (length(dummy.ov.idx)) {
|
|
| 785 |
# Mb[dummy.lv.idx, ] <- 0 |
|
| 786 |
# Mb[cbind(dummy.lv.idx, dummy.ov.idx)] <- 1 |
|
| 787 |
# } |
|
| 788 |
# MSM <- Mb %*% COV %*% t(Mb) |
|
| 789 |
# MTM <- Mb %*% THETA %*% t(Mb) |
|
| 790 |
# VETA <- MSM - MTM |
|
| 791 | ||
| 792 |
# if (lavmodel@meanstructure) {
|
|
| 793 |
# nu.idx <- which(names(this.model@GLIST) == "nu")[b] |
|
| 794 |
# NU <- this.model@GLIST[[nu.idx]] |
|
| 795 |
# EETA <- lav_sam_eeta(M = Mb, YBAR = YBAR, NU = NU) |
|
| 796 |
# out <- c(EETA, lav_matrix_vech(VETA)) |
|
| 797 |
# } else {
|
|
| 798 |
# out <- lav_matrix_vech(VETA) |
|
| 799 |
# } |
|
| 800 | ||
| 801 |
# out |
|
| 802 |
# } |
|
| 803 | ||
| 804 |
# current point estimates |
|
| 805 |
# PT <- STEP1$PT |
|
| 806 |
# x <- PT$est[keep.idx] |
|
| 807 |
# if (lavmodel@meanstructure) {
|
|
| 808 |
# JACc <- numDeriv::jacobian(func = ffc, x = x, YBAR = STEP1$YBAR[[1]], |
|
| 809 |
# COV = STEP1$COV[[1]]) |
|
| 810 |
# } else {
|
|
| 811 |
# JACc <- numDeriv::jacobian(func = ffc, x = x, COV = STEP1$COV[[1]]) |
|
| 812 |
# } |
|
| 813 | ||
| 814 |
# calling lav_sam_step1_local() directly |
|
| 815 | ! |
ffc <- function(x) {
|
| 816 | ! |
step1 <- STEP1 |
| 817 | ||
| 818 |
# fill in new 'x' values in PT |
|
| 819 | ! |
step1$PT$est[keep.idx] <- x |
| 820 | ! |
step1 <- lav_sam_step1_local(STEP1 = step1, FIT = FIT, |
| 821 | ! |
sam.method = STEP1$sam.method, local.options = STEP1$local.options) |
| 822 | ! |
if (lavmodel@meanstructure) {
|
| 823 | ! |
out <- c(step1$EETA[[1]], lav_matrix_vech(step1$VETA[[1]])) |
| 824 |
} else {
|
|
| 825 | ! |
out <- lav_matrix_vech(step1$VETA[[1]]) |
| 826 |
} |
|
| 827 | ! |
out |
| 828 |
} |
|
| 829 |
# shut off verbose |
|
| 830 | ! |
verbose.flag <- lav_verbose() |
| 831 | ! |
lav_verbose(FALSE) |
| 832 | ! |
JACc <- numDeriv::jacobian(func = ffc, x = STEP1$PT$est[keep.idx]) |
| 833 | ! |
lav_verbose(verbose.flag) |
| 834 | ||
| 835 |
# assemble JAC |
|
| 836 | ! |
JAC <- (JACc %*% JACa) + JACb |
| 837 | ||
| 838 | ! |
if (return.jac) {
|
| 839 | ! |
attr(JAC, "JACa") <- JACa |
| 840 | ! |
attr(JAC, "JACb") <- JACb |
| 841 | ! |
attr(JAC, "JACc") <- JACc |
| 842 |
} |
|
| 843 | ||
| 844 |
# eventually, this will be a list per group/block |
|
| 845 | ! |
list(JAC) |
| 846 |
} |
|
| 847 | ||
| 848 |
lav_sam_step1_local_jac_var2 <- function(ybar = NULL, S = NULL, |
|
| 849 |
M = NULL, NU = NULL) {
|
|
| 850 | ||
| 851 | ! |
nfac <- nrow(M) |
| 852 | ! |
K.nfac <- lav_matrix_commutation(nfac, nfac) |
| 853 | ! |
IK <- diag(nfac*nfac) + K.nfac |
| 854 | ||
| 855 | ! |
MEAN.FS <- M %*% (ybar - NU) |
| 856 | ! |
MSM <- M %*% S %*% t(M) |
| 857 | ||
| 858 | ! |
part1a <- ( diag(nfac) %x% matrix(lav_matrix_vec(IK %*% (MSM %x% diag(nfac)) %*% K.nfac), nfac^3, nfac) + |
| 859 | ! |
matrix(diag(nfac) %x% (IK %*% (diag(nfac) %x% MSM)), nfac^4, nfac^2) ) |
| 860 | ! |
tmp1 <- part1a %*% IK %*% (diag(nfac) %x% MEAN.FS) %*% M |
| 861 | ||
| 862 |
# S part |
|
| 863 | ! |
A <- tcrossprod(MEAN.FS) |
| 864 | ! |
part1b <- diag(nfac) %x% matrix(lav_matrix_vec(IK %*% (A %x% diag(nfac)) %*% K.nfac), nfac^3, nfac) |
| 865 | ! |
part1c <- matrix(diag(nfac) %x% (IK %*% (diag(nfac) %x% A)), nfac^4, nfac^2) |
| 866 | ! |
tmp2 <- (part1a + part1b + part1c) %*% lav_matrix_duplication_post(M %x% M) |
| 867 | ||
| 868 |
# together |
|
| 869 | ! |
JAC.S.analytic <- cbind(tmp1, tmp2) |
| 870 | ! |
JAC.S.analytic |
| 871 |
} |
|
| 872 | ||
| 873 |
lav_sam_step1_local_jac_mean2 <- function(ybar = NULL, M = NULL, NU = NULL) {
|
|
| 874 | ! |
nfac <- nrow(M) |
| 875 | ! |
K.nfac <- lav_matrix_commutation(nfac, nfac) |
| 876 | ! |
IK <- diag(nfac*nfac) + K.nfac |
| 877 | ||
| 878 | ! |
MEAN.FS <- M %*% (ybar - NU) |
| 879 | ||
| 880 | ! |
tmp1 <- IK %*% (diag(nfac) %x% MEAN.FS) %*% M |
| 881 | ! |
tmp2 <- lav_matrix_duplication_post(M %x% M) |
| 882 | ! |
JAC.M.analytic <- cbind(tmp1, tmp2) |
| 883 | ! |
JAC.M.analytic |
| 884 |
} |
|
| 885 | ||
| 886 |
lav_sam_gamma_add_numerical <- function(STEP1 = NULL, FIT = NULL, group = 1L) {
|
|
| 887 | ||
| 888 | ! |
lavdata <- FIT@Data |
| 889 | ! |
lavsamplestats <- FIT@SampleStats |
| 890 | ! |
lavmodel <- FIT@Model |
| 891 | ! |
lavpta <- FIT@pta |
| 892 | ! |
nblocks <- lavpta$nblocks |
| 893 | ||
| 894 | ! |
local.options <- STEP1$local.options |
| 895 | ! |
sam.method <- STEP1$sam.method |
| 896 | ||
| 897 | ! |
ngroups <- lavdata@ngroups |
| 898 | ! |
if (ngroups > 1L) {
|
| 899 | ! |
lav_msg_stop(gettext("IJ local SEs: not available with multiple groups!\n"))
|
| 900 |
} |
|
| 901 | ! |
g <- group |
| 902 | ! |
Y <- FIT@Data@X[[g]] |
| 903 | ! |
N <- nrow(Y) |
| 904 | ||
| 905 |
# NAMES + lv.keep |
|
| 906 | ! |
lv.names <- STEP1$LV.NAMES[[1]] |
| 907 | ! |
lv.names <- c("..int..", lv.names)
|
| 908 | ! |
nfac <- length(lv.names) |
| 909 | ! |
idx1 <- rep(seq_len(nfac), each = nfac) |
| 910 | ! |
idx2 <- rep(seq_len(nfac), times = nfac) |
| 911 | ||
| 912 | ! |
K.nfac <- lav_matrix_commutation(nfac, nfac) |
| 913 | ! |
IK <- diag(nfac * nfac) + K.nfac |
| 914 | ||
| 915 | ! |
NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":") |
| 916 | ! |
NAMES[seq_len(nfac)] <- lv.names |
| 917 | ! |
lv.keep <- colnames(STEP1$VETA[[1]]) |
| 918 | ! |
FS.mean <- STEP1$FS.mean[[1]] |
| 919 | ! |
keep.idx <- match(lv.keep, NAMES) |
| 920 | ||
| 921 | ! |
theta.to.eetavetai <- function(x, i = 1L) {
|
| 922 | ! |
PT <- STEP1$PT |
| 923 | ! |
PT$est[step1.idx] <- x |
| 924 | ! |
this.lavmodel <- lav_model_set_parameters(lavmodel, |
| 925 | ! |
x = PT$est[PT$free > 0 & !duplicated(PT$free)]) |
| 926 | ! |
this.nu <- this.lavmodel@GLIST$nu |
| 927 | ! |
rm.idx <- lavpta$vidx$lv.interaction[[1]] |
| 928 |
# no interaction columns! |
|
| 929 | ! |
this.lambda <- this.lavmodel@GLIST$lambda[, -rm.idx,drop = FALSE] |
| 930 | ! |
this.theta <- this.lavmodel@GLIST$theta |
| 931 | ! |
this.M <- lav_sam_mapping_matrix(LAMBDA = this.lambda, |
| 932 | ! |
THETA = this.theta, |
| 933 | ! |
S = STEP1$COV[[1]], |
| 934 | ! |
method = STEP1$local.options$M.method) |
| 935 | ! |
MTM <- this.M %*% this.theta %*% t(this.M) |
| 936 | ! |
MTM <- lav_matrix_bdiag(0,MTM) |
| 937 | ||
| 938 | ! |
fi <- this.M %*% (Y[i,] - this.nu); fi <- rbind(1, fi); fii <- drop(fi) |
| 939 | ! |
fi2 <- (fii[idx1]*fii[idx2]) |
| 940 | ||
| 941 | ! |
tmp <- ( ((tcrossprod(fi) - MTM) %x% MTM) + |
| 942 | ! |
(MTM %x% (tcrossprod(fi) - MTM)) + |
| 943 | ! |
lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM) + |
| 944 | ! |
lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM) + |
| 945 | ! |
(IK %*% (MTM %x% MTM)) ) |
| 946 | ||
| 947 |
# we have no access to FS2.mean, so we need to reduce the matrices |
|
| 948 |
# right away |
|
| 949 | ! |
f.star <- tcrossprod(fi2[keep.idx] - FS.mean) |
| 950 | ! |
e.star <- STEP1$lambda[[1]] * tmp[keep.idx, keep.idx, drop = FALSE] |
| 951 | ! |
iveta2 <- f.star - e.star |
| 952 |
#iveta <- iveta2[seq_len(nfac - 1), seq_len(nfac - 1)] |
|
| 953 | ||
| 954 | ! |
ieeta2 <- ( lav_matrix_vec(tcrossprod(fi))[keep.idx] - |
| 955 | ! |
lav_matrix_vec(tcrossprod(FS.mean))[keep.idx] + |
| 956 | ! |
(FS.mean %x% FS.mean)[keep.idx] - |
| 957 | ! |
STEP1$lambda[[1]] * lav_matrix_vec(MTM)[keep.idx] ) |
| 958 | ||
| 959 | ! |
c(ieeta2, lav_matrix_vech(iveta2)) |
| 960 | ! |
} # single 'i' |
| 961 | ||
| 962 | ! |
step1.idx <- which(STEP1$PT$free %in% STEP1$step1.free.idx) |
| 963 | ! |
x.step1 <- STEP1$PT$est[step1.idx] |
| 964 | ! |
try.one <- theta.to.eetavetai(x = x.step1, i = 1) |
| 965 | ! |
CVETA <- matrix(0, nrow = length(try.one), ncol = length(x.step1)) |
| 966 | ! |
for(i in 1:N) {
|
| 967 | ! |
tmp <- numDeriv::jacobian(func = theta.to.eetavetai, x = x.step1, i = i) |
| 968 | ! |
CVETA <- CVETA + 1/N * tmp |
| 969 |
} |
|
| 970 | ||
| 971 | ! |
Gamma.addition <- N * (CVETA %*% STEP1$Sigma.11 %*% t(CVETA)) |
| 972 | ! |
Gamma.addition |
| 973 |
} |
|
| 974 | ||
| 975 |
# semi-analytic version |
|
| 976 |
# YR 4 June 2025: works, but still needs cleanup + avoid redundant calculations |
|
| 977 |
# (eg when multiplied with a matrix with many zero rows/cols) |
|
| 978 |
lav_sam_gamma_add <- function(STEP1 = NULL, FIT = NULL, group = 1L) {
|
|
| 979 | ||
| 980 | ! |
lavdata <- FIT@Data |
| 981 | ! |
lavsamplestats <- FIT@SampleStats |
| 982 | ! |
lavmodel <- FIT@Model |
| 983 | ! |
lavpta <- FIT@pta |
| 984 | ! |
nblocks <- lavpta$nblocks |
| 985 | ||
| 986 | ! |
local.options <- STEP1$local.options |
| 987 | ! |
sam.method <- STEP1$sam.method |
| 988 | ||
| 989 | ! |
ngroups <- lavdata@ngroups |
| 990 | ! |
if (ngroups > 1L) {
|
| 991 | ! |
lav_msg_stop(gettext("IJ local SEs: not available with multiple groups!\n"))
|
| 992 |
} |
|
| 993 | ! |
g <- group |
| 994 | ! |
Y <- FIT@Data@X[[g]] |
| 995 | ! |
N <- nrow(Y) |
| 996 | ! |
P <- ncol(Y) |
| 997 | ||
| 998 |
# NAMES + lv.keep |
|
| 999 | ! |
lv.names <- STEP1$LV.NAMES[[1]] |
| 1000 | ! |
lv.names <- c("..int..", lv.names)
|
| 1001 | ! |
nfac <- length(lv.names) |
| 1002 | ! |
idx1 <- rep(seq_len(nfac), each = nfac) |
| 1003 | ! |
idx2 <- rep(seq_len(nfac), times = nfac) |
| 1004 | ||
| 1005 | ! |
K.nfac <- lav_matrix_commutation(nfac, nfac) |
| 1006 | ! |
IK <- diag(nfac * nfac) + K.nfac |
| 1007 | ! |
D <- lav_matrix_duplication(nfac) |
| 1008 | ||
| 1009 | ! |
NAMES <- paste(lv.names[idx1], lv.names[idx2], sep = ":") |
| 1010 | ! |
NAMES[seq_len(nfac)] <- lv.names |
| 1011 | ! |
lv.keep <- colnames(STEP1$VETA[[1]]) |
| 1012 | ! |
FS.mean <- STEP1$FS.mean[[1]] |
| 1013 | ! |
keep.idx <- match(lv.keep, NAMES) |
| 1014 | ||
| 1015 |
# step 1 free parameters |
|
| 1016 | ! |
step1.idx <- which(STEP1$PT$free %in% STEP1$step1.free.idx) |
| 1017 | ! |
x.step1 <- STEP1$PT$est[step1.idx] |
| 1018 | ||
| 1019 | ! |
this.nu <- STEP1$NU[[1]] |
| 1020 | ! |
this.M <- STEP1$M[[1]] |
| 1021 | ! |
this.MTM <- lav_matrix_bdiag(0, STEP1$MTM[[1]][seq_len(nfac - 1), seq_len(nfac - 1)]) |
| 1022 | ! |
this <- c(this.nu, lav_matrix_vec(this.M), lav_matrix_vech(this.MTM)) |
| 1023 | ! |
INDEX <- matrix(seq_len(nfac^2 * nfac^2), nfac^2, nfac^2) |
| 1024 | ||
| 1025 | ! |
x2this <- function(x) {
|
| 1026 | ! |
PT <- STEP1$PT |
| 1027 | ! |
PT$est[step1.idx] <- x |
| 1028 | ! |
this.lavmodel <- lav_model_set_parameters(lavmodel, |
| 1029 | ! |
x = PT$est[PT$free > 0 & !duplicated(PT$free)]) |
| 1030 | ! |
this.nu <- this.lavmodel@GLIST$nu |
| 1031 | ! |
rm.idx <- lavpta$vidx$lv.interaction[[1]] |
| 1032 |
# no interaction columns! |
|
| 1033 | ! |
this.lambda <- this.lavmodel@GLIST$lambda[, -rm.idx,drop = FALSE] |
| 1034 | ! |
this.theta <- this.lavmodel@GLIST$theta |
| 1035 | ! |
this.M <- lav_sam_mapping_matrix(LAMBDA = this.lambda, |
| 1036 | ! |
THETA = this.theta, |
| 1037 | ! |
S = STEP1$COV[[1]], |
| 1038 | ! |
method = STEP1$local.options$M.method) |
| 1039 | ! |
MTM <- this.M %*% this.theta %*% t(this.M) |
| 1040 | ! |
MTM <- lav_matrix_bdiag(0,MTM) |
| 1041 | ||
| 1042 | ! |
out <- c(this.nu, lav_matrix_vec(this.M), lav_matrix_vech(MTM)) |
| 1043 | ! |
out |
| 1044 |
} |
|
| 1045 | ! |
JAC.x2this <- numDeriv::jacobian(func = x2this, x = x.step1) |
| 1046 |
# 46 x 24 |
|
| 1047 | ||
| 1048 |
# JAC.eetai2.this |
|
| 1049 | ! |
JAC.eeta2.this <- matrix(0, nrow = length(STEP1$EETA[[1]]), ncol = length(this)) |
| 1050 | ! |
pstar <- nfac * (nfac + 1) / 2 |
| 1051 | ! |
idx <- P + length(this.M) + seq_len(pstar) |
| 1052 | ! |
JAC.eeta2.this[,idx] <- (-diag(nfac^2) %*% D)[keep.idx,] |
| 1053 | ||
| 1054 |
# define function for JAC.veta2.fi |
|
| 1055 | ! |
get.JAC.veta2.fi <- function(x, MTM, FS.MEAN = NULL, lambda.star = 1, keep.idx = NULL) {
|
| 1056 | ! |
fi <- drop(fi) |
| 1057 | ! |
P <- length(fi) |
| 1058 | ! |
stopifnot(P == ncol(MTM)) |
| 1059 | ||
| 1060 |
#INDEX <- matrix(seq_len(P^2 * P^2), P^2, P^2) |
|
| 1061 | ||
| 1062 |
# (tcrossprod(fi) - MTM) %x% MTM) -- part A |
|
| 1063 | ! |
block.a <- fi %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i]))
|
| 1064 | ! |
long.a <- diag(P) %x% lav_matrix_vec(fi %x% MTM) |
| 1065 | ! |
big.a <- block.a + long.a |
| 1066 | ! |
part.a <- big.a[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1067 | ||
| 1068 |
# (MTM %x% (tcrossprod(fi) - MTM)) -- part B |
|
| 1069 | ! |
block.b <- lav_matrix_vec(fi %x% MTM) %x% diag(P) |
| 1070 | ! |
long.b <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i])) %x% fi
|
| 1071 | ! |
big.b <- block.b + long.b |
| 1072 | ! |
part.b <- big.b[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1073 | ||
| 1074 |
# lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM) -- part C |
|
| 1075 | ! |
block.c <- do.call("rbind", lapply(seq_len(P), function(i) fi %x% (diag(P) %x% MTM[,i])))
|
| 1076 | ! |
long.c <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% (fi %x% MTM[,i])))
|
| 1077 | ! |
big.c <- block.c + long.c |
| 1078 | ! |
part.c <- big.c[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1079 | ||
| 1080 |
# lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM) -- part D |
|
| 1081 | ! |
long.d <- diag(P) %x% lav_matrix_vec(MTM %x% fi) |
| 1082 | ! |
block.d <- (fi %x% lav_matrix_vec(MTM)) %x% diag(P) |
| 1083 | ! |
big.d <- block.d + long.d |
| 1084 | ! |
part.d <- big.d[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1085 | ||
| 1086 |
# t1 (tcrossprod(fi2[keep.idx] - FS.mean) only) -- part E |
|
| 1087 | ! |
idx1 <- rep(seq_len(P), each = P) |
| 1088 | ! |
idx2 <- rep(seq_len(P), times = P) |
| 1089 | ! |
fi2 <- (fi[idx1]*fi[idx2]) |
| 1090 | ! |
fik <- fi2[keep.idx] |
| 1091 | ||
| 1092 | ! |
fi <- as.matrix(fi) |
| 1093 | ! |
tt <- ((fi %x% diag(P))[keep.idx,] + (diag(P) %x% fi)[keep.idx,]) |
| 1094 | ! |
tmp <- ((fik - FS.mean) %x% tt) + (tt %x% (fik - FS.mean)) |
| 1095 | ! |
part.e <- tmp[lav_matrix_vech_idx(length(fik)),] |
| 1096 | ||
| 1097 | ! |
final <- part.e - lambda.star * (part.a + part.b + part.c + part.d) |
| 1098 | ! |
final |
| 1099 |
} |
|
| 1100 | ||
| 1101 |
# define function for JAC.veta2.this.i |
|
| 1102 | ! |
get.JAC.veta2.this <- function(x, fi = NULL, lambda.star = 1, keep.idx = NULL) {
|
| 1103 | ! |
nvar <- ncol(STEP1$M[[1]]) |
| 1104 | ! |
nfac <- nrow(STEP1$M[[1]]) |
| 1105 | ! |
this.nu <- x[seq_len(nvar)]; x <- x[-seq_len(nvar)] |
| 1106 | ! |
this.M <- matrix(x[seq_len(nvar*nfac)], nrow = nfac, ncol = nvar) |
| 1107 | ! |
x <- x[-seq_len(nvar*nfac)] |
| 1108 | ! |
MTM <- lav_matrix_vech_reverse(x) |
| 1109 | ! |
fi <- as.matrix(fi) |
| 1110 | ! |
P <- nrow(fi) |
| 1111 | ||
| 1112 |
# part a: ((tcrossprod(fi) - MTM) %x% MTM) |
|
| 1113 | ! |
long.a <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% -MTM[,i]))
|
| 1114 | ! |
block.a <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% (tcrossprod(fi) - MTM)[,i])) %x% diag(P)
|
| 1115 | ! |
big.a.vec <- long.a + block.a |
| 1116 | ! |
big.a <- big.a.vec %*% D |
| 1117 | ! |
part.a <- big.a[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1118 | ||
| 1119 |
# part b: (MTM %x% (tcrossprod(fi) - MTM)) |
|
| 1120 | ! |
block.b <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% -MTM[,i])) %x% diag(P)
|
| 1121 | ! |
long.b <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% (tcrossprod(fi) - MTM)[,i]))
|
| 1122 | ! |
big.b.vec <- block.b + long.b |
| 1123 | ! |
big.b <- big.b.vec %*% D |
| 1124 | ! |
part.b <- big.b[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1125 | ||
| 1126 |
# part c: lav_matrix_commutation_post((tcrossprod(fi) - MTM) %x% MTM) |
|
| 1127 | ! |
block.c <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) ((tcrossprod(fi) - MTM)[,i]) %x% diag(P)))
|
| 1128 | ! |
long.c <- do.call("rbind", lapply(seq_len(P), function(i) diag(P*P) %x% (-MTM[,i]) ))
|
| 1129 | ! |
big.c.vec <- block.c + long.c |
| 1130 | ! |
big.c <- big.c.vec %*% D |
| 1131 | ! |
part.c <- big.c[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1132 | ||
| 1133 |
# part d: lav_matrix_commutation_pre((tcrossprod(fi) - MTM) %x% MTM) |
|
| 1134 | ! |
block.d <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) -MTM[,i] %x% diag(P)))
|
| 1135 | ! |
long.d <- do.call("rbind", lapply(seq_len(P), function(i) diag(P*P) %x% ((tcrossprod(fi) - MTM)[,i]) ))
|
| 1136 | ! |
big.d.vec <- block.d + long.d |
| 1137 | ! |
big.d <- big.d.vec %*% D |
| 1138 | ! |
part.d <- big.d[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1139 | ||
| 1140 |
# part e: (IK %*% (MTM %x% MTM)) |
|
| 1141 | ! |
K <- lav_matrix_commutation(P, P) |
| 1142 | ! |
e1 <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i]))
|
| 1143 | ! |
e2 <- do.call("rbind", lapply(seq_len(P), function(i) diag(P*P) %x% MTM[,i] ))
|
| 1144 | ! |
e3 <- do.call("rbind", lapply(seq_len(P), function(i) diag(P) %x% MTM[,i])) %x% diag(P)
|
| 1145 | ! |
e4 <- diag(P) %x% do.call("rbind", lapply(seq_len(P), function(i) K %*% (diag(P) %x% MTM[,i])))
|
| 1146 | ! |
big.e.vec <- e1 + e2 + e3 + e4 |
| 1147 | ! |
big.e <- big.e.vec %*% D |
| 1148 | ! |
part.e <- big.e[lav_matrix_vech(INDEX[keep.idx, keep.idx]),] |
| 1149 | ||
| 1150 | ! |
final <- -1 * lambda.star * (part.a + part.b + part.c + part.d + part.e) |
| 1151 | ! |
final |
| 1152 |
} |
|
| 1153 | ||
| 1154 | ! |
n_eeta_veta <- length(STEP1$EETA[[1]]) + length(lav_matrix_vech(STEP1$VETA[[1]])) |
| 1155 | ! |
CVETA <- matrix(0, nrow = n_eeta_veta, ncol = length(x.step1)) |
| 1156 | ! |
for(i in 1:N) {
|
| 1157 |
# experimental: remove fs outliers |
|
| 1158 |
#if (i %in% STEP1$fs.outlier.idx[[1]]) {
|
|
| 1159 |
# next |
|
| 1160 |
#} |
|
| 1161 | ||
| 1162 |
# factor score |
|
| 1163 | ! |
fi <- rbind(1, this.M %*% (Y[i,] - this.nu)) |
| 1164 | ||
| 1165 |
#tmp <- numDeriv::jacobian(func = theta.to.eetavetai, x = x.step1, i = i) |
|
| 1166 | ! |
JAC.this2fi.i <- rbind(0, cbind(-1 * this.M, |
| 1167 | ! |
t(as.matrix(Y[i,] - drop(this.nu))) %x% diag(nrow(this.M)), |
| 1168 | ! |
matrix(0, nrow = nrow(this.M), ncol = length(lav_matrix_vech(this.MTM))))) |
| 1169 | ||
| 1170 | ! |
JAC.eeta2.fi.i <- ((fi %x% diag(nfac)) + (diag(nfac) %x% fi))[keep.idx,] |
| 1171 | ! |
EETA2 <- ((JAC.eeta2.fi.i %*% JAC.this2fi.i) + JAC.eeta2.this) %*% JAC.x2this |
| 1172 | ||
| 1173 | ! |
JAC.veta2.fi.i <- get.JAC.veta2.fi(x = fi, MTM = this.MTM, FS.MEAN = FS.mean, |
| 1174 | ! |
lambda.star = STEP1$lambda[[1]], keep.idx = keep.idx) |
| 1175 | ! |
JAC.veta2.this.i <- matrix(0, nrow = nrow(JAC.veta2.fi.i), ncol = ncol(JAC.this2fi.i)) |
| 1176 | ! |
JAC.veta2.this.i[,idx] <- get.JAC.veta2.this(x = this, fi = fi, |
| 1177 | ! |
lambda.star = STEP1$lambda[[1]], |
| 1178 | ! |
keep.idx = keep.idx) |
| 1179 | ! |
VETA2 <- ((JAC.veta2.fi.i %*% JAC.this2fi.i) + JAC.veta2.this.i) %*% JAC.x2this |
| 1180 | ||
| 1181 |
# FIXME: remove outliers somehow? |
|
| 1182 | ! |
CVETA <- CVETA + 1/N * rbind(EETA2, VETA2) |
| 1183 |
} |
|
| 1184 | ||
| 1185 | ! |
Gamma.addition <- N * (CVETA %*% STEP1$Sigma.11 %*% t(CVETA)) |
| 1186 | ! |
Gamma.addition |
| 1187 |
} |
|
| 1188 | ||
| 1189 |
| 1 |
# LDW 11/4/24 : overwrite defaults depending on mimic in separate function |
|
| 2 |
# |
|
| 3 |
lav_options_mimic <- function(opt) {
|
|
| 4 | 79x |
mlr.test <- "yuan.bentler.mplus" # for now |
| 5 | 79x |
if (opt$gls.v11.mplus == "default") {
|
| 6 | 79x |
opt$gls.v11.mplus <- (opt$mimic == "Mplus") |
| 7 |
} |
|
| 8 | 79x |
if (opt$gamma.vcov.mplus == "default") {
|
| 9 | 79x |
opt$gamma.vcov.mplus <- (opt$mimic == "Mplus") |
| 10 |
} |
|
| 11 | 79x |
if (opt$gamma.wls.mplus == "default") {
|
| 12 | 79x |
opt$gamma.wls.mplus <- (opt$mimic == "Mplus") |
| 13 |
} |
|
| 14 | 79x |
if (opt$information.expected.mplus == "default") {
|
| 15 | 79x |
opt$information.expected.mplus <- (opt$mimic == "Mplus") |
| 16 |
} |
|
| 17 | 79x |
if (opt$mimic == "lavaan") {
|
| 18 | 79x |
if (is.character(opt$conditional.x)) { # = "default"
|
| 19 | 40x |
if (lav_options_estimatorgroup(opt$estimator) == "ML") {
|
| 20 | 36x |
opt$conditional.x <- FALSE |
| 21 |
} |
|
| 22 |
} |
|
| 23 | 79x |
if (opt$fixed.x == "default") {
|
| 24 | 40x |
if (any(lav_options_estimatorgroup(opt$estimator) == c("MML", "ML", "IV")) &&
|
| 25 | 40x |
is.character(opt$start) && opt$start != "simple") { # new in 0.6-12
|
| 26 | 36x |
opt$fixed.x <- TRUE |
| 27 |
} |
|
| 28 |
} |
|
| 29 | 79x |
if (is.character(opt$zero.keep.margins)) { # = "default"
|
| 30 | 79x |
opt$zero.keep.margins <- TRUE |
| 31 |
} |
|
| 32 | ! |
} else if (opt$mimic == "Mplus") {
|
| 33 | ! |
if (length(opt$group.equal) == 0L || all(nchar(opt$group.equal) == 0L)) {
|
| 34 | ! |
if (opt$.categorical) {
|
| 35 | ! |
opt$group.equal <- c("loadings", "thresholds")
|
| 36 |
} else {
|
|
| 37 | ! |
if (is.logical(opt$meanstructure) && !opt$meanstructure) {
|
| 38 | ! |
opt$group.equal <- "loadings" |
| 39 |
} else {
|
|
| 40 | ! |
opt$group.equal <- c("loadings", "intercepts")
|
| 41 |
} |
|
| 42 |
} |
|
| 43 |
} |
|
| 44 | ! |
if (opt$missing == "default") {
|
| 45 | ! |
if (!opt$.categorical && any(opt$estimator == c("ml", "mlr")))
|
| 46 |
{
|
|
| 47 |
# since version 5? |
|
| 48 | ! |
opt$missing <- "ml" |
| 49 |
# check later if this is ok |
|
| 50 |
} |
|
| 51 |
} |
|
| 52 | ! |
if (opt$estimator != "pml") {
|
| 53 | ! |
if (opt$meanstructure == "default") opt$meanstructure <- TRUE |
| 54 |
} |
|
| 55 | ! |
if (opt$estimator == "mlr") mlr.test <- "yuan.bentler.mplus" |
| 56 | ! |
if (any(lav_options_estimatorgroup(opt$estimator) == |
| 57 | ! |
c("ML", "REML", "NTRLS", "catML"))) {
|
| 58 |
} |
|
| 59 | ! |
if (is.character(opt$conditional.x)) { # = "default"
|
| 60 | ! |
if (lav_options_estimatorgroup(opt$estimator) == "ML") {
|
| 61 | ! |
opt$conditional.x <- FALSE |
| 62 |
} |
|
| 63 |
} |
|
| 64 | ! |
if (opt$fixed.x == "default") {
|
| 65 | ! |
if (any(lav_options_estimatorgroup(opt$estimator) == c("MML", "ML")) &&
|
| 66 | ! |
is.character(opt$start) && opt$start != "simple") { # new in 0.6-12
|
| 67 | ! |
opt$fixed.x <- TRUE |
| 68 |
} |
|
| 69 |
} |
|
| 70 | ! |
if (is.character(opt$zero.keep.margins)) { # = "default"
|
| 71 | ! |
opt$zero.keep.margins <- TRUE |
| 72 |
} |
|
| 73 | ! |
opt$baseline.conditional.x.free.slopes <- FALSE |
| 74 | ! |
} else if (opt$mimic == "EQS") {
|
| 75 | ! |
opt$baseline.fixed.x.free.cov <- FALSE |
| 76 | ! |
if (opt$estimator == "mlr") mlr.test <- "yuan.bentler" |
| 77 | ! |
if (any(lav_options_estimatorgroup(opt$estimator) == |
| 78 | ! |
c("ML", "REML", "NTRLS", "catML"))) {
|
| 79 | ! |
if (opt$likelihood == "default") opt$likelihood <- "wishart" |
| 80 |
} |
|
| 81 | ! |
} else if (opt$mimic == "LISREL") {
|
| 82 | ! |
opt$baseline.fixed.x.free.cov <- FALSE |
| 83 | ! |
if (any(lav_options_estimatorgroup(opt$estimator) == |
| 84 | ! |
c("ML", "REML", "NTRLS", "catML"))) {
|
| 85 | ! |
if (opt$likelihood == "default") opt$likelihood <- "wishart" |
| 86 |
} |
|
| 87 |
} |
|
| 88 | 79x |
if (opt$estimator == "mlr") {
|
| 89 | 2x |
if (opt$test[1] == "default") {
|
| 90 | 2x |
opt$test <- mlr.test |
| 91 |
} else {
|
|
| 92 | ! |
opt$test <- union(mlr.test, opt$test) |
| 93 |
} |
|
| 94 |
} |
|
| 95 | 79x |
opt |
| 96 |
} |
| 1 |
# the 'multiple group' method as described in Guttman, 1952 |
|
| 2 |
# |
|
| 3 |
# Guttman, L. (1952). Multiple group methods for common-factor analysis, |
|
| 4 |
# their basis, computation, and interpretation. Psychometrika, 17(2) 209--222 |
|
| 5 |
# |
|
| 6 |
# YR 02 Feb 2023: - first version in lavaan, using quadprog (no std.lv yet) |
|
| 7 | ||
| 8 |
lav_cfa_guttman1952 <- function(S, |
|
| 9 |
marker.idx = NULL, |
|
| 10 |
lambda.nonzero.idx = NULL, |
|
| 11 |
theta = NULL, # vector! |
|
| 12 |
theta.bounds = FALSE, |
|
| 13 |
force.pd = FALSE, |
|
| 14 |
zero.after.efa = FALSE, |
|
| 15 |
quadprog = FALSE, |
|
| 16 |
psi.mapping = FALSE, |
|
| 17 |
nobs = 20L) { # for cutoff
|
|
| 18 |
# dimensions |
|
| 19 | ! |
nvar <- ncol(S) |
| 20 | ! |
nfac <- length(marker.idx) |
| 21 | ! |
stopifnot(length(theta) == nvar) |
| 22 | ||
| 23 |
# overview of lambda structure |
|
| 24 | ! |
B <- matrix(0, nvar, nfac) |
| 25 | ! |
lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx |
| 26 | ! |
B[lambda.marker.idx] <- 1L |
| 27 | ! |
B[lambda.nonzero.idx] <- 1L |
| 28 | ||
| 29 |
# this method does not support crossloadings! |
|
| 30 | ! |
if (any(rowSums(B) > 1)) {
|
| 31 | ! |
lav_msg_stop(gettext("the guttman1952 procedure does not support ",
|
| 32 | ! |
"crossloadings; consider fabin or bentler1982 instead")) |
| 33 |
} |
|
| 34 | ||
| 35 |
# if we wish to keep SminTheta PD, we must keep theta within bounds |
|
| 36 | ! |
if (force.pd) {
|
| 37 | ! |
theta.bounds <- TRUE |
| 38 |
} |
|
| 39 | ! |
if (psi.mapping) {
|
| 40 | ! |
theta.bounds <- TRUE |
| 41 | ! |
force.pd <- TRUE |
| 42 |
} |
|
| 43 | ||
| 44 |
# do we first 'clip' the theta values so they are within standard bounds? |
|
| 45 |
# (Question: do we need the 0.01 and 0.99 multipliers?) |
|
| 46 | ! |
diagS <- diag(S) |
| 47 | ! |
if (theta.bounds) {
|
| 48 |
# lower bound |
|
| 49 | ! |
lower.bound <- diagS * 0 # * 0.01 |
| 50 | ! |
too.small.idx <- which(theta < lower.bound) |
| 51 | ! |
if (length(too.small.idx) > 0L) {
|
| 52 | ! |
theta[too.small.idx] <- lower.bound[too.small.idx] |
| 53 |
} |
|
| 54 | ||
| 55 |
# upper bound |
|
| 56 | ! |
upper.bound <- diagS * 1 # * 0.99 |
| 57 | ! |
too.large.idx <- which(theta > upper.bound) |
| 58 | ! |
if (length(too.large.idx) > 0L) {
|
| 59 | ! |
theta[too.large.idx] <- upper.bound[too.large.idx] |
| 60 |
} |
|
| 61 |
} |
|
| 62 | ||
| 63 |
# compute SminTheta: S where we replace diagonal with 'communalities' |
|
| 64 | ! |
diag.theta <- diag(theta, nvar) |
| 65 | ! |
SminTheta <- S - diag.theta |
| 66 | ! |
if (force.pd) {
|
| 67 | ! |
lambda <- try(lav_matrix_symmetric_diff_smallest_root(S, diag.theta), |
| 68 | ! |
silent = TRUE |
| 69 |
) |
|
| 70 | ! |
if (inherits(lambda, "try-error")) {
|
| 71 | ! |
lav_msg_warn(gettext("failed to compute lambda"))
|
| 72 | ! |
SminTheta <- S - diag.theta # and hope for the best |
| 73 |
} else {
|
|
| 74 | ! |
cutoff <- 1 + 1 / (nobs - 1) |
| 75 | ! |
if (lambda < cutoff) {
|
| 76 | ! |
lambda.star <- lambda - 1 / (nobs - 1) |
| 77 | ! |
SminTheta <- S - lambda.star * diag.theta |
| 78 |
} else {
|
|
| 79 | ! |
SminTheta <- S - diag.theta |
| 80 |
} |
|
| 81 |
} |
|
| 82 |
} else {
|
|
| 83 |
# at least we force the diagonal elements of SminTheta to be nonnegative |
|
| 84 | ! |
lower.bound <- diagS * 0.001 |
| 85 | ! |
too.small.idx <- which(diag(SminTheta) < lower.bound) |
| 86 | ! |
if (length(too.small.idx) > 0L) {
|
| 87 | ! |
diag(SminTheta)[too.small.idx] <- lower.bound[too.small.idx] |
| 88 |
} |
|
| 89 |
} |
|
| 90 | ||
| 91 |
# compute covariances among 1) (corrected) variables, and |
|
| 92 |
# 2) (corrected) sum-scores |
|
| 93 | ! |
YS.COV <- SminTheta %*% B |
| 94 | ||
| 95 |
# compute covariance matrix of corrected sum-scores |
|
| 96 |
# SS.COV <- t(B) %*% SminTheta %*% B |
|
| 97 | ! |
SS.COV <- crossprod(B, YS.COV) |
| 98 | ||
| 99 |
# scaling factors |
|
| 100 |
# D.inv.sqrt <- diag(1/sqrt(diag(SS.COV))) |
|
| 101 | ! |
d.inv.sqrt <- 1 / sqrt(diag(SS.COV)) |
| 102 | ||
| 103 |
# factor correlation matrix |
|
| 104 |
# PHI <- D.inv.sqrt %*% SS.COV %*% D.inv.sqrt |
|
| 105 | ! |
PHI <- t(SS.COV * d.inv.sqrt) * d.inv.sqrt |
| 106 | ||
| 107 |
# factor *structure* matrix |
|
| 108 |
# (covariances corrected Y & corrected normalized sum-scores) |
|
| 109 |
# YS.COR <- YS.COV %*% D.inv.sqrt |
|
| 110 | ! |
YS.COR <- t(YS.COV) * d.inv.sqrt # transposed! |
| 111 | ||
| 112 | ! |
if (zero.after.efa) {
|
| 113 |
# we initially assume a saturated LAMBDA (like EFA) |
|
| 114 |
# then, we just fix the zero-elements to zero |
|
| 115 | ||
| 116 | ! |
LAMBDA <- t(solve(PHI, YS.COR)) # = unconstrained EFA version |
| 117 |
# force zeroes |
|
| 118 | ! |
LAMBDA <- LAMBDA * B |
| 119 | ! |
} else if (quadprog) {
|
| 120 |
# constained version using quadprog |
|
| 121 |
# only useful if (in)equality constraints are needed (TODo) |
|
| 122 | ||
| 123 |
# PHI MUST be positive-definite |
|
| 124 | ! |
PHI <- cov2cor(lav_matrix_symmetric_force_pd(PHI, |
| 125 | ! |
tol = 1e-04 |
| 126 | ! |
)) # option? |
| 127 | ! |
Dmat <- lav_matrix_bdiag(rep(list(PHI), nvar)) |
| 128 | ! |
dvec <- as.vector(YS.COR) |
| 129 | ! |
eq.idx <- which(t(B) != 1) # these must be zero (row-wise!) |
| 130 | ! |
Rmat <- diag(nrow(Dmat))[eq.idx, , drop = FALSE] |
| 131 | ! |
bvec <- rep(0, length(eq.idx)) # optional, 0=default |
| 132 | ! |
out <- try(quadprog::solve.QP( |
| 133 | ! |
Dmat = Dmat, dvec = dvec, Amat = t(Rmat), |
| 134 | ! |
meq = length(eq.idx), bvec = bvec |
| 135 | ! |
), silent = TRUE) |
| 136 | ! |
if (inherits(out, "try-error")) {
|
| 137 | ! |
lav_msg_warn(gettext("solve.QP failed to find a solution"))
|
| 138 | ! |
Lambda <- B |
| 139 | ! |
Lambda[lambda.nonzero.idx] <- as.numeric(NA) |
| 140 | ! |
Theta <- diag(rep(as.numeric(NA), nvar), nvar) |
| 141 | ! |
Psi <- matrix(as.numeric(NA), nfac, nfac) |
| 142 | ! |
return(list(lambda = Lambda, theta = Theta, psi = Psi)) |
| 143 |
} else {
|
|
| 144 | ! |
LAMBDA <- matrix(out$solution, nrow = nvar, ncol = nfac, byrow = TRUE) |
| 145 |
# zap almost zero elements |
|
| 146 | ! |
LAMBDA[abs(LAMBDA) < sqrt(.Machine$double.eps)] <- 0 |
| 147 |
} |
|
| 148 |
} else {
|
|
| 149 |
# default, if no (in)equality constraints |
|
| 150 | ! |
LAMBDA <- t(solve(PHI, YS.COR)) # = unconstrained EFA version |
| 151 |
#YS.COR0 <- YS.COR |
|
| 152 |
#YS.COR0[t(B) != 1] <- 0 |
|
| 153 |
#LAMBDA <- t(YS.COR0) |
|
| 154 |
} |
|
| 155 | ||
| 156 |
# rescale LAMBDA, so that 'marker' indicator == 1 |
|
| 157 | ! |
marker.lambda <- LAMBDA[lambda.marker.idx] |
| 158 | ! |
Lambda <- t(t(LAMBDA) * (1 / marker.lambda)) |
| 159 | ||
| 160 |
# rescale PHI, covariance metric |
|
| 161 | ! |
Psi <- t(PHI * marker.lambda) * marker.lambda |
| 162 | ||
| 163 |
# redo psi using ML mapping function? |
|
| 164 | ! |
if (psi.mapping) {
|
| 165 | ! |
Ti <- 1 / theta |
| 166 | ! |
zero.theta.idx <- which(abs(theta) < 0.01) # be conservative |
| 167 | ! |
if (length(zero.theta.idx) > 0L) {
|
| 168 | ! |
Ti[zero.theta.idx] <- 1 |
| 169 |
} |
|
| 170 | ||
| 171 |
# ML mapping function |
|
| 172 | ! |
M <- solve(t(Lambda) %*% diag(Ti, nvar) %*% Lambda) %*% t(Lambda) %*% diag(Ti, nvar) |
| 173 | ! |
Psi <- M %*% SminTheta %*% t(M) |
| 174 |
} |
|
| 175 | ||
| 176 | ! |
list(lambda = Lambda, theta = theta, psi = Psi) |
| 177 |
} |
|
| 178 | ||
| 179 |
# internal function to be used inside lav_optim_noniter |
|
| 180 |
# return 'x', the estimated vector of free parameters |
|
| 181 |
lav_cfa_guttman1952_internal <- function(lavobject = NULL, # convenience |
|
| 182 |
# internal slot |
|
| 183 |
lavmodel = NULL, |
|
| 184 |
lavsamplestats = NULL, |
|
| 185 |
lavpartable = NULL, |
|
| 186 |
lavdata = NULL, |
|
| 187 |
lavoptions = NULL, |
|
| 188 |
theta.bounds = TRUE, |
|
| 189 |
force.pd = TRUE, |
|
| 190 |
zero.after.efa = FALSE, |
|
| 191 |
quadprog = FALSE, |
|
| 192 |
psi.mapping = TRUE) {
|
|
| 193 | ! |
lavpta <- NULL |
| 194 | ! |
if (!is.null(lavobject)) {
|
| 195 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 196 | ||
| 197 |
# extract slots |
|
| 198 | ! |
lavmodel <- lavobject@Model |
| 199 | ! |
lavsamplestats <- lavobject@SampleStats |
| 200 | ! |
lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta) |
| 201 | ! |
lavpta <- lavobject@pta |
| 202 | ! |
lavdata <- lavobject@Data |
| 203 | ! |
lavoptions <- lavobject@Options |
| 204 |
} |
|
| 205 | ! |
if (is.null(lavpta)) {
|
| 206 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 207 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 208 |
} |
|
| 209 | ||
| 210 | ! |
if (missing(zero.after.efa) && |
| 211 | ! |
!is.null(lavoptions$estimator.args$zero.after.efa)) {
|
| 212 | ! |
zero.after.efa <- lavoptions$estimator.args$zero.after.efa |
| 213 |
} |
|
| 214 | ||
| 215 | ! |
if (missing(psi.mapping) && |
| 216 | ! |
!is.null(lavoptions$estimator.args$psi.mapping)) {
|
| 217 | ! |
psi.mapping <- lavoptions$estimator.args$psi.mapping |
| 218 |
} |
|
| 219 | ||
| 220 | ! |
if (missing(quadprog) && |
| 221 | ! |
!is.null(lavoptions$estimator.args$quadprog)) {
|
| 222 | ! |
quadprog <- lavoptions$estimator.args$quadprog |
| 223 |
} |
|
| 224 | ||
| 225 |
# no structural part! |
|
| 226 | ! |
if (any(lavpartable$op == "~")) {
|
| 227 | ! |
lav_msg_stop(gettext("GUTTMAN1952 estimator only available for CFA models"))
|
| 228 |
} |
|
| 229 |
# no BETA matrix! (i.e., no higher-order factors) |
|
| 230 | ! |
if (!is.null(lavmodel@GLIST$beta)) {
|
| 231 | ! |
lav_msg_stop(gettext( |
| 232 | ! |
"GUTTMAN1952 estimator not available for models that require a BETA matrix")) |
| 233 |
} |
|
| 234 |
# no std.lv = TRUE for now |
|
| 235 | ! |
if (lavoptions$std.lv) {
|
| 236 | ! |
lav_msg_stop(gettext( |
| 237 | ! |
"GUTTMAN1952 estimator not available if std.lv = TRUE")) |
| 238 |
} |
|
| 239 | ||
| 240 | ! |
nblocks <- lav_partable_nblocks(lavpartable) |
| 241 | ! |
stopifnot(nblocks == 1L) # for now |
| 242 | ! |
b <- 1L |
| 243 | ! |
sample.cov <- lavsamplestats@cov[[b]] |
| 244 | ! |
nvar <- nrow(sample.cov) |
| 245 | ! |
lv.names <- lavpta$vnames$lv.regular[[b]] |
| 246 | ! |
nfac <- length(lv.names) |
| 247 | ! |
marker.idx <- lavpta$vidx$lv.marker[[b]] |
| 248 | ! |
lambda.idx <- which(names(lavmodel@GLIST) == "lambda") |
| 249 | ! |
lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]] |
| 250 |
# only diagonal THETA for now... |
|
| 251 |
# because if we have correlated residuals, we should remove the |
|
| 252 |
# corresponding variables as instruments before we estimate lambda... |
|
| 253 |
# (see MIIV) |
|
| 254 | ! |
theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2' |
| 255 | ! |
m.theta <- lavmodel@m.free.idx[[theta.idx]] |
| 256 | ! |
nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)] |
| 257 | ! |
if (length(nondiag.idx) > 0L) {
|
| 258 | ! |
lav_msg_warn(gettext( |
| 259 | ! |
"this implementation of FABIN does not handle correlated residuals yet!")) |
| 260 |
} |
|
| 261 | ||
| 262 |
# 1. obtain estimate for (diagonal elements of) THETA |
|
| 263 |
# for now we use Spearman per factor |
|
| 264 | ! |
B <- matrix(0, nvar, nfac) |
| 265 | ! |
lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx |
| 266 | ! |
B[lambda.marker.idx] <- 1L |
| 267 | ! |
B[lambda.nonzero.idx] <- 1L |
| 268 | ! |
theta <- numeric(nvar) |
| 269 | ! |
for (f in seq_len(nfac)) {
|
| 270 | ! |
ov.idx <- which(B[, f] == 1L) |
| 271 | ! |
S.fac <- sample.cov[ov.idx, ov.idx, drop = FALSE] |
| 272 | ! |
theta[ov.idx] <- lav_cfa_theta_spearman(S.fac, bounds = "wide") |
| 273 |
} |
|
| 274 | ||
| 275 |
# 2. run Guttman1952 'Multiple Groups' algorithm |
|
| 276 | ! |
out <- lav_cfa_guttman1952( |
| 277 | ! |
S = sample.cov, marker.idx = marker.idx, |
| 278 | ! |
lambda.nonzero.idx = lambda.nonzero.idx, |
| 279 | ! |
theta = theta, |
| 280 |
# experimental |
|
| 281 | ! |
theta.bounds = theta.bounds, |
| 282 | ! |
force.pd = force.pd, |
| 283 | ! |
zero.after.efa = zero.after.efa, |
| 284 | ! |
quadprog = quadprog, |
| 285 | ! |
psi.mapping = psi.mapping, |
| 286 |
# |
|
| 287 | ! |
nobs = lavsamplestats@ntotal |
| 288 |
) |
|
| 289 | ! |
LAMBDA <- out$lambda |
| 290 | ! |
THETA <- diag(out$theta, nvar) |
| 291 | ! |
PSI <- out$psi |
| 292 | ||
| 293 |
# store matrices in lavmodel@GLIST |
|
| 294 | ! |
lavmodel@GLIST$lambda <- LAMBDA |
| 295 | ! |
lavmodel@GLIST$theta <- THETA |
| 296 | ! |
lavmodel@GLIST$psi <- PSI |
| 297 | ||
| 298 |
# extract free parameters only |
|
| 299 | ! |
x <- lav_model_get_parameters(lavmodel) |
| 300 | ||
| 301 |
# apply bounds (if any) |
|
| 302 | ! |
if (!is.null(lavpartable$lower)) {
|
| 303 | ! |
lower.x <- lavpartable$lower[lavpartable$free > 0] |
| 304 | ! |
too.small.idx <- which(x < lower.x) |
| 305 | ! |
if (length(too.small.idx) > 0L) {
|
| 306 | ! |
x[too.small.idx] <- lower.x[too.small.idx] |
| 307 |
} |
|
| 308 |
} |
|
| 309 | ! |
if (!is.null(lavpartable$upper)) {
|
| 310 | ! |
upper.x <- lavpartable$upper[lavpartable$free > 0] |
| 311 | ! |
too.large.idx <- which(x > upper.x) |
| 312 | ! |
if (length(too.large.idx) > 0L) {
|
| 313 | ! |
x[too.large.idx] <- upper.x[too.large.idx] |
| 314 |
} |
|
| 315 |
} |
|
| 316 | ||
| 317 | ! |
x |
| 318 |
} |
| 1 |
# bootstrap based NVCOV |
|
| 2 |
lav_model_nvcov_bootstrap <- function(lavmodel = NULL, |
|
| 3 |
lavsamplestats = NULL, |
|
| 4 |
lavoptions = NULL, |
|
| 5 |
lavimplied = NULL, |
|
| 6 |
lavh1 = NULL, |
|
| 7 |
lavdata = NULL, |
|
| 8 |
lavcache = NULL, |
|
| 9 |
lavpartable = NULL) {
|
|
| 10 |
# number of bootstrap draws |
|
| 11 | 1x |
if (!is.null(lavoptions$bootstrap)) {
|
| 12 | 1x |
R <- lavoptions$bootstrap |
| 13 |
} else {
|
|
| 14 | ! |
R <- 1000L |
| 15 |
} |
|
| 16 | ||
| 17 | 1x |
boot.type <- "ordinary" |
| 18 | 1x |
if ("bollen.stine" %in% lavoptions$test) {
|
| 19 | ! |
boot.type <- "bollen.stine" |
| 20 |
} |
|
| 21 | ||
| 22 | 1x |
TEST <- NULL |
| 23 | 1x |
COEF <- lav_bootstrap_internal( |
| 24 | 1x |
object = NULL, |
| 25 | 1x |
lavmodel. = lavmodel, |
| 26 | 1x |
lavsamplestats. = lavsamplestats, |
| 27 | 1x |
lavpartable. = lavpartable, |
| 28 | 1x |
lavoptions. = lavoptions, |
| 29 | 1x |
lavdata. = lavdata, |
| 30 | 1x |
R = R, |
| 31 | 1x |
check.post = lavoptions$check.post, |
| 32 | 1x |
type = boot.type, |
| 33 | 1x |
FUN = ifelse(boot.type == "bollen.stine", |
| 34 | 1x |
"coeftest", "coef" |
| 35 |
) |
|
| 36 |
) |
|
| 37 |
# warn = -1L) |
|
| 38 | ! |
COEF.orig <- COEF |
| 39 | ||
| 40 |
# new in 0.6-12: always warn for failed and nonadmissible |
|
| 41 | ! |
error.idx <- attr(COEF, "error.idx") |
| 42 | ! |
nfailed <- length(error.idx) # zero if NULL |
| 43 | ! |
if (nfailed > 0L) {
|
| 44 | ! |
lav_msg_warn(gettextf( |
| 45 | ! |
"%s bootstrap runs failed or did not converge.", nfailed)) |
| 46 |
} |
|
| 47 | ||
| 48 | ! |
notok <- length(attr(COEF, "nonadmissible")) # zero if NULL |
| 49 | ! |
if (notok > 0L) {
|
| 50 | ! |
lav_msg_warn(gettextf( |
| 51 | ! |
"%s bootstrap runs resulted in nonadmissible solutions.", notok)) |
| 52 |
} |
|
| 53 | ||
| 54 | ! |
if (length(error.idx) > 0L) {
|
| 55 |
# new in 0.6-13: we must still remove them! |
|
| 56 | ! |
COEF <- COEF[-error.idx, , drop = FALSE] |
| 57 |
# this also drops the attributes |
|
| 58 |
} |
|
| 59 | ||
| 60 | ! |
if (boot.type == "bollen.stine") {
|
| 61 | ! |
nc <- ncol(COEF) |
| 62 | ! |
TEST <- COEF[, nc] |
| 63 | ! |
COEF <- COEF[, -nc, drop = FALSE] |
| 64 |
} |
|
| 65 | ||
| 66 |
# new in 0.6-20: check for outliers, ie big difference between sd() and mad() |
|
| 67 |
# see github issue 347 |
|
| 68 | ! |
sd_mad_ratio <- ( apply(COEF, 2, sd, na.rm = TRUE) / |
| 69 | ! |
apply(COEF, 2, mad, na.rm = TRUE) ) |
| 70 | ! |
crit.ratio <- 5 |
| 71 | ! |
if (any(sd_mad_ratio > crit.ratio)) {
|
| 72 | ! |
NAMES <- lav_partable_labels(lavpartable, type = "free") |
| 73 | ! |
params_w_outliers <- paste(NAMES[sd_mad_ratio > crit.ratio], collapse = " ") |
| 74 | ! |
lav_msg_warn(gettextf( |
| 75 | ! |
"The following boostrapped free parameters have a high (>5) |
| 76 | ! |
ratio of standard deviation to median absolute deviation: %s. |
| 77 | ! |
P-values and confidence intervals may not match.", params_w_outliers)) |
| 78 |
} |
|
| 79 | ||
| 80 |
# FIXME: cov rescale? Yes for now |
|
| 81 | ! |
nboot <- nrow(COEF) |
| 82 | ! |
NVarCov <- lavsamplestats@ntotal * (cov(COEF) * (nboot - 1) / nboot) |
| 83 | ||
| 84 |
# save COEF and TEST (if any) |
|
| 85 | ! |
attr(NVarCov, "BOOT.COEF") <- COEF.orig # including attributes |
| 86 | ! |
attr(NVarCov, "BOOT.TEST") <- TEST |
| 87 | ||
| 88 | ! |
NVarCov |
| 89 |
} |
|
| 90 | ||
| 91 | ||
| 92 |
# robust `sem' NVCOV (see Browne, 1984, bentler & dijkstra 1985) |
|
| 93 |
lav_model_nvcov_robust_sem <- function(lavmodel = NULL, |
|
| 94 |
lavsamplestats = NULL, |
|
| 95 |
lavdata = NULL, |
|
| 96 |
lavcache = NULL, |
|
| 97 |
lavimplied = NULL, |
|
| 98 |
lavh1 = NULL, |
|
| 99 |
lavoptions = NULL, |
|
| 100 |
use.ginv = FALSE, |
|
| 101 |
attr.Delta = TRUE, |
|
| 102 |
attr.tDVGVD = FALSE, |
|
| 103 |
attr.E.inv = FALSE, |
|
| 104 |
attr.WLS.V = FALSE) {
|
|
| 105 |
# compute inverse of the expected(!) information matrix |
|
| 106 | 4x |
if (lavmodel@estimator == "ML" && lavoptions$information.expected.mplus) {
|
| 107 |
# YR - 11 aug 2010 - what Mplus seems to do is (see Muthen apx 4 eq102) |
|
| 108 |
# - A1 is not based on Sigma.hat and Mu.hat, |
|
| 109 |
# but on lavsamplestats@cov and lavsamplestats@mean... ('unstructured')
|
|
| 110 |
# - Gamma is not identical to what is used for WLS; closer to EQS |
|
| 111 |
# - N/N-1 bug in G11 for NVarCov (but not test statistic) |
|
| 112 |
# - we divide by N-1! (just like EQS) |
|
| 113 | ! |
E.inv <- lav_model_information_expected_MLM( |
| 114 | ! |
lavmodel = lavmodel, |
| 115 | ! |
lavsamplestats = lavsamplestats, |
| 116 | ! |
extra = TRUE, |
| 117 | ! |
augmented = TRUE, |
| 118 | ! |
inverted = TRUE, |
| 119 | ! |
use.ginv = use.ginv |
| 120 |
) |
|
| 121 |
} else {
|
|
| 122 | 4x |
E.inv <- lav_model_information( |
| 123 | 4x |
lavmodel = lavmodel, |
| 124 | 4x |
lavsamplestats = lavsamplestats, |
| 125 | 4x |
lavdata = lavdata, |
| 126 | 4x |
lavimplied = lavimplied, |
| 127 | 4x |
lavh1 = lavh1, |
| 128 | 4x |
lavoptions = lavoptions, |
| 129 | 4x |
extra = TRUE, |
| 130 | 4x |
augmented = TRUE, |
| 131 | 4x |
inverted = TRUE, |
| 132 | 4x |
use.ginv = use.ginv |
| 133 |
) |
|
| 134 |
} |
|
| 135 | ||
| 136 |
# check if E.inv is ok |
|
| 137 | 4x |
if (inherits(E.inv, "try-error")) {
|
| 138 | ! |
return(E.inv) |
| 139 |
} |
|
| 140 | ||
| 141 | 4x |
Delta <- attr(E.inv, "Delta") |
| 142 | 4x |
WLS.V <- attr(E.inv, "WLS.V") |
| 143 | 4x |
attr(E.inv, "Delta") <- NULL |
| 144 | 4x |
attr(E.inv, "WLS.V") <- NULL |
| 145 |
# Gamma |
|
| 146 | 4x |
Gamma <- lavsamplestats@NACOV |
| 147 | 4x |
if (lavmodel@estimator == "ML" && |
| 148 | 4x |
lavoptions$gamma.vcov.mplus && !lavsamplestats@NACOV.user) {
|
| 149 |
# 'fix' G11 part of Gamma (NOTE: this is NOT needed for SB test |
|
| 150 |
# statistic |
|
| 151 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 152 | ! |
gg1 <- (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]] |
| 153 | ! |
if (lavmodel@conditional.x) {
|
| 154 | ! |
nvar <- NCOL(lavsamplestats@res.cov[[g]]) |
| 155 |
} else {
|
|
| 156 | ! |
nvar <- NCOL(lavsamplestats@cov[[g]]) |
| 157 |
} |
|
| 158 | ! |
G11 <- Gamma[[g]][1:nvar, 1:nvar, drop = FALSE] |
| 159 | ! |
Gamma[[g]][1:nvar, 1:nvar] <- G11 * gg1 |
| 160 |
} # g |
|
| 161 |
} |
|
| 162 | ||
| 163 | ||
| 164 | 4x |
tDVGVD <- matrix(0, ncol = ncol(E.inv), nrow = nrow(E.inv)) |
| 165 | 4x |
for (g in 1:lavsamplestats@ngroups) {
|
| 166 | 4x |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 167 | 4x |
if (lavoptions$gamma.vcov.mplus) {
|
| 168 | ! |
fg1 <- (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@ntotal |
| 169 |
} else {
|
|
| 170 |
# from 0.6 onwards, we use fg1 == fg, to be more consistent with |
|
| 171 |
# lav_test() |
|
| 172 | 4x |
fg1 <- fg |
| 173 |
} |
|
| 174 |
# fg twice for WLS.V, 1/fg1 once for GaMMA |
|
| 175 |
# if fg==fg1, there would be only one fg, as in Satorra 1999 p.8 |
|
| 176 |
# t(Delta) * WLS.V %*% Gamma %*% WLS.V %*% Delta |
|
| 177 | 4x |
if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
|
| 178 |
# diagonal weight matrix |
|
| 179 | 4x |
WD <- WLS.V[[g]] * Delta[[g]] |
| 180 |
} else {
|
|
| 181 |
# full weight matrix |
|
| 182 | ! |
WD <- WLS.V[[g]] %*% Delta[[g]] |
| 183 |
} |
|
| 184 | 4x |
tDVGVD <- tDVGVD + fg * fg / fg1 * crossprod(WD, Gamma[[g]] %*% WD) |
| 185 |
} # g |
|
| 186 | 4x |
NVarCov <- (E.inv %*% tDVGVD %*% E.inv) |
| 187 | ||
| 188 |
# to be reused by lav_test() |
|
| 189 | 4x |
if (attr.Delta) {
|
| 190 | 4x |
attr(NVarCov, "Delta") <- Delta |
| 191 |
} |
|
| 192 |
# for twostep.robust in sam() |
|
| 193 | 4x |
if (attr.tDVGVD) {
|
| 194 | ! |
attr(NVarCov, "tDVGVD") <- tDVGVD |
| 195 |
} |
|
| 196 | ||
| 197 | 4x |
if ((lavoptions$information[1] == lavoptions$information[2]) && |
| 198 | 4x |
(lavoptions$h1.information[1] == lavoptions$h1.information[2]) && |
| 199 | 4x |
(lavoptions$information[2] == "expected" || |
| 200 | 4x |
lavoptions$observed.information[1] == |
| 201 | 4x |
lavoptions$observed.information[2])) {
|
| 202 |
# only when same type of information is used # new in 0.6-6 |
|
| 203 | 4x |
attr(NVarCov, "E.inv") <- E.inv |
| 204 | 4x |
attr(NVarCov, "WLS.V") <- WLS.V |
| 205 |
} |
|
| 206 | ||
| 207 |
# user override |
|
| 208 | 4x |
if (attr.E.inv && is.null(attr(NVarCov, "E.inv"))) {
|
| 209 | ! |
attr(NVarCov, "E.inv") <- E.inv |
| 210 |
} |
|
| 211 | 4x |
if (attr.WLS.V && is.null(attr(NVarCov, "WLS.V"))) {
|
| 212 | ! |
attr(NVarCov, "WLS.V") <- WLS.V |
| 213 |
} |
|
| 214 | ||
| 215 | 4x |
NVarCov |
| 216 |
} |
|
| 217 | ||
| 218 |
lav_model_nvcov_robust_sandwich <- function(lavmodel = NULL, |
|
| 219 |
lavsamplestats = NULL, |
|
| 220 |
lavdata = NULL, |
|
| 221 |
lavoptions = NULL, |
|
| 222 |
lavimplied = NULL, |
|
| 223 |
lavh1 = NULL, |
|
| 224 |
lavcache = NULL, |
|
| 225 |
use.ginv = FALSE) {
|
|
| 226 |
# sandwich estimator: A.inv %*% B %*% t(A.inv) |
|
| 227 |
# where A.inv == E.inv |
|
| 228 |
# B == outer product of case-wise scores |
|
| 229 | ||
| 230 |
# inverse observed/expected information matrix |
|
| 231 | 8x |
E.inv <- lav_model_information( |
| 232 | 8x |
lavmodel = lavmodel, |
| 233 | 8x |
lavsamplestats = lavsamplestats, |
| 234 | 8x |
lavdata = lavdata, |
| 235 | 8x |
lavcache = lavcache, |
| 236 | 8x |
lavimplied = lavimplied, |
| 237 | 8x |
lavh1 = lavh1, |
| 238 | 8x |
lavoptions = lavoptions, |
| 239 | 8x |
extra = FALSE, |
| 240 | 8x |
augmented = TRUE, |
| 241 | 8x |
inverted = TRUE, |
| 242 | 8x |
use.ginv = use.ginv |
| 243 |
) |
|
| 244 | ||
| 245 |
# check if E.inv is ok |
|
| 246 | 8x |
if (inherits(E.inv, "try-error")) {
|
| 247 | ! |
return(E.inv) |
| 248 |
} |
|
| 249 | ||
| 250 |
# new in 0.6-6, check for h1.information.meat |
|
| 251 | 8x |
lavoptions2 <- lavoptions |
| 252 | 8x |
if (!is.null(lavoptions$information.meat)) {
|
| 253 | 8x |
lavoptions2$information <- lavoptions$information.meat |
| 254 |
} |
|
| 255 | 8x |
if (!is.null(lavoptions$h1.information.meat)) {
|
| 256 | 8x |
lavoptions2$h1.information <- lavoptions$h1.information.meat |
| 257 |
} |
|
| 258 | ||
| 259 |
# outer product of case-wise scores |
|
| 260 | 8x |
B0 <- |
| 261 | 8x |
lav_model_information_firstorder( |
| 262 | 8x |
lavmodel = lavmodel, |
| 263 | 8x |
lavsamplestats = lavsamplestats, |
| 264 | 8x |
lavdata = lavdata, |
| 265 | 8x |
lavcache = lavcache, |
| 266 | 8x |
lavimplied = lavimplied, |
| 267 | 8x |
lavh1 = lavh1, |
| 268 | 8x |
lavoptions = lavoptions2, |
| 269 | 8x |
extra = TRUE, |
| 270 | 8x |
check.pd = FALSE, |
| 271 | 8x |
augmented = FALSE, |
| 272 | 8x |
inverted = FALSE, |
| 273 | 8x |
use.ginv = use.ginv |
| 274 |
) |
|
| 275 | ||
| 276 |
# compute sandwich estimator |
|
| 277 | 8x |
NVarCov <- E.inv %*% B0 %*% E.inv |
| 278 | ||
| 279 | 8x |
attr(NVarCov, "B0.group") <- attr(B0, "B0.group") |
| 280 | ||
| 281 | 8x |
if ((lavoptions$information[1] == lavoptions$information[2]) && |
| 282 | 8x |
(lavoptions$h1.information[1] == lavoptions$h1.information[2]) && |
| 283 | 8x |
(lavoptions$information[2] == "expected" || |
| 284 | 8x |
lavoptions$observed.information[1] == |
| 285 | 8x |
lavoptions$observed.information[2])) {
|
| 286 |
# only when same type of information is used # new in 0.6-6 |
|
| 287 | 8x |
attr(NVarCov, "E.inv") <- E.inv |
| 288 |
} |
|
| 289 | ||
| 290 | 8x |
NVarCov |
| 291 |
} |
|
| 292 | ||
| 293 |
# two stage |
|
| 294 |
# - two.stage: Gamma = I_1^{-1}
|
|
| 295 |
# - robust.two.stage: Gamma = incomplete Gamma (I_1^{-1} J_1 I_1^{-1})
|
|
| 296 |
# where I_1 and J_1 are based on the (saturated) model h1 |
|
| 297 |
# (either unstructured, or structured) |
|
| 298 |
# |
|
| 299 |
# references: |
|
| 300 |
# |
|
| 301 |
# - Savalei \& Bentler (2009) eq (6) for se = "two.stage" |
|
| 302 |
# - Savalei \& Falk (2014) eq (3) for se = "robust.two.stage" |
|
| 303 |
# - Yuan \& Bentler (2000) |
|
| 304 |
lav_model_nvcov_two_stage <- function(lavmodel = NULL, |
|
| 305 |
lavsamplestats = NULL, |
|
| 306 |
lavoptions = NULL, |
|
| 307 |
lavimplied = NULL, |
|
| 308 |
lavh1 = NULL, |
|
| 309 |
lavdata = NULL, |
|
| 310 |
use.ginv = FALSE) {
|
|
| 311 |
# expected OR observed, depending on lavoptions$information |
|
| 312 | ! |
if (is.null(lavoptions) && is.null(lavoptions$information[1])) {
|
| 313 | ! |
lavoptions <- list( |
| 314 | ! |
information = "observed", |
| 315 | ! |
observed.information = "h1", |
| 316 | ! |
h1.information = "structured" |
| 317 |
) |
|
| 318 |
} |
|
| 319 | ||
| 320 |
# restrictions: |
|
| 321 |
# only works if: |
|
| 322 |
# - information is expected, |
|
| 323 |
# - or information is observed but with observed.information == "h1" |
|
| 324 | ! |
if (lavoptions$information[1] == "observed" && |
| 325 | ! |
lavoptions$observed.information[1] != "h1") {
|
| 326 | ! |
lav_msg_stop( |
| 327 | ! |
gettext("two.stage + observed information currently only works
|
| 328 | ! |
with observed.information = 'h1'")) |
| 329 |
} |
|
| 330 |
# no weights (yet) |
|
| 331 | ! |
if (!is.null(lavdata@weights[[1]])) {
|
| 332 | ! |
lav_msg_stop(gettext("two.stage + sampling.weights is not supported yet"))
|
| 333 |
} |
|
| 334 |
# no fixed.x (yet) |
|
| 335 |
# if(!is.null(lavsamplestats@x.idx) && |
|
| 336 |
# length(lavsamplestats@x.idx[[1]]) > 0L) {
|
|
| 337 |
# lav_msg_stop(gettext("two.stage + fixed.x = TRUE is not supported yet"))
|
|
| 338 |
# } |
|
| 339 | ||
| 340 | ||
| 341 |
# information matrix |
|
| 342 | ! |
E.inv <- lav_model_information( |
| 343 | ! |
lavmodel = lavmodel, |
| 344 | ! |
lavsamplestats = lavsamplestats, |
| 345 | ! |
lavdata = lavdata, |
| 346 | ! |
lavoptions = lavoptions, |
| 347 | ! |
lavimplied = lavimplied, |
| 348 | ! |
lavh1 = lavh1, |
| 349 | ! |
extra = TRUE, |
| 350 | ! |
augmented = TRUE, |
| 351 | ! |
inverted = TRUE, |
| 352 | ! |
use.ginv = use.ginv |
| 353 |
) |
|
| 354 | ! |
Delta <- attr(E.inv, "Delta") |
| 355 | ! |
WLS.V <- attr(E.inv, "WLS.V") # this is 'H' or 'A1' in the literature |
| 356 | ! |
attr(E.inv, "Delta") <- NULL |
| 357 | ! |
attr(E.inv, "WLS.V") <- NULL |
| 358 | ||
| 359 |
# check if E.inv is ok |
|
| 360 | ! |
if (inherits(E.inv, "try-error")) {
|
| 361 | ! |
return(E.inv) |
| 362 |
} |
|
| 363 | ||
| 364 |
# check WLS.V = A1 |
|
| 365 | ! |
if (is.null(WLS.V)) {
|
| 366 | ! |
lav_msg_stop(gettext("WLS.V/H/A1 is NULL, observed.information = hessian?"))
|
| 367 |
} |
|
| 368 | ||
| 369 |
# Gamma |
|
| 370 | ! |
Gamma <- vector("list", length = lavsamplestats@ngroups)
|
| 371 | ||
| 372 |
# handle multiple groups |
|
| 373 | ! |
tDVGVD <- matrix(0, ncol = ncol(E.inv), nrow = nrow(E.inv)) |
| 374 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 375 | ! |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 376 |
# fg1 <- (lavsamplestats@nobs[[g]]-1)/lavsamplestats@ntotal |
|
| 377 | ! |
fg1 <- fg |
| 378 |
# fg twice for WLS.V, 1/fg1 once for GaMMA |
|
| 379 |
# if fg==fg1, there would be only one fg, as in Satorra 1999 p.8 |
|
| 380 |
# t(Delta) * WLS.V %*% Gamma %*% WLS.V %*% Delta |
|
| 381 | ! |
WD <- WLS.V[[g]] %*% Delta[[g]] |
| 382 | ||
| 383 |
# to compute (incomplete) GAMMA, should we use |
|
| 384 |
# structured or unstructured mean/sigma? |
|
| 385 |
# |
|
| 386 |
# we use the same setting as to compute 'H' (the h1 information matrix) |
|
| 387 |
# so that at Omega = H if data is complete |
|
| 388 | ! |
if (lavoptions$h1.information[1] == "unstructured") {
|
| 389 |
#MU <- lavsamplestats@missing.h1[[g]]$mu |
|
| 390 |
#SIGMA <- lavsamplestats@missing.h1[[g]]$sigma |
|
| 391 | ! |
MU <- lavh1$implied$mean[[g]] |
| 392 | ! |
SIGMA <- lavh1$implied$cov[[g]] |
| 393 |
} else {
|
|
| 394 | ! |
MU <- lavimplied$mean[[g]] |
| 395 | ! |
SIGMA <- lavimplied$cov[[g]] |
| 396 |
} |
|
| 397 | ||
| 398 |
# compute 'Gamma' (or Omega.beta) |
|
| 399 | ! |
if (lavoptions$se == "two.stage") {
|
| 400 |
# this is Savalei & Bentler (2009) |
|
| 401 | ! |
if (lavoptions$information[1] == "expected") {
|
| 402 | ! |
Info <- lav_mvnorm_missing_information_expected( |
| 403 | ! |
Y = lavdata@X[[g]], Mp = lavdata@Mp[[g]], |
| 404 | ! |
wt = lavdata@weights[[g]], |
| 405 | ! |
Mu = MU, Sigma = SIGMA, |
| 406 | ! |
x.idx = lavsamplestats@x.idx[[g]] |
| 407 |
) |
|
| 408 |
} else {
|
|
| 409 | ! |
Info <- lav_mvnorm_missing_information_observed_samplestats( |
| 410 | ! |
Yp = lavsamplestats@missing[[g]], |
| 411 |
# wt not needed |
|
| 412 | ! |
Mu = MU, Sigma = SIGMA, |
| 413 | ! |
x.idx = lavsamplestats@x.idx[[g]] |
| 414 |
) |
|
| 415 |
} |
|
| 416 | ! |
Gamma[[g]] <- lav_matrix_symmetric_inverse(Info) |
| 417 |
} else { # we assume "robust.two.stage"
|
|
| 418 |
# NACOV is here incomplete Gamma |
|
| 419 |
# Savalei & Falk (2014) |
|
| 420 |
# |
|
| 421 | ! |
if (length(lavdata@cluster) > 0L) {
|
| 422 | ! |
cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
| 423 |
} else {
|
|
| 424 | ! |
cluster.idx <- NULL |
| 425 |
} |
|
| 426 | ! |
Gamma[[g]] <- lav_mvnorm_missing_h1_omega_sw( |
| 427 | ! |
Y = |
| 428 | ! |
lavdata@X[[g]], Mp = lavdata@Mp[[g]], |
| 429 | ! |
Yp = lavsamplestats@missing[[g]], |
| 430 | ! |
wt = lavdata@weights[[g]], |
| 431 | ! |
cluster.idx = cluster.idx, |
| 432 | ! |
Mu = MU, Sigma = SIGMA, |
| 433 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 434 | ! |
information = lavoptions$information[1] |
| 435 |
) |
|
| 436 |
} |
|
| 437 | ||
| 438 |
# compute |
|
| 439 | ! |
tDVGVD <- tDVGVD + fg * fg / fg1 * crossprod(WD, Gamma[[g]] %*% WD) |
| 440 |
} # g |
|
| 441 | ||
| 442 | ! |
NVarCov <- (E.inv %*% tDVGVD %*% E.inv) |
| 443 | ||
| 444 |
# to be reused by lavaanTest |
|
| 445 | ! |
attr(NVarCov, "Delta") <- Delta |
| 446 | ! |
attr(NVarCov, "Gamma") <- Gamma |
| 447 | ! |
if ((lavoptions$information[1] == lavoptions$information[2]) && |
| 448 | ! |
(lavoptions$h1.information[1] == lavoptions$h1.information[2]) && |
| 449 | ! |
(lavoptions$information[2] == "expected" || |
| 450 | ! |
lavoptions$observed.information[1] == |
| 451 | ! |
lavoptions$observed.information[2])) {
|
| 452 |
# only when same type of information is used # new in 0.6-6 |
|
| 453 | ! |
attr(NVarCov, "E.inv") <- E.inv |
| 454 | ! |
attr(NVarCov, "WLS.V") <- WLS.V |
| 455 |
} |
|
| 456 | ||
| 457 | ! |
NVarCov |
| 458 |
} |
|
| 459 | ||
| 460 | ||
| 461 | ||
| 462 |
lav_model_vcov <- function(lavmodel = NULL, |
|
| 463 |
lavsamplestats = NULL, |
|
| 464 |
lavoptions = NULL, |
|
| 465 |
lavdata = NULL, |
|
| 466 |
lavpartable = NULL, |
|
| 467 |
lavcache = NULL, |
|
| 468 |
lavimplied = NULL, |
|
| 469 |
lavh1 = NULL, |
|
| 470 |
use.ginv = FALSE) {
|
|
| 471 | 105x |
likelihood <- lavoptions$likelihood |
| 472 |
# information <- lavoptions$information[1] # first one is for vcov |
|
| 473 | 105x |
se <- lavoptions$se |
| 474 |
# mimic <- lavoptions$mimic |
|
| 475 | ||
| 476 |
# special cases |
|
| 477 | 105x |
if (se == "none" || se == "external" || se == "twostep") {
|
| 478 | ! |
return(matrix(0, 0, 0)) |
| 479 |
} |
|
| 480 | ||
| 481 | 105x |
if (se == "standard") {
|
| 482 | 92x |
NVarCov <- lav_model_information( |
| 483 | 92x |
lavmodel = lavmodel, |
| 484 | 92x |
lavsamplestats = lavsamplestats, |
| 485 | 92x |
lavdata = lavdata, |
| 486 | 92x |
lavcache = lavcache, |
| 487 | 92x |
lavimplied = lavimplied, |
| 488 | 92x |
lavh1 = lavh1, |
| 489 | 92x |
lavoptions = lavoptions, |
| 490 | 92x |
extra = FALSE, |
| 491 | 92x |
augmented = TRUE, |
| 492 | 92x |
inverted = TRUE, |
| 493 | 92x |
use.ginv = use.ginv |
| 494 |
) |
|
| 495 | 13x |
} else if (se == "first.order") {
|
| 496 | ! |
NVarCov <- |
| 497 | ! |
lav_model_information_firstorder( |
| 498 | ! |
lavmodel = lavmodel, |
| 499 | ! |
lavsamplestats = lavsamplestats, |
| 500 | ! |
lavdata = lavdata, |
| 501 | ! |
lavcache = lavcache, |
| 502 | ! |
lavimplied = lavimplied, |
| 503 | ! |
lavh1 = lavh1, |
| 504 | ! |
lavoptions = lavoptions, |
| 505 | ! |
extra = TRUE, |
| 506 | ! |
check.pd = FALSE, |
| 507 | ! |
augmented = TRUE, |
| 508 | ! |
inverted = TRUE, |
| 509 | ! |
use.ginv = use.ginv |
| 510 |
) |
|
| 511 | 13x |
} else if (se %in% c("robust.sem", "robust.sem.nt", "robust.cluster.sem")) {
|
| 512 | 4x |
NVarCov <- |
| 513 | 4x |
lav_model_nvcov_robust_sem( |
| 514 | 4x |
lavmodel = lavmodel, |
| 515 | 4x |
lavsamplestats = lavsamplestats, |
| 516 | 4x |
lavcache = lavcache, |
| 517 | 4x |
lavdata = lavdata, |
| 518 | 4x |
lavimplied = lavimplied, |
| 519 | 4x |
lavh1 = lavh1, |
| 520 | 4x |
lavoptions = lavoptions, |
| 521 | 4x |
use.ginv = use.ginv |
| 522 |
) |
|
| 523 | 9x |
} else if (se == "robust.huber.white" || se == "robust.cluster") {
|
| 524 | 8x |
NVarCov <- |
| 525 | 8x |
lav_model_nvcov_robust_sandwich( |
| 526 | 8x |
lavmodel = lavmodel, |
| 527 | 8x |
lavsamplestats = lavsamplestats, |
| 528 | 8x |
lavdata = lavdata, |
| 529 | 8x |
lavcache = lavcache, |
| 530 | 8x |
lavimplied = lavimplied, |
| 531 | 8x |
lavh1 = lavh1, |
| 532 | 8x |
lavoptions = lavoptions, |
| 533 | 8x |
use.ginv = use.ginv |
| 534 |
) |
|
| 535 | 1x |
} else if (se %in% c("two.stage", "robust.two.stage")) {
|
| 536 | ! |
NVarCov <- |
| 537 | ! |
lav_model_nvcov_two_stage( |
| 538 | ! |
lavmodel = lavmodel, |
| 539 | ! |
lavsamplestats = lavsamplestats, |
| 540 | ! |
lavoptions = lavoptions, |
| 541 | ! |
lavdata = lavdata, |
| 542 | ! |
lavimplied = lavimplied, |
| 543 | ! |
lavh1 = lavh1, |
| 544 | ! |
use.ginv = use.ginv |
| 545 |
) |
|
| 546 | 1x |
} else if (se == "bootstrap") {
|
| 547 | 1x |
NVarCov <- try( |
| 548 | 1x |
lav_model_nvcov_bootstrap( |
| 549 | 1x |
lavmodel = lavmodel, |
| 550 | 1x |
lavsamplestats = lavsamplestats, |
| 551 | 1x |
lavoptions = lavoptions, |
| 552 | 1x |
lavdata = lavdata, |
| 553 | 1x |
lavimplied = lavimplied, |
| 554 | 1x |
lavh1 = lavh1, |
| 555 | 1x |
lavcache = lavcache, |
| 556 | 1x |
lavpartable = lavpartable |
| 557 |
), |
|
| 558 | 1x |
silent = TRUE |
| 559 |
) |
|
| 560 |
} else {
|
|
| 561 | ! |
lav_msg_warn(gettextf("unknown se type: %s", se))
|
| 562 |
} |
|
| 563 | ||
| 564 | 105x |
if (!inherits(NVarCov, "try-error")) {
|
| 565 |
# denominator! |
|
| 566 | 104x |
if (lavmodel@estimator %in% c("ML", "PML", "FML") &&
|
| 567 | 104x |
likelihood == "normal") {
|
| 568 | 76x |
if (lavdata@nlevels == 1L) {
|
| 569 | 72x |
N <- lavsamplestats@ntotal |
| 570 |
# new in 0.6-9 (to mimic method="lm" in effectLite) |
|
| 571 |
# special case: univariate regression in each group |
|
| 572 | 72x |
if (lavoptions$mimic == "lm" && |
| 573 | 72x |
all(lavmodel@modprop$uvreg)) {
|
| 574 | ! |
N <- sum(unlist(lavsamplestats@nobs) - |
| 575 | ! |
(unlist(lavmodel@modprop$nexo) + 1L)) |
| 576 |
# always adding the intercept (for now) |
|
| 577 |
} |
|
| 578 |
} else {
|
|
| 579 |
# total number of clusters (over groups) |
|
| 580 | 4x |
N <- 0 |
| 581 | 4x |
for (g in 1:lavsamplestats@ngroups) {
|
| 582 | 8x |
N <- N + lavdata@Lp[[g]]$nclusters[[2]] |
| 583 |
} |
|
| 584 |
} |
|
| 585 |
} else {
|
|
| 586 | 28x |
N <- lavsamplestats@ntotal - lavsamplestats@ngroups |
| 587 |
} |
|
| 588 | ||
| 589 | 104x |
VarCov <- 1 / N * NVarCov |
| 590 | ||
| 591 |
# check if VarCov is pd -- new in 0.6-2 |
|
| 592 |
# mostly important if we have (in)equality constraints (MASS::ginv!) |
|
| 593 | 104x |
if (lavmodel@ceq.simple.only) {
|
| 594 |
# do nothing |
|
| 595 | 104x |
} else if (!is.null(lavoptions$check.vcov) && lavoptions$check.vcov) {
|
| 596 | 44x |
eigvals <- eigen(VarCov, |
| 597 | 44x |
symmetric = TRUE, |
| 598 | 44x |
only.values = TRUE |
| 599 | 44x |
)$values |
| 600 |
# correct for (in)equality constraints |
|
| 601 | 44x |
neq <- 0L |
| 602 | 44x |
niq <- 0L |
| 603 | 44x |
if (nrow(lavmodel@con.jac) > 0L) {
|
| 604 | 16x |
ceq.idx <- attr(lavmodel@con.jac, "ceq.idx") |
| 605 | 16x |
cin.idx <- attr(lavmodel@con.jac, "cin.idx") |
| 606 | 16x |
ina.idx <- attr(lavmodel@con.jac, "inactive.idx") |
| 607 | 16x |
if (length(ceq.idx) > 0L) {
|
| 608 | 14x |
neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank |
| 609 |
} |
|
| 610 | 16x |
if (length(cin.idx) > 0L) {
|
| 611 | 6x |
niq <- length(cin.idx) - length(ina.idx) # only active |
| 612 |
} |
|
| 613 |
# total number of relevant constraints |
|
| 614 | 16x |
neiq <- neq + niq |
| 615 | 16x |
if (neiq > 0L) {
|
| 616 | 16x |
eigvals <- rev(eigvals)[-seq_len(neiq)] |
| 617 |
} |
|
| 618 |
} |
|
| 619 | 44x |
min.val <- min(eigvals) |
| 620 |
# if(any(eigvals < -1 * sqrt(.Machine$double.eps)) && |
|
| 621 | 44x |
if (min.val < .Machine$double.eps^(3 / 4)) {
|
| 622 |
# VarCov.chol <- suppressWarnings(try(chol(VarCov, |
|
| 623 |
# pivot = TRUE), silent = TRUE)) |
|
| 624 |
# VarCov.rank <- attr(VarCov.chol, "rank") |
|
| 625 |
# VarCov.pivot <- attr(VarCov.chol, "pivot") |
|
| 626 |
# VarCov.badidx <- VarCov.pivot[ VarCov.rank + 1L ] |
|
| 627 |
# pt.idx <- which(lavpartable$free == VarCov.badidx) |
|
| 628 |
# par.string <- paste(lavpartable$lhs[pt.idx], |
|
| 629 |
# lavpartable$op[ pt.idx], |
|
| 630 |
# lavpartable$rhs[pt.idx]) |
|
| 631 |
# if(lavdata@ngroups > 1L) {
|
|
| 632 |
# par.string <- paste0(par.string, " in group ", |
|
| 633 |
# lavpartable$group[pt.idx]) |
|
| 634 |
# } |
|
| 635 |
# if(lavdata@nlevels > 1L) {
|
|
| 636 |
# par.string <- paste0(par.string, " in level ", |
|
| 637 |
# lavpartable$level[pt.idx]) |
|
| 638 |
# } |
|
| 639 | ||
| 640 | ! |
if (min.val > 0) {
|
| 641 | ! |
lav_msg_warn( |
| 642 | ! |
gettextf("The variance-covariance matrix of the estimated
|
| 643 | ! |
parameters (vcov) does not appear to be positive |
| 644 | ! |
definite! The smallest eigenvalue (= %e) is close |
| 645 | ! |
to zero. This may be a symptom that the model is |
| 646 | ! |
not identified.", min(min.val))) |
| 647 |
} else {
|
|
| 648 | ! |
lav_msg_warn( |
| 649 | ! |
gettextf("The variance-covariance matrix of the estimated parameters
|
| 650 | ! |
(vcov) does not appear to be positive definite! The smallest |
| 651 | ! |
eigenvalue (= %e) is smaller than zero. This may be a |
| 652 | ! |
symptom that the model is not identified.", |
| 653 | ! |
min(min.val))) |
| 654 |
} |
|
| 655 |
} |
|
| 656 |
} |
|
| 657 |
} else {
|
|
| 658 | 1x |
lav_msg_warn( |
| 659 | 1x |
gettext("Could not compute standard errors! The information matrix
|
| 660 | 1x |
could not be inverted. This may be a symptom that the model |
| 661 | 1x |
is not identified.") |
| 662 |
) |
|
| 663 | 1x |
VarCov <- NULL |
| 664 |
} # could not invert |
|
| 665 | ||
| 666 | 105x |
VarCov |
| 667 |
} |
|
| 668 | ||
| 669 |
lav_model_vcov_se <- function(lavmodel, lavpartable, VCOV = NULL, |
|
| 670 |
BOOT = NULL) {
|
|
| 671 |
# 0. special case |
|
| 672 | 109x |
if (is.null(VCOV)) {
|
| 673 | 5x |
se <- rep(as.numeric(NA), lavmodel@nx.user) |
| 674 | 5x |
se[lavpartable$free == 0L] <- 0.0 |
| 675 | 5x |
return(se) |
| 676 |
} |
|
| 677 | ||
| 678 |
# 1. free parameters only |
|
| 679 | 104x |
x.var <- diag(VCOV) |
| 680 |
# check for negative values (what to do: NA or 0.0?) |
|
| 681 | 104x |
x.var[x.var < 0] <- as.numeric(NA) |
| 682 | 104x |
x.se <- sqrt(x.var) |
| 683 | 104x |
if (lavmodel@ceq.simple.only) {
|
| 684 | ! |
GLIST <- lav_model_x2glist( |
| 685 | ! |
lavmodel = lavmodel, x = x.se, |
| 686 | ! |
type = "unco" |
| 687 |
) |
|
| 688 |
} else {
|
|
| 689 | 104x |
GLIST <- lav_model_x2glist( |
| 690 | 104x |
lavmodel = lavmodel, x = x.se, |
| 691 | 104x |
type = "free" |
| 692 |
) |
|
| 693 |
} |
|
| 694 | ||
| 695 |
# se for full parameter table, but with 0.0 entries for def/ceq/cin |
|
| 696 |
# elements |
|
| 697 | 104x |
se <- lav_model_get_parameters( |
| 698 | 104x |
lavmodel = lavmodel, GLIST = GLIST, |
| 699 | 104x |
type = "user", extra = FALSE |
| 700 |
) |
|
| 701 | ||
| 702 | ||
| 703 |
# 2. fixed parameters -> se = 0.0 |
|
| 704 | 104x |
se[which(lavpartable$free == 0L)] <- 0.0 |
| 705 | ||
| 706 | ||
| 707 |
# 3. defined parameters: |
|
| 708 | 104x |
def.idx <- which(lavpartable$op == ":=") |
| 709 | 104x |
if (length(def.idx) > 0L) {
|
| 710 | 2x |
if (!is.null(BOOT)) {
|
| 711 |
# we must remove the NA rows (and hope we have something left) |
|
| 712 | ! |
error.idx <- attr(BOOT, "error.idx") |
| 713 | ! |
if (length(error.idx) > 0L) {
|
| 714 | ! |
BOOT <- BOOT[-error.idx, , drop = FALSE] # drops attributes |
| 715 |
} |
|
| 716 | ||
| 717 | ! |
BOOT.def <- apply(BOOT, 1L, lavmodel@def.function) |
| 718 | ! |
if (length(def.idx) == 1L) {
|
| 719 | ! |
BOOT.def <- as.matrix(BOOT.def) |
| 720 |
} else {
|
|
| 721 | ! |
BOOT.def <- t(BOOT.def) |
| 722 |
} |
|
| 723 |
# new in 0.6-20: check for outliers, big difference betwen sd() and mad() |
|
| 724 |
# see github issue 347 |
|
| 725 | ! |
sd_mad_ratio <- ( apply(BOOT.def, 2, sd, na.rm = TRUE) / |
| 726 | ! |
apply(BOOT.def, 2, mad, na.rm = TRUE) ) |
| 727 | ! |
crit.ratio <- 5 |
| 728 | ! |
if (any(sd_mad_ratio > crit.ratio)) {
|
| 729 | ! |
NAMES <- colnames(BOOT.def) |
| 730 | ! |
def_w_outliers <- paste(NAMES[sd_mad_ratio > crit.ratio], |
| 731 | ! |
collapse = " ") |
| 732 | ! |
lav_msg_warn(gettextf( |
| 733 | ! |
"The following boostrapped defined parameters have a high (>5) |
| 734 | ! |
ratio of standard deviation to median absolute deviation: %s. |
| 735 | ! |
P-values and confidence intervals may not match.", def_w_outliers)) |
| 736 |
} |
|
| 737 | ! |
nboot <- nrow(BOOT.def) |
| 738 | ! |
def.cov <- cov(BOOT.def) * (nboot - 1) / nboot |
| 739 |
} else {
|
|
| 740 |
# regular delta method |
|
| 741 | 2x |
x <- lav_model_get_parameters(lavmodel = lavmodel, type = "free") |
| 742 | 2x |
JAC <- try(lav_func_jacobian_complex(func = lavmodel@def.function, x = x), |
| 743 | 2x |
silent = TRUE |
| 744 |
) |
|
| 745 | 2x |
if (inherits(JAC, "try-error")) { # eg. pnorm()
|
| 746 | ! |
JAC <- lav_func_jacobian_simple(func = lavmodel@def.function, x = x) |
| 747 |
} |
|
| 748 | 2x |
if (lavmodel@ceq.simple.only) {
|
| 749 | ! |
JAC <- JAC %*% t(lavmodel@ceq.simple.K) |
| 750 |
} |
|
| 751 | 2x |
def.cov <- JAC %*% VCOV %*% t(JAC) |
| 752 |
} |
|
| 753 |
# check for negative se's |
|
| 754 | 2x |
diag.def.cov <- diag(def.cov) |
| 755 | 2x |
diag.def.cov[diag.def.cov < 0] <- as.numeric(NA) |
| 756 | 2x |
se[def.idx] <- sqrt(diag.def.cov) |
| 757 |
} |
|
| 758 | ||
| 759 | 104x |
se |
| 760 |
} |
| 1 |
# numerical derivatives using complex numbers |
|
| 2 |
# see Squire & Trapp 1998, siam rev 40(1) 110-112 |
|
| 3 |
# or Ridout, MS (2009), the american statistician 63(1) 66-74 |
|
| 4 | ||
| 5 |
# it would seem that you can choose h to be fairly small, without |
|
| 6 |
# sacrifycing accuracy due to rounding errors |
|
| 7 | ||
| 8 |
# YR 17 July 2012 |
|
| 9 | ||
| 10 |
lav_func_gradient_complex <- function(func, x, |
|
| 11 |
h = .Machine$double.eps, ..., |
|
| 12 |
fallback.simple = TRUE) {
|
|
| 13 | ! |
f0 <- try(func(x * (0 + 1i), ...), silent = TRUE) |
| 14 | ! |
if (!is.complex(f0)) {
|
| 15 | ! |
if (fallback.simple) {
|
| 16 | ! |
dx <- lav_func_gradient_simple(func = func, x = x, h = sqrt(h), ...) |
| 17 | ! |
return(dx) |
| 18 |
} else {
|
|
| 19 | ! |
lav_msg_stop(gettext( |
| 20 | ! |
"function does not return a complex value")) # eg abs() |
| 21 |
} |
|
| 22 |
} |
|
| 23 | ! |
if (inherits(f0, "try-error")) {
|
| 24 | ! |
if (fallback.simple) {
|
| 25 | ! |
dx <- lav_func_gradient_simple(func = func, x = x, h = sqrt(h), ...) |
| 26 | ! |
return(dx) |
| 27 |
} else {
|
|
| 28 | ! |
lav_msg_stop(gettext( |
| 29 | ! |
"function does not support non-numeric (complex) argument")) |
| 30 |
} |
|
| 31 |
} |
|
| 32 | ! |
if (length(f0) != 1L) {
|
| 33 | ! |
lav_msg_stop(gettext( |
| 34 | ! |
"function is not scalar and returns more than one element")) |
| 35 |
} |
|
| 36 | ||
| 37 | ! |
nvar <- length(x) |
| 38 | ||
| 39 |
# determine 'h' per element of x |
|
| 40 | ! |
h <- pmax(h, abs(h * x)) |
| 41 | ||
| 42 |
# get exact h, per x |
|
| 43 | ! |
tmp <- x + h |
| 44 | ! |
h <- (tmp - x) |
| 45 | ||
| 46 |
# simple 'forward' method |
|
| 47 | ! |
dx <- rep(as.numeric(NA), nvar) |
| 48 | ! |
for (p in seq_len(nvar)) {
|
| 49 | ! |
dx[p] <- Im(func(x + h * 1i * (seq.int(nvar) == p), ...)) / h[p] |
| 50 |
} |
|
| 51 | ||
| 52 | ! |
dx |
| 53 |
} |
|
| 54 | ||
| 55 |
# as a backup, if func() is not happy about non-numeric arguments |
|
| 56 |
lav_func_gradient_simple <- function(func, x, |
|
| 57 |
h = sqrt(.Machine$double.eps), ...) {
|
|
| 58 |
# check current point, see if it is a scalar function |
|
| 59 | ! |
f0 <- func(x, ...) |
| 60 | ! |
if (length(f0) != 1L) {
|
| 61 | ! |
lav_msg_stop(gettext( |
| 62 | ! |
"function is not scalar and returns more than one element")) |
| 63 |
} |
|
| 64 | ||
| 65 | ! |
nvar <- length(x) |
| 66 | ||
| 67 |
# determine 'h' per element of x |
|
| 68 | ! |
h <- pmax(h, abs(h * x)) |
| 69 | ||
| 70 |
# get exact h, per x |
|
| 71 | ! |
tmp <- x + h |
| 72 | ! |
h <- (tmp - x) |
| 73 | ||
| 74 |
# simple 'forward' method |
|
| 75 | ! |
dx <- rep(as.numeric(NA), nvar) |
| 76 | ! |
for (p in seq_len(nvar)) {
|
| 77 | ! |
dx[p] <- (func(x + h * (seq.int(nvar) == p), ...) - func(x, ...)) / h[p] |
| 78 |
} |
|
| 79 | ||
| 80 | ! |
dx |
| 81 |
} |
|
| 82 | ||
| 83 |
lav_func_jacobian_complex <- function(func, x, |
|
| 84 |
h = .Machine$double.eps, ..., |
|
| 85 |
fallback.simple = TRUE) {
|
|
| 86 | 506x |
f0 <- try(func(x * (0 + 1i), ...), silent = TRUE) |
| 87 | 506x |
if (!is.complex(f0)) {
|
| 88 | 29x |
if (fallback.simple) {
|
| 89 | 29x |
dx <- lav_func_jacobian_simple(func = func, x = x, h = sqrt(h), ...) |
| 90 | 29x |
return(dx) |
| 91 |
} else {
|
|
| 92 | ! |
lav_msg_stop(gettext( |
| 93 | ! |
"function does not return a complex value")) # eg abs() |
| 94 |
} |
|
| 95 |
} |
|
| 96 | 477x |
if (inherits(f0, "try-error")) {
|
| 97 | ! |
if (fallback.simple) {
|
| 98 | ! |
dx <- lav_func_jacobian_simple(func = func, x = x, h = sqrt(h), ...) |
| 99 | ! |
return(dx) |
| 100 |
} else {
|
|
| 101 | ! |
lav_msg_stop(gettext( |
| 102 | ! |
"function does not support non-numeric (complex) argument")) |
| 103 |
} |
|
| 104 |
} |
|
| 105 | 477x |
nres <- length(f0) |
| 106 | 477x |
nvar <- length(x) |
| 107 | ||
| 108 |
# determine 'h' per element of x |
|
| 109 | 477x |
h <- pmax(h, abs(h * x)) |
| 110 | ||
| 111 |
# get exact h, per x |
|
| 112 | 477x |
tmp <- x + h |
| 113 | 477x |
h <- (tmp - x) |
| 114 | ||
| 115 |
# simple 'forward' method |
|
| 116 | 477x |
dx <- matrix(as.numeric(NA), nres, nvar) |
| 117 | 477x |
for (p in seq_len(nvar)) {
|
| 118 | 7279x |
dx[, p] <- Im(func(x + h * 1i * (seq.int(nvar) == p), ...)) / h[p] |
| 119 |
} |
|
| 120 | ||
| 121 | 477x |
dx |
| 122 |
} |
|
| 123 | ||
| 124 |
lav_func_jacobian_simple <- function(func, x, |
|
| 125 |
h = sqrt(.Machine$double.eps), ...) {
|
|
| 126 | 29x |
f0 <- func(x, ...) |
| 127 | 29x |
nres <- length(f0) |
| 128 | 29x |
nvar <- length(x) |
| 129 | ||
| 130 |
# determine 'h' per element of x |
|
| 131 | 29x |
h <- pmax(h, abs(h * x)) |
| 132 | ||
| 133 |
# get exact h, per x |
|
| 134 | 29x |
tmp <- x + h |
| 135 | 29x |
h <- (tmp - x) |
| 136 | ||
| 137 |
# simple 'forward' method |
|
| 138 | 29x |
dx <- matrix(as.numeric(NA), nres, nvar) |
| 139 | 29x |
for (p in seq_len(nvar)) {
|
| 140 | 872x |
dx[, p] <- (func(x + h * (seq.int(nvar) == p), ...) - func(x, ...)) / h[p] |
| 141 |
} |
|
| 142 | ||
| 143 | 29x |
dx |
| 144 |
} |
|
| 145 | ||
| 146 |
# this is based on the Ridout (2009) paper, and the code snippet for 'h4' |
|
| 147 |
lav_func_hessian_complex <- function(func, x, |
|
| 148 |
h = .Machine$double.eps, ...) {
|
|
| 149 | ! |
f0 <- try(func(x * (0 + 1i), ...), silent = TRUE) |
| 150 | ! |
if (!is.complex(f0)) {
|
| 151 | ! |
lav_msg_stop(gettext( |
| 152 | ! |
"function does not return a complex value")) # eg abs() |
| 153 |
} |
|
| 154 | ! |
if (inherits(f0, "try-error")) {
|
| 155 | ! |
lav_msg_stop(gettext( |
| 156 | ! |
"function does not support non-numeric (complex) argument")) |
| 157 |
} |
|
| 158 | ! |
if (length(f0) != 1L) {
|
| 159 | ! |
lav_msg_stop(gettext( |
| 160 | ! |
"function is not scalar and returns more than one element")) |
| 161 |
} |
|
| 162 | ||
| 163 | ! |
nvar <- length(x) |
| 164 | ||
| 165 |
# determine 'h' per element of x |
|
| 166 |
# delta1 <- pmax(h^(1/3), abs(h^(1/3)*x)) |
|
| 167 |
# delta2 <- pmax(h^(1/5), abs(h^(1/5)*x)) |
|
| 168 | ! |
delta1 <- h^(1 / 3) |
| 169 | ! |
delta2 <- h^(1 / 5) |
| 170 | ||
| 171 | ! |
H <- matrix(as.numeric(NA), nvar, nvar) |
| 172 | ! |
for (i in seq_len(nvar)) {
|
| 173 | ! |
for (j in 1:i) {
|
| 174 | ! |
if (i == j) {
|
| 175 | ! |
delta <- delta2 |
| 176 |
} else {
|
|
| 177 | ! |
delta <- delta1 |
| 178 |
} |
|
| 179 | ! |
H[i, j] <- H[j, i] <- |
| 180 | ! |
Im(func(x + delta * 1i * (seq.int(nvar) == i) * x + |
| 181 | ! |
delta * (seq.int(nvar) == j) * x, ...) - |
| 182 | ! |
func(x + delta * 1i * (seq.int(nvar) == i) * x - |
| 183 | ! |
delta * (seq.int(nvar) == j) * x, ...)) / |
| 184 | ! |
(2 * delta * delta * x[i] * x[j]) |
| 185 |
} |
|
| 186 |
} |
|
| 187 | ||
| 188 | ! |
H |
| 189 |
} |
|
| 190 | ||
| 191 |
lav_deriv_cov2corB <- function(COV = NULL) {
|
|
| 192 | ! |
nvar <- nrow(COV) |
| 193 | ! |
dS.inv <- 1 / diag(COV) |
| 194 | ! |
R <- cov2cor(COV) |
| 195 | ! |
A <- -R %x% (0.5 * diag(dS.inv)) |
| 196 | ! |
B <- (0.5 * diag(dS.inv)) %x% -R |
| 197 | ! |
DD <- diag(lav_matrix_vec(diag(nvar))) |
| 198 | ! |
A2 <- A %*% DD |
| 199 | ! |
B2 <- B %*% DD |
| 200 | ! |
out <- A2 + B2 + diag(lav_matrix_vec(tcrossprod(sqrt(dS.inv)))) |
| 201 | ! |
D <- lav_matrix_duplication(nvar) |
| 202 | ! |
out.vech <- 0.5 * (t(D) %*% out %*% D) |
| 203 | ! |
out.vech |
| 204 |
} |
|
| 205 | ||
| 206 |
# quick and dirty (FIXME!!!) way to get |
|
| 207 |
# surely there must be a more elegant way? |
|
| 208 |
# see lav_deriv_cov2corB, if no num.idx... |
|
| 209 |
# dCor/dCov |
|
| 210 |
lav_deriv_cov2cor <- function(COV = NULL, num.idx = NULL) {
|
|
| 211 |
# dCor/dvar1 = - cov / (2*var1 * sqrt(var1) * sqrt(var2)) |
|
| 212 |
# dCor/dvar2 = - cov / (2*var2 * sqrt(var1) * sqrt(var2)) |
|
| 213 |
# dCor/dcov = 1/(sqrt(var1) * sqrt(var2)) |
|
| 214 | ||
| 215 |
# diagonal: diag(lav_matrix_vech(tcrossprod(1/delta))) |
|
| 216 | ||
| 217 | ! |
nvar <- ncol(COV) |
| 218 | ! |
pstar <- nvar * (nvar + 1) / 2 |
| 219 | ! |
delta <- sqrt(diag(COV)) |
| 220 | ! |
if (length(num.idx) > 0L) {
|
| 221 | ! |
delta[num.idx] <- 1.0 |
| 222 |
} |
|
| 223 | ||
| 224 | ! |
A <- COV * -1 / (2 * delta * delta * tcrossprod(delta)) |
| 225 | ! |
if (length(num.idx) > 0L) {
|
| 226 | ! |
A[num.idx, ] <- 0 |
| 227 | ! |
A[cbind(num.idx, num.idx)] <- 1 |
| 228 |
} |
|
| 229 | ! |
A2 <- diag(nvar) %x% t(A) |
| 230 | ||
| 231 | ! |
OUT <- diag(pstar) |
| 232 | ! |
diag(OUT) <- lav_matrix_vech(tcrossprod(1 / delta)) |
| 233 | ! |
var.idx <- lav_matrix_diagh_idx(nvar) |
| 234 | ! |
DUP <- lav_matrix_duplication(nvar) |
| 235 | ! |
OUT[, var.idx] <- t(DUP) %*% A2[, lav_matrix_diag_idx(nvar)] |
| 236 | ||
| 237 | ! |
if (length(num.idx) > 0L) {
|
| 238 | ! |
var.idx <- var.idx[-num.idx] |
| 239 |
} |
|
| 240 | ! |
OUT[var.idx, var.idx] <- 0 |
| 241 | ||
| 242 | ! |
OUT |
| 243 |
} |
|
| 244 | ||
| 245 | ||
| 246 |
lav_deriv_cov2cor_numerical <- function(COV, num.idx = integer(0)) {
|
|
| 247 | ! |
compute.R <- function(x) {
|
| 248 | ! |
S <- lav_matrix_vech_reverse(x) |
| 249 | ! |
diagS <- diag(S) |
| 250 | ! |
delta <- 1 / sqrt(diagS) |
| 251 | ! |
if (length(num.idx) > 0L) {
|
| 252 | ! |
delta[num.idx] <- 1.0 |
| 253 |
} |
|
| 254 | ! |
R <- diag(delta) %*% S %*% diag(delta) |
| 255 |
# R <- cov2cor(S) |
|
| 256 | ! |
R.vec <- lav_matrix_vech(R, diagonal = TRUE) |
| 257 | ! |
R.vec |
| 258 |
} |
|
| 259 | ||
| 260 | ! |
x <- lav_matrix_vech(COV, diagonal = TRUE) |
| 261 | ! |
dx <- lav_func_jacobian_complex(func = compute.R, x = x) |
| 262 | ||
| 263 | ! |
dx |
| 264 |
} |
| 1 |
# create random starting values starting from a parameter table |
|
| 2 |
# - using the lower/upper bounds and runif() for factor loadings |
|
| 3 |
# and variances |
|
| 4 |
# - using runif(,-1,+1) for correlations; rescale using variances |
|
| 5 |
# - check if Sigma.hat is PD; if not, try again |
|
| 6 |
# |
|
| 7 |
# YR 26 Feb 2024 |
|
| 8 | ||
| 9 |
lav_partable_random <- function(lavpartable = NULL, |
|
| 10 |
# needed if we still need to compute bounds: |
|
| 11 |
lavh1 = NULL, lavdata = NULL, |
|
| 12 |
lavsamplestats = NULL, lavoptions = NULL) {
|
|
| 13 | ||
| 14 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 15 | ||
| 16 |
# ALWAYS (recompute) bounds, as user may have provide other |
|
| 17 |
# bounds (eg "pos.var") (0.6-20) |
|
| 18 | ! |
lavoptions2 <- lavoptions |
| 19 | ! |
lavoptions2$bounds <- "standard" |
| 20 | ! |
lavoptions2$optim.bounds <- |
| 21 | ! |
list( |
| 22 | ! |
lower = c( |
| 23 | ! |
"ov.var", "lv.var", "loadings", |
| 24 | ! |
"covariances" |
| 25 |
), |
|
| 26 | ! |
upper = c( |
| 27 | ! |
"ov.var", "lv.var", "loadings", |
| 28 | ! |
"covariances" |
| 29 |
), |
|
| 30 | ! |
lower.factor = c(1.0, 1.0, 1.0, 0.999), |
| 31 | ! |
upper.factor = c(1.0, 1.0, 1.0, 0.999), |
| 32 | ! |
min.reliability.marker = 0.1, |
| 33 | ! |
min.var.lv.endo = 0.005 |
| 34 |
) |
|
| 35 | ! |
lavpartable <- lav_partable_add_bounds( |
| 36 | ! |
partable = lavpartable, |
| 37 | ! |
lavh1 = lavh1, lavdata = lavdata, |
| 38 | ! |
lavsamplestats = lavsamplestats, lavoptions = lavoptions2 |
| 39 |
) |
|
| 40 | ||
| 41 |
# replace -Inf/Inf by -1/1 * .Machine$double.eps (for runif) |
|
| 42 | ! |
inf.idx <- which(lavpartable$lower < -1e+16) |
| 43 | ! |
if (length(inf.idx) > 0L) {
|
| 44 | ! |
lavpartable$lower[inf.idx] <- -1e+16 |
| 45 |
} |
|
| 46 | ! |
inf.idx <- which(lavpartable$upper > 1e+16) |
| 47 | ! |
if (length(inf.idx) > 0L) {
|
| 48 | ! |
lavpartable$upper[inf.idx] <- 1e+16 |
| 49 |
} |
|
| 50 | ||
| 51 |
# empty lavpartable$start? |
|
| 52 | ! |
if (is.null(lavpartable$start)) {
|
| 53 | ! |
START <- numeric(length(lavpartable$lhs)) |
| 54 |
# set loadings to 0.7 |
|
| 55 | ! |
loadings.idx <- which(lavpartable$free > 0L & |
| 56 | ! |
lavpartable$op == "=~") |
| 57 | ! |
if (length(loadings.idx) > 0L) {
|
| 58 | ! |
START[loadings.idx] <- 0.7 |
| 59 |
} |
|
| 60 |
# set (only) variances to 1 |
|
| 61 | ! |
var.idx <- which(lavpartable$free > 0L & |
| 62 | ! |
lavpartable$op == "~~" & |
| 63 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 64 | ! |
if (length(var.idx) > 0L) {
|
| 65 | ! |
START[var.idx] <- 1 |
| 66 |
} |
|
| 67 | ||
| 68 | ! |
lavpartable$start <- START |
| 69 |
} |
|
| 70 | ||
| 71 |
# initial values |
|
| 72 | ! |
START <- lavpartable$start |
| 73 | ||
| 74 | ! |
nblocks <- lav_partable_nblocks(lavpartable) |
| 75 | ! |
block.values <- lav_partable_block_values(lavpartable) |
| 76 | ! |
for (b in 1:nblocks) {
|
| 77 | ! |
ov.names <- lavpta$vnames$ov[[b]] |
| 78 | ! |
lv.names <- lavpta$vnames$lv[[b]] |
| 79 | ! |
ov.ind.names <- lavpta$vnames$ov.ind[[b]] |
| 80 | ||
| 81 |
# start with the lv (residual) variances |
|
| 82 | ! |
lv.var.idx <- which(lavpartable$block == block.values[b] & |
| 83 | ! |
lavpartable$op == "~~" & |
| 84 | ! |
lavpartable$lhs %in% lv.names & |
| 85 | ! |
lavpartable$rhs %in% lv.names & |
| 86 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 87 | ||
| 88 | ! |
if (length(lv.var.idx) > 0L) {
|
| 89 | ! |
for (i in lv.var.idx) {
|
| 90 | ! |
if (lavpartable$free[i] > 0L && |
| 91 | ! |
(lavpartable$lower[i] < lavpartable$upper[i])) {
|
| 92 | ! |
START[i] <- runif( |
| 93 | ! |
n = 1L, min = lavpartable$lower[i], |
| 94 | ! |
max = lavpartable$upper[i] |
| 95 |
) |
|
| 96 |
} |
|
| 97 |
} |
|
| 98 |
} |
|
| 99 | ||
| 100 |
# first, we generate lv correlations, and then rescale to covariances |
|
| 101 | ! |
lv.cov.idx <- which(lavpartable$block == block.values[b] & |
| 102 | ! |
lavpartable$op == "~~" & |
| 103 | ! |
lavpartable$lhs %in% lv.names & |
| 104 | ! |
lavpartable$rhs %in% lv.names & |
| 105 | ! |
lavpartable$lhs != lavpartable$rhs) |
| 106 | ||
| 107 | ! |
if (length(lv.cov.idx) > 0L) {
|
| 108 | ! |
for (i in lv.cov.idx) {
|
| 109 | ! |
if (lavpartable$free[i] > 0L && |
| 110 | ! |
(lavpartable$lower[i] < lavpartable$upper[i])) {
|
| 111 | ! |
cor.val <- runif(n = 1L, -0.5, +0.5) |
| 112 | ! |
var1.idx <- which(lavpartable$block == block.values[b] & |
| 113 | ! |
lavpartable$op == "~~" & |
| 114 | ! |
lavpartable$lhs == lavpartable$lhs[i] & |
| 115 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 116 | ! |
var2.idx <- which(lavpartable$block == block.values[b] & |
| 117 | ! |
lavpartable$op == "~~" & |
| 118 | ! |
lavpartable$lhs == lavpartable$rhs[i] & |
| 119 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 120 | ! |
START[i] <- cor.val * sqrt(START[var1.idx]) * sqrt(START[var2.idx]) |
| 121 |
} |
|
| 122 |
} |
|
| 123 |
} |
|
| 124 | ||
| 125 |
# next, (residual) ov variances |
|
| 126 | ! |
ov.var.idx <- which(lavpartable$block == block.values[b] & |
| 127 | ! |
lavpartable$op == "~~" & |
| 128 | ! |
lavpartable$lhs %in% ov.names & |
| 129 | ! |
lavpartable$rhs %in% ov.names & |
| 130 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 131 | ||
| 132 | ! |
if (length(ov.var.idx) > 0L) {
|
| 133 | ! |
for (i in ov.var.idx) {
|
| 134 | ! |
if (lavpartable$free[i] > 0L && |
| 135 | ! |
(lavpartable$lower[i] < lavpartable$upper[i])) {
|
| 136 | ! |
START[i] <- runif( |
| 137 | ! |
n = 1L, min = lavpartable$lower[i], |
| 138 | ! |
max = lavpartable$upper[i] |
| 139 |
) |
|
| 140 |
} |
|
| 141 |
} |
|
| 142 |
} |
|
| 143 | ||
| 144 |
# (residual) ov covariances (if any) |
|
| 145 | ! |
ov.cov.idx <- which(lavpartable$block == block.values[b] & |
| 146 | ! |
lavpartable$op == "~~" & |
| 147 | ! |
lavpartable$lhs %in% ov.names & |
| 148 | ! |
lavpartable$rhs %in% ov.names & |
| 149 | ! |
lavpartable$lhs != lavpartable$rhs) |
| 150 | ||
| 151 | ! |
if (length(ov.cov.idx) > 0L) {
|
| 152 | ! |
for (i in ov.cov.idx) {
|
| 153 | ! |
if (lavpartable$free[i] > 0L && |
| 154 | ! |
(lavpartable$lower[i] < lavpartable$upper[i])) {
|
| 155 | ! |
cor.val <- runif(n = 1L, -0.5, +0.5) |
| 156 | ! |
var1.idx <- which(lavpartable$block == block.values[b] & |
| 157 | ! |
lavpartable$op == "~~" & |
| 158 | ! |
lavpartable$lhs == lavpartable$lhs[i] & |
| 159 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 160 | ! |
var2.idx <- which(lavpartable$block == block.values[b] & |
| 161 | ! |
lavpartable$op == "~~" & |
| 162 | ! |
lavpartable$lhs == lavpartable$rhs[i] & |
| 163 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 164 | ! |
START[i] <- cor.val * sqrt(START[var1.idx]) * sqrt(START[var2.idx]) |
| 165 |
} |
|
| 166 |
} |
|
| 167 |
} |
|
| 168 | ||
| 169 |
# finally, the lambda values, keeping in mind that |
|
| 170 |
# lambda_p^(u) = sqrt( upper(res.var.indicators_p) / |
|
| 171 |
# lower(var.factor) ) |
|
| 172 | ! |
lambda.idx <- which(lavpartable$block == block.values[b] & |
| 173 | ! |
lavpartable$op == "=~" & |
| 174 | ! |
lavpartable$lhs %in% lv.names & |
| 175 | ! |
lavpartable$rhs %in% ov.ind.names) |
| 176 | ||
| 177 | ! |
if (length(lambda.idx)) {
|
| 178 | ! |
for (i in lambda.idx) {
|
| 179 | ! |
if (lavpartable$free[i] > 0L && |
| 180 | ! |
(lavpartable$lower[i] < lavpartable$upper[i])) {
|
| 181 | ! |
varov.idx <- which(lavpartable$block == block.values[b] & |
| 182 | ! |
lavpartable$op == "~~" & |
| 183 | ! |
lavpartable$lhs == lavpartable$rhs[i] & |
| 184 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 185 | ! |
varlv.idx <- which(lavpartable$block == block.values[b] & |
| 186 | ! |
lavpartable$op == "~~" & |
| 187 | ! |
lavpartable$lhs == lavpartable$lhs[i] & |
| 188 | ! |
lavpartable$lhs == lavpartable$rhs) |
| 189 | ! |
lambda.u <- sqrt(START[varov.idx] / START[varlv.idx]) |
| 190 | ! |
START[i] <- runif(n = 1, -lambda.u, lambda.u) |
| 191 |
} |
|
| 192 |
} |
|
| 193 |
} |
|
| 194 |
} |
|
| 195 | ||
| 196 |
# sanity check; needed? |
|
| 197 | ! |
current.warn <- lav_warn() |
| 198 | ! |
if (lav_warn(TRUE)) |
| 199 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 200 | ! |
START <- lav_start_check_cov( |
| 201 | ! |
lavpartable = lavpartable, start = START |
| 202 |
) |
|
| 203 | ||
| 204 | ! |
START |
| 205 |
} |
| 1 |
# compute the jacobian: dtheta_2/dtheta_1: |
|
| 2 |
# |
|
| 3 |
# theta_2: - in the rows |
|
| 4 |
# - the croon corrections, expressed as |
|
| 5 |
# 1) scaled offsets (scoffset), and |
|
| 6 |
# 2) scaling factors |
|
| 7 |
# theta_1: - in the columns |
|
| 8 |
# - the free parameters of the measurement model |
|
| 9 |
# |
|
| 10 |
lav_fsr_delta21 <- function(object, FSM = NULL) {
|
|
| 11 | ! |
lavmodel <- object@Model |
| 12 | ! |
nmat <- lavmodel@nmat |
| 13 | ||
| 14 | ! |
NCOL <- lavmodel@nx.free |
| 15 | ! |
m.el.idx <- x.el.idx <- vector("list", length = length(lavmodel@GLIST))
|
| 16 | ! |
for (mm in seq_len(length(lavmodel@GLIST))) {
|
| 17 | ! |
m.el.idx[[mm]] <- lavmodel@m.free.idx[[mm]] |
| 18 | ! |
x.el.idx[[mm]] <- lavmodel@x.free.idx[[mm]] |
| 19 |
# handle symmetric matrices |
|
| 20 | ! |
if (lavmodel@isSymmetric[mm]) {
|
| 21 |
# since we use 'x.free.idx', only symmetric elements |
|
| 22 |
# are duplicated (not the equal ones, only in x.free.free) |
|
| 23 | ! |
dix <- duplicated(x.el.idx[[mm]]) |
| 24 | ! |
if (any(dix)) {
|
| 25 | ! |
m.el.idx[[mm]] <- m.el.idx[[mm]][!dix] |
| 26 | ! |
x.el.idx[[mm]] <- x.el.idx[[mm]][!dix] |
| 27 |
} |
|
| 28 |
} |
|
| 29 |
} |
|
| 30 | ||
| 31 |
# Delta per group (or block?) |
|
| 32 | ! |
Delta <- vector("list", length = lavmodel@ngroups)
|
| 33 | ||
| 34 | ! |
for (g in 1:lavmodel@ngroups) {
|
| 35 | ! |
fsm <- FSM[[g]] |
| 36 | ||
| 37 |
# which mm belong to group g? |
|
| 38 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 39 | ! |
MLIST <- lavmodel@GLIST[mm.in.group] |
| 40 | ||
| 41 | ! |
nrow.scoffset <- ncol(MLIST$lambda) |
| 42 | ! |
nrow.scale <- ncol(MLIST$lambda) |
| 43 | ! |
NROW <- nrow.scoffset + nrow.scale |
| 44 | ! |
Delta.group <- matrix(0, nrow = NROW, ncol = NCOL) |
| 45 | ||
| 46 |
# prepare some computations |
|
| 47 | ! |
AL.inv <- solve(fsm %*% MLIST$lambda) |
| 48 | ! |
ATA <- fsm %*% MLIST$theta %*% t(fsm) |
| 49 | ||
| 50 | ! |
for (mm in mm.in.group) {
|
| 51 | ! |
mname <- names(lavmodel@GLIST)[mm] |
| 52 | ||
| 53 |
# skip empty ones |
|
| 54 | ! |
if (!length(m.el.idx[[mm]])) next |
| 55 | ||
| 56 | ! |
if (mname == "lambda") {
|
| 57 | ! |
dL <- (-1 * (ATA %*% AL.inv + AL.inv %*% ATA) %*% |
| 58 | ! |
(AL.inv %x% AL.inv) %*% fsm) |
| 59 | ||
| 60 | ! |
delta.scoffset <- dL |
| 61 | ! |
delta.scale <- fsm ## only ok for 1 row!!! |
| 62 | ! |
delta <- rbind(delta.scoffset, delta.scale) |
| 63 | ||
| 64 | ! |
Delta.group[, x.el.idx[[mm]]] <- delta[, m.el.idx[[mm]]] |
| 65 | ! |
} else if (mname == "theta") {
|
| 66 | ! |
dT <- lav_matrix_vec((t(AL.inv) %*% fsm) %x% |
| 67 | ! |
(t(fsm) %*% AL.inv)) |
| 68 | ! |
delta.scoffset <- dT |
| 69 | ! |
delta.scale <- matrix(0, |
| 70 | ! |
nrow = nrow.scale, |
| 71 | ! |
ncol = length(MLIST$theta) |
| 72 |
) |
|
| 73 | ! |
delta <- rbind(delta.scoffset, delta.scale) |
| 74 | ||
| 75 | ! |
Delta.group[, x.el.idx[[mm]]] <- delta[, m.el.idx[[mm]]] |
| 76 | ! |
} else if (mname %in% c("psi", "nu", "alpha")) {
|
| 77 |
# zero |
|
| 78 | ! |
next |
| 79 |
} else {
|
|
| 80 | ! |
lav_msg_stop(gettextf( |
| 81 | ! |
"model matrix %s is not lambda/theta/psi", mname)) |
| 82 |
} |
|
| 83 |
} # mm |
|
| 84 | ||
| 85 | ! |
Delta[[g]] <- Delta.group |
| 86 |
} # g |
|
| 87 | ||
| 88 | ! |
Delta |
| 89 |
} |
|
| 90 | ||
| 91 |
lav_fsr_pa2si <- function(PT = NULL, LVINFO) {
|
|
| 92 | ! |
PT.orig <- PT |
| 93 | ||
| 94 |
# remove se column (if any) |
|
| 95 | ! |
if (!is.null(PT$se)) {
|
| 96 | ! |
PT$se <- NULL |
| 97 |
} |
|
| 98 | ||
| 99 |
# ngroups |
|
| 100 | ! |
ngroups <- lav_partable_ngroups(PT) |
| 101 | ||
| 102 | ! |
lhs <- rhs <- op <- character(0) |
| 103 | ! |
group <- block <- level <- free <- exo <- integer(0) |
| 104 | ! |
ustart <- est <- start <- numeric(0) |
| 105 | ||
| 106 | ! |
for (g in seq_len(ngroups)) {
|
| 107 | ! |
nMM <- length(LVINFO[[g]]) |
| 108 | ! |
for (mm in seq_len(nMM)) {
|
| 109 | ! |
lvinfo <- LVINFO[[g]][[mm]] |
| 110 | ! |
lv.names <- lvinfo$lv.names |
| 111 | ||
| 112 | ! |
nfac <- length(lv.names) |
| 113 | ! |
if (nfac > 1L) {
|
| 114 | ! |
lav_msg_stop(gettext("more than 1 factor in measurement block"))
|
| 115 |
} |
|
| 116 | ||
| 117 | ! |
LV <- lv.names |
| 118 | ! |
ind <- paste(LV, ".si", sep = "") |
| 119 | ! |
scoffset <- lvinfo$scoffset[1, 1] |
| 120 | ! |
scale <- lvinfo$scale[1, 1] |
| 121 | ||
| 122 | ! |
lhs <- c(lhs, LV, ind, ind, ind) |
| 123 | ! |
op <- c(op, "=~", "~~", "~*~", "~1") |
| 124 | ! |
rhs <- c(rhs, ind, ind, ind, "") |
| 125 | ! |
block <- c(block, rep(g, 4L)) |
| 126 | ! |
free <- c(free, 0L, 1L, 1L, 0L) |
| 127 | ! |
ustart <- c(ustart, 1, scoffset, scale, 0) |
| 128 | ! |
exo <- c(exo, rep(0L, 4L)) |
| 129 | ! |
group <- c(group, rep(g, 4L)) |
| 130 | ! |
start <- c(start, 1, scoffset, scale, 0) |
| 131 | ! |
est <- c(est, 1, scoffset, scale, 0) |
| 132 |
} |
|
| 133 |
} |
|
| 134 | ||
| 135 |
# ree counter |
|
| 136 | ! |
idx.free <- which(free > 0) |
| 137 | ! |
free[idx.free] <- max(PT$free) + 1:length(idx.free) |
| 138 | ||
| 139 | ! |
LIST <- list( |
| 140 | ! |
id = max(PT$id) + 1:length(lhs), |
| 141 | ! |
lhs = lhs, |
| 142 | ! |
op = op, |
| 143 | ! |
rhs = rhs, |
| 144 | ! |
user = rep(10L, length(lhs)), |
| 145 | ! |
block = block, |
| 146 | ! |
group = group, |
| 147 | ! |
level = rep(1L, length(lhs)), |
| 148 | ! |
free = free, |
| 149 | ! |
ustart = ustart, |
| 150 | ! |
exo = exo, |
| 151 | ! |
start = start, |
| 152 | ! |
est = est |
| 153 |
) |
|
| 154 | ||
| 155 | ! |
PT.si <- lav_partable_merge(PT, LIST) |
| 156 | ||
| 157 | ! |
PT.si |
| 158 |
} |
| 1 |
# loglikelihood clustered/twolevel data -- conditional.x = TRUE |
|
| 2 | ||
| 3 |
# YR: first version around Sept 2021 |
|
| 4 | ||
| 5 |
# take model-implied mean+variance matrices, and reorder/augment them |
|
| 6 |
# to facilitate computing of (log)likelihood in the two-level case |
|
| 7 | ||
| 8 |
# when conditional.x = TRUE: |
|
| 9 |
# - sigma.w and sigma.b: same dimensions, level-1 'Y' variables only |
|
| 10 |
# - sigma.zz: level-2 variables only |
|
| 11 |
# - sigma.yz: cov(level-1, level-2) |
|
| 12 |
# - beta.w: beta y within part |
|
| 13 |
# - beta.b: beta y between part |
|
| 14 |
# - beta.z: beta z (between-only) |
|
| 15 |
lav_mvreg_cluster_implied22l <- function(Lp = NULL, |
|
| 16 |
implied = NULL, |
|
| 17 |
Res.Int.W = NULL, |
|
| 18 |
Res.Int.B = NULL, |
|
| 19 |
Res.Pi.W = NULL, |
|
| 20 |
Res.Pi.B = NULL, |
|
| 21 |
Res.Sigma.W = NULL, |
|
| 22 |
Res.Sigma.B = NULL) {
|
|
| 23 | ! |
if (!is.null(implied)) {
|
| 24 |
# FIXME: only for single-group analysis! |
|
| 25 | ! |
Res.Sigma.W <- implied$res.cov[[1]] |
| 26 | ! |
Res.Int.W <- implied$res.int[[1]] |
| 27 | ! |
Res.Pi.W <- implied$res.slopes[[1]] |
| 28 | ||
| 29 | ! |
Res.Sigma.B <- implied$res.cov[[2]] |
| 30 | ! |
Res.Int.B <- implied$res.int[[2]] |
| 31 | ! |
Res.Pi.B <- implied$res.slopes[[2]] |
| 32 |
} |
|
| 33 | ||
| 34 |
# within/between idx |
|
| 35 | ! |
within.x.idx <- Lp$within.x.idx[[1]] |
| 36 | ! |
between.y.idx <- Lp$between.y.idx[[2]] |
| 37 | ! |
between.x.idx <- Lp$between.x.idx[[2]] |
| 38 | ||
| 39 |
# ov.idx per level |
|
| 40 | ! |
ov.idx <- Lp$ov.idx |
| 41 | ||
| 42 |
# 'tilde' matrices: ALL variables within and between |
|
| 43 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 44 | ||
| 45 |
# only 'y' |
|
| 46 | ! |
ov.y.idx <- Lp$ov.y.idx |
| 47 | ||
| 48 |
# two levels only (for now) |
|
| 49 | ! |
ov.y.idx1 <- ov.y.idx[[1]] |
| 50 | ! |
ov.y.idx2 <- ov.y.idx[[2]] |
| 51 | ||
| 52 |
# Sigma.W.tilde |
|
| 53 | ! |
Sigma.W.tilde <- matrix(0, p.tilde, p.tilde) |
| 54 | ! |
Sigma.W.tilde[ov.y.idx1, ov.y.idx1] <- Res.Sigma.W |
| 55 | ||
| 56 |
# INT.W.tilde |
|
| 57 | ! |
INT.W.tilde <- matrix(0, p.tilde, 1L) |
| 58 | ! |
INT.W.tilde[ov.y.idx1, 1L] <- Res.Int.W |
| 59 | ||
| 60 |
# PI.W.tilde |
|
| 61 | ! |
PI.W.tilde <- matrix(0, p.tilde, ncol(Res.Pi.W)) |
| 62 | ! |
PI.W.tilde[ov.y.idx1, ] <- Res.Pi.W |
| 63 | ||
| 64 | ! |
BETA.W.tilde <- rbind(t(INT.W.tilde), t(PI.W.tilde)) |
| 65 | ||
| 66 | ||
| 67 | ||
| 68 |
# Sigma.B.tilde |
|
| 69 | ! |
Sigma.B.tilde <- matrix(0, p.tilde, p.tilde) |
| 70 | ! |
Sigma.B.tilde[ov.y.idx2, ov.y.idx2] <- Res.Sigma.B |
| 71 | ||
| 72 |
# INT.B.tilde |
|
| 73 | ! |
INT.B.tilde <- matrix(0, p.tilde, 1L) |
| 74 | ! |
INT.B.tilde[ov.y.idx2, 1L] <- Res.Int.B |
| 75 | ||
| 76 |
# PI.B.tilde |
|
| 77 | ! |
PI.B.tilde <- matrix(0, p.tilde, ncol(Res.Pi.B)) |
| 78 | ! |
PI.B.tilde[ov.y.idx2, ] <- Res.Pi.B |
| 79 | ||
| 80 | ! |
BETA.B.tilde <- rbind(t(INT.B.tilde), t(PI.B.tilde)) |
| 81 | ||
| 82 | ! |
if (length(between.y.idx) > 0L) {
|
| 83 | ! |
rm.idx <- c(within.x.idx, between.x.idx, between.y.idx) # between AND x |
| 84 | ! |
beta.z <- BETA.B.tilde[, between.y.idx, drop = FALSE] |
| 85 | ! |
beta.b <- BETA.B.tilde[, -rm.idx, drop = FALSE] |
| 86 | ! |
beta.w <- BETA.W.tilde[, -rm.idx, drop = FALSE] |
| 87 | ! |
sigma.zz <- Sigma.B.tilde[between.y.idx, between.y.idx, drop = FALSE] |
| 88 | ! |
sigma.yz <- Sigma.B.tilde[-rm.idx, between.y.idx, drop = FALSE] |
| 89 | ! |
sigma.b <- Sigma.B.tilde[-rm.idx, -rm.idx, drop = FALSE] |
| 90 | ! |
sigma.w <- Sigma.W.tilde[-rm.idx, -rm.idx, drop = FALSE] |
| 91 |
} else {
|
|
| 92 | ! |
rm.idx <- c(within.x.idx, between.x.idx) # all 'x' |
| 93 | ! |
beta.z <- matrix(0, 0L, 0L) |
| 94 | ! |
sigma.zz <- matrix(0, 0L, 0L) |
| 95 | ! |
beta.b <- BETA.B.tilde[, -rm.idx, drop = FALSE] |
| 96 | ! |
beta.w <- BETA.W.tilde[, -rm.idx, drop = FALSE] |
| 97 | ! |
sigma.b <- Sigma.B.tilde[-rm.idx, -rm.idx, drop = FALSE] |
| 98 | ! |
sigma.w <- Sigma.W.tilde[-rm.idx, -rm.idx, drop = FALSE] |
| 99 | ! |
sigma.yz <- matrix(0, nrow(sigma.w), 0L) |
| 100 |
} |
|
| 101 | ||
| 102 | ||
| 103 |
# beta.wb # FIXme: not correct if some 'x' are splitted (overlap) |
|
| 104 |
# but because we ALWAYS treat splitted-x as 'y', this is not a problem |
|
| 105 | ! |
beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE]) |
| 106 | ! |
beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE] |
| 107 | ||
| 108 | ! |
list( |
| 109 | ! |
sigma.w = sigma.w, sigma.b = sigma.b, sigma.zz = sigma.zz, |
| 110 | ! |
sigma.yz = sigma.yz, beta.w = beta.w, beta.b = beta.b, beta.z = beta.z, |
| 111 | ! |
beta.wb = beta.wb |
| 112 |
) |
|
| 113 |
} |
|
| 114 | ||
| 115 | ||
| 116 |
# recreate implied matrices from 2L matrices |
|
| 117 |
lav_mvreg_cluster_2l2implied <- function(Lp, |
|
| 118 |
sigma.w = NULL, |
|
| 119 |
sigma.b = NULL, |
|
| 120 |
sigma.zz = NULL, |
|
| 121 |
sigma.yz = NULL, |
|
| 122 |
beta.w = NULL, |
|
| 123 |
beta.b = NULL, |
|
| 124 |
beta.z = NULL) {
|
|
| 125 |
# within/between idx |
|
| 126 | ! |
within.x.idx <- Lp$within.x.idx[[1]] |
| 127 | ! |
between.y.idx <- Lp$between.y.idx[[2]] |
| 128 | ! |
between.x.idx <- Lp$between.x.idx[[2]] |
| 129 | ||
| 130 |
# ov.idx per level |
|
| 131 | ! |
ov.idx <- Lp$ov.idx |
| 132 | ||
| 133 |
# 'tilde' matrices: ALL variables within and between |
|
| 134 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 135 | ||
| 136 |
# only 'y' |
|
| 137 | ! |
ov.y.idx <- Lp$ov.y.idx |
| 138 | ||
| 139 |
# two levels only (for now) |
|
| 140 | ! |
ov.y.idx1 <- ov.y.idx[[1]] |
| 141 | ! |
ov.y.idx2 <- ov.y.idx[[2]] |
| 142 | ||
| 143 |
# Sigma.W.tilde |
|
| 144 | ! |
Sigma.W.tilde <- matrix(0, p.tilde, p.tilde) |
| 145 | ! |
Sigma.W.tilde[ov.y.idx1, ov.y.idx1] <- sigma.w |
| 146 | ||
| 147 |
# INT.W.tilde |
|
| 148 | ! |
INT.W.tilde <- matrix(0, p.tilde, 1L) |
| 149 | ! |
INT.W.tilde[ov.y.idx1, 1L] <- beta.w[1L, ] |
| 150 | ||
| 151 |
# PI.W.tilde |
|
| 152 | ! |
PI.W.tilde <- matrix(0, p.tilde, nrow(beta.w) - 1L) |
| 153 | ! |
PI.W.tilde[ov.y.idx1, ] <- t(beta.w[-1L, ]) |
| 154 | ||
| 155 |
# Sigma.B.tilde |
|
| 156 | ! |
Sigma.B.tilde <- matrix(0, p.tilde, p.tilde) |
| 157 | ! |
Sigma.B.tilde[ov.y.idx1, ov.y.idx1] <- sigma.b |
| 158 | ||
| 159 |
# INT.B.tilde |
|
| 160 | ! |
INT.B.tilde <- matrix(0, p.tilde, 1L) |
| 161 | ! |
INT.B.tilde[ov.y.idx1, 1L] <- beta.b[1L, ] |
| 162 | ||
| 163 |
# PI.B.tilde |
|
| 164 | ! |
PI.B.tilde <- matrix(0, p.tilde, nrow(beta.b) - 1L) |
| 165 | ! |
PI.B.tilde[ov.y.idx1, ] <- t(beta.b[-1L, ]) |
| 166 | ||
| 167 | ! |
if (length(between.y.idx) > 0L) {
|
| 168 | ! |
INT.B.tilde[between.y.idx, 1L] <- beta.z[1L, ] |
| 169 | ! |
PI.B.tilde[between.y.idx, ] <- t(beta.z[-1L, ]) |
| 170 | ! |
Sigma.B.tilde[between.y.idx, between.y.idx] <- sigma.zz |
| 171 | ! |
Sigma.B.tilde[ov.y.idx1, between.y.idx] <- sigma.yz |
| 172 | ! |
Sigma.B.tilde[between.y.idx, ov.y.idx1] <- t(sigma.yz) |
| 173 |
} |
|
| 174 | ||
| 175 | ! |
Res.Sigma.W <- Sigma.W.tilde[ov.y.idx1, ov.y.idx1, drop = FALSE] |
| 176 | ! |
Res.Int.W <- INT.W.tilde[ov.y.idx1, , drop = FALSE] |
| 177 | ! |
Res.Pi.W <- PI.W.tilde[ov.y.idx1, , drop = FALSE] |
| 178 | ||
| 179 | ! |
Res.Sigma.B <- Sigma.B.tilde[ov.y.idx2, ov.y.idx2, drop = FALSE] |
| 180 | ! |
Res.Int.B <- INT.B.tilde[ov.y.idx2, , drop = FALSE] |
| 181 | ! |
Res.Pi.B <- PI.B.tilde[ov.y.idx2, , drop = FALSE] |
| 182 | ||
| 183 | ! |
implied <- list( |
| 184 | ! |
res.cov = list(Res.Sigma.W, Res.Sigma.B), |
| 185 | ! |
res.int = list(Res.Int.W, Res.Int.B), |
| 186 | ! |
res.slopes = list(Res.Pi.W, Res.Pi.B) |
| 187 |
) |
|
| 188 | ||
| 189 |
# Note: cov.x and mean.x must be added by the caller |
|
| 190 | ! |
implied |
| 191 |
} |
|
| 192 | ||
| 193 |
lav_mvreg_cluster_loglik_samplestats_2l <- function(YLp = NULL, |
|
| 194 |
Lp = NULL, |
|
| 195 |
Res.Sigma.W = NULL, |
|
| 196 |
Res.Int.W = NULL, |
|
| 197 |
Res.Pi.W = NULL, |
|
| 198 |
Res.Sigma.B = NULL, |
|
| 199 |
Res.Int.B = NULL, |
|
| 200 |
Res.Pi.B = NULL, |
|
| 201 |
out = NULL, # 2l |
|
| 202 |
Sinv.method = "eigen", |
|
| 203 |
log2pi = FALSE, |
|
| 204 |
minus.two = TRUE) {
|
|
| 205 |
# map implied to 2l matrices |
|
| 206 | ! |
if (is.null(out)) {
|
| 207 | ! |
out <- lav_mvreg_cluster_implied22l( |
| 208 | ! |
Lp = Lp, implied = NULL, |
| 209 | ! |
Res.Sigma.W = Res.Sigma.W, |
| 210 | ! |
Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W, |
| 211 | ! |
Res.Sigma.B = Res.Sigma.B, |
| 212 | ! |
Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B |
| 213 |
) |
|
| 214 |
} |
|
| 215 | ! |
sigma.w <- out$sigma.w |
| 216 | ! |
sigma.b <- out$sigma.b |
| 217 | ! |
sigma.zz <- out$sigma.zz |
| 218 | ! |
sigma.yz <- out$sigma.yz |
| 219 | ! |
beta.w <- out$beta.w |
| 220 | ! |
beta.b <- out$beta.b |
| 221 | ! |
beta.z <- out$beta.z |
| 222 | ! |
beta.wb <- out$beta.wb |
| 223 | ||
| 224 |
# check for beta.wb |
|
| 225 | ! |
if (is.null(out$beta.wb)) {
|
| 226 | ! |
beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE]) |
| 227 | ! |
beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE] |
| 228 |
} |
|
| 229 | ||
| 230 |
# log 2*pi |
|
| 231 | ! |
LOG.2PI <- log(2 * pi) |
| 232 | ||
| 233 |
# Lp |
|
| 234 | ! |
nclusters <- Lp$nclusters[[2]] |
| 235 | ! |
cluster.size <- Lp$cluster.size[[2]] |
| 236 | ! |
cluster.sizes <- Lp$cluster.sizes[[2]] |
| 237 | ! |
ncluster.sizes <- Lp$ncluster.sizes[[2]] |
| 238 | ! |
n.s <- Lp$cluster.size.ns[[2]] |
| 239 | ||
| 240 |
# dependent 'y' level-2 ('Z') only variables?
|
|
| 241 | ! |
between.y.idx <- Lp$between.y.idx[[2]] |
| 242 | ||
| 243 |
# extract (the many) sample statistics from YLp |
|
| 244 | ! |
sample.wb <- YLp[[2]]$sample.wb |
| 245 | ! |
sample.YYres.wb1 <- YLp[[2]]$sample.YYres.wb1 |
| 246 | ! |
sample.XX.wb1 <- YLp[[2]]$sample.XX.wb1 |
| 247 | ! |
sample.wb2 <- YLp[[2]]$sample.wb2 |
| 248 | ! |
sample.YYres.wb2 <- YLp[[2]]$sample.YYres.wb2 |
| 249 | ! |
sample.YresX.wb2 <- YLp[[2]]$sample.YresX.wb2 |
| 250 | ! |
sample.XX.wb2 <- YLp[[2]]$sample.XX.wb2 |
| 251 | ! |
sample.clz.Y2.res <- YLp[[2]]$sample.clz.Y2.res |
| 252 | ! |
sample.clz.Y2.XX <- YLp[[2]]$sample.clz.Y2.XX |
| 253 | ! |
sample.clz.Y2.B <- YLp[[2]]$sample.clz.Y2.B |
| 254 | ! |
if (length(between.y.idx) > 0L) {
|
| 255 | ! |
sample.clz.ZZ.res <- YLp[[2]]$sample.clz.ZZ.res |
| 256 | ! |
sample.clz.ZZ.XX <- YLp[[2]]$sample.clz.ZZ.XX |
| 257 | ! |
sample.clz.ZZ.B <- YLp[[2]]$sample.clz.ZZ.B |
| 258 | ! |
sample.clz.YZ.res <- YLp[[2]]$sample.clz.YZ.res |
| 259 | ! |
sample.clz.YZ.XX <- YLp[[2]]$sample.clz.YZ.XX |
| 260 | ! |
sample.clz.YresXZ <- YLp[[2]]$sample.clz.YresXZ # zero? |
| 261 | ! |
sample.clz.XWZres <- YLp[[2]]$sample.clz.XWZres |
| 262 |
} |
|
| 263 | ||
| 264 |
# reconstruct S.PW |
|
| 265 | ! |
wb1.diff <- sample.wb - beta.wb |
| 266 | ! |
Y1Y1.wb.res <- (sample.YYres.wb1 + |
| 267 | ! |
t(wb1.diff) %*% sample.XX.wb1 %*% (wb1.diff)) |
| 268 | ||
| 269 |
# this one is weighted -- not the same as crossprod(Y2w.res) |
|
| 270 | ! |
wb2.diff <- sample.wb2 - beta.wb |
| 271 | ! |
Y2Y2w.res <- (sample.YYres.wb2 + |
| 272 | ! |
sample.YresX.wb2 %*% (wb2.diff) + |
| 273 | ! |
t(wb2.diff) %*% t(sample.YresX.wb2) + |
| 274 | ! |
t(wb2.diff) %*% sample.XX.wb2 %*% (wb2.diff)) |
| 275 | ! |
S.PW <- (Y1Y1.wb.res - Y2Y2w.res) / sum(cluster.size - 1) |
| 276 | ||
| 277 |
# common parts: |
|
| 278 | ! |
sigma.w.inv <- lav_matrix_symmetric_inverse( |
| 279 | ! |
S = sigma.w, |
| 280 | ! |
logdet = TRUE |
| 281 |
) |
|
| 282 | ! |
sigma.w.logdet <- attr(sigma.w.inv, "logdet") |
| 283 | ! |
if (length(between.y.idx) > 0L) {
|
| 284 | ! |
sigma.zz.inv <- lav_matrix_symmetric_inverse( |
| 285 | ! |
S = sigma.zz, |
| 286 | ! |
logdet = TRUE |
| 287 |
) |
|
| 288 | ! |
sigma.zz.logdet <- attr(sigma.zz.inv, "logdet") |
| 289 | ! |
sigma.yz.zi <- sigma.yz %*% sigma.zz.inv |
| 290 | ! |
sigma.zi.zy <- t(sigma.yz.zi) |
| 291 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 292 |
} else {
|
|
| 293 | ! |
sigma.b.z <- sigma.b |
| 294 |
} |
|
| 295 | ||
| 296 |
# min 2* logliklihood |
|
| 297 | ! |
DIST <- numeric(ncluster.sizes) |
| 298 | ! |
LOGDET <- numeric(ncluster.sizes) |
| 299 | ! |
CONST <- numeric(ncluster.sizes) |
| 300 | ! |
for (clz in seq_len(ncluster.sizes)) {
|
| 301 |
# cluster size |
|
| 302 | ! |
nj <- cluster.sizes[clz] |
| 303 | ||
| 304 |
# data between |
|
| 305 | ! |
nj.idx <- which(cluster.size == nj) |
| 306 | ! |
y2.diff <- sample.clz.Y2.B[[clz]] - beta.wb |
| 307 | ! |
Y2Yc.yy <- (sample.clz.Y2.res[[clz]] + |
| 308 | ! |
t(y2.diff) %*% sample.clz.Y2.XX[[clz]] %*% (y2.diff)) |
| 309 | ! |
if (length(between.y.idx) > 0L) {
|
| 310 | ! |
zz.diff <- sample.clz.ZZ.B[[clz]] - beta.z |
| 311 | ! |
Y2Yc.zz <- (sample.clz.ZZ.res[[clz]] + |
| 312 | ! |
t(zz.diff) %*% sample.clz.ZZ.XX[[clz]] %*% (zz.diff)) |
| 313 | ! |
Y2Yc.yz <- (sample.clz.YZ.res[[clz]] + |
| 314 | ! |
sample.clz.YresXZ[[clz]] %*% zz.diff + # zero? |
| 315 | ! |
t(y2.diff) %*% sample.clz.XWZres[[clz]] + |
| 316 | ! |
t(y2.diff) %*% sample.clz.YZ.XX[[clz]] %*% zz.diff) |
| 317 |
} |
|
| 318 | ||
| 319 |
# construct sigma.j |
|
| 320 | ! |
sigma.j <- (nj * sigma.b.z) + sigma.w |
| 321 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse( |
| 322 | ! |
S = sigma.j, |
| 323 | ! |
logdet = TRUE |
| 324 |
) |
|
| 325 | ! |
sigma.j.logdet <- attr(sigma.j.inv, "logdet") |
| 326 | ||
| 327 | ! |
if (length(between.y.idx) > 0L) {
|
| 328 | ! |
sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi |
| 329 | ||
| 330 |
# part 1 -- zz |
|
| 331 | ! |
Vinv.11 <- sigma.zz.inv + nj * (sigma.zi.zy %*% sigma.ji.yz.zi) |
| 332 | ! |
q.zz <- sum(Vinv.11 * Y2Yc.zz) |
| 333 | ||
| 334 |
# part 2 -- yz |
|
| 335 | ! |
q.yz <- -nj * sum(sigma.ji.yz.zi * Y2Yc.yz) |
| 336 |
} else {
|
|
| 337 | ! |
q.zz <- q.yz <- sigma.zz.logdet <- 0 |
| 338 |
} |
|
| 339 | ||
| 340 |
# part 5 -- yyc |
|
| 341 | ! |
q.yyc <- -nj * sum(sigma.j.inv * Y2Yc.yy) |
| 342 | ||
| 343 | ! |
if (log2pi) {
|
| 344 | ! |
P <- nj * nrow(sigma.w) + nrow(sigma.zz) |
| 345 | ! |
CONST[clz] <- P * LOG.2PI |
| 346 |
} |
|
| 347 | ! |
LOGDET[clz] <- sigma.zz.logdet + sigma.j.logdet |
| 348 | ! |
DIST[clz] <- q.zz + 2 * q.yz - q.yyc |
| 349 |
} |
|
| 350 |
# q.yya + q.yyb |
|
| 351 | ! |
q.W <- sum(cluster.size - 1) * sum(sigma.w.inv * S.PW) |
| 352 |
# logdet within part |
|
| 353 | ! |
L.W <- sum(cluster.size - 1) * sigma.w.logdet |
| 354 | ||
| 355 |
# -2*times logl (without the constant) (for optimization) |
|
| 356 | ! |
loglik <- sum(LOGDET * n.s) + sum(DIST) + q.W + L.W |
| 357 | ||
| 358 | ! |
if (log2pi) {
|
| 359 | ! |
loglik <- loglik + sum(CONST * n.s) |
| 360 |
} |
|
| 361 | ||
| 362 |
# functions below compute -2 * logl |
|
| 363 | ! |
if (!minus.two) {
|
| 364 | ! |
loglik <- loglik / (-2) |
| 365 |
} |
|
| 366 | ||
| 367 | ! |
loglik |
| 368 |
} |
|
| 369 | ||
| 370 |
# first derivative -2*logl wrt Beta.W, Beta.B, Sigma.W, Sigma.B |
|
| 371 |
lav_mvreg_cluster_dlogl_2l_samplestats <- function(YLp = NULL, |
|
| 372 |
Lp = NULL, |
|
| 373 |
Res.Sigma.W = NULL, |
|
| 374 |
Res.Int.W = NULL, |
|
| 375 |
Res.Pi.W = NULL, |
|
| 376 |
Res.Sigma.B = NULL, |
|
| 377 |
Res.Int.B = NULL, |
|
| 378 |
Res.Pi.B = NULL, |
|
| 379 |
out = NULL, # 2l |
|
| 380 |
return.list = FALSE, |
|
| 381 |
Sinv.method = "eigen") {
|
|
| 382 |
# map implied to 2l matrices |
|
| 383 | ! |
if (is.null(out)) {
|
| 384 | ! |
out <- lav_mvreg_cluster_implied22l( |
| 385 | ! |
Lp = Lp, implied = NULL, |
| 386 | ! |
Res.Sigma.W = Res.Sigma.W, |
| 387 | ! |
Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W, |
| 388 | ! |
Res.Sigma.B = Res.Sigma.B, |
| 389 | ! |
Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B |
| 390 |
) |
|
| 391 |
} |
|
| 392 | ! |
sigma.w <- out$sigma.w |
| 393 | ! |
sigma.b <- out$sigma.b |
| 394 | ! |
sigma.zz <- out$sigma.zz |
| 395 | ! |
sigma.yz <- out$sigma.yz |
| 396 | ! |
beta.w <- out$beta.w |
| 397 | ! |
beta.b <- out$beta.b |
| 398 | ! |
beta.z <- out$beta.z |
| 399 | ! |
beta.wb <- out$beta.wb |
| 400 | ||
| 401 |
# check for beta.wb |
|
| 402 | ! |
if (is.null(out$beta.wb)) {
|
| 403 | ! |
beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE]) |
| 404 | ! |
beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE] |
| 405 |
} |
|
| 406 | ||
| 407 |
# Lp |
|
| 408 | ! |
nclusters <- Lp$nclusters[[2]] |
| 409 | ! |
cluster.size <- Lp$cluster.size[[2]] |
| 410 | ! |
cluster.sizes <- Lp$cluster.sizes[[2]] |
| 411 | ! |
ncluster.sizes <- Lp$ncluster.sizes[[2]] |
| 412 | ! |
n.s <- Lp$cluster.size.ns[[2]] |
| 413 | ||
| 414 | ! |
within.x.idx <- Lp$within.x.idx[[1]] |
| 415 | ! |
between.y.idx <- Lp$between.y.idx[[2]] |
| 416 | ||
| 417 | ! |
w1.idx <- seq_len(length(within.x.idx) + 1L) |
| 418 | ! |
b1.idx <- c(1L, seq_len(nrow(beta.wb))[-w1.idx]) |
| 419 | ||
| 420 |
# extract (the many) sample statistics from YLp |
|
| 421 | ! |
sample.wb <- YLp[[2]]$sample.wb |
| 422 | ! |
sample.YYres.wb1 <- YLp[[2]]$sample.YYres.wb1 |
| 423 | ! |
sample.XX.wb1 <- YLp[[2]]$sample.XX.wb1 |
| 424 | ! |
sample.wb2 <- YLp[[2]]$sample.wb2 |
| 425 | ! |
sample.YYres.wb2 <- YLp[[2]]$sample.YYres.wb2 |
| 426 | ! |
sample.YresX.wb2 <- YLp[[2]]$sample.YresX.wb2 |
| 427 | ! |
sample.XX.wb2 <- YLp[[2]]$sample.XX.wb2 |
| 428 | ! |
sample.clz.Y2.res <- YLp[[2]]$sample.clz.Y2.res |
| 429 | ! |
sample.clz.Y2.XX <- YLp[[2]]$sample.clz.Y2.XX |
| 430 | ! |
sample.clz.Y2.B <- YLp[[2]]$sample.clz.Y2.B |
| 431 | ! |
if (length(between.y.idx) > 0L) {
|
| 432 | ! |
sample.clz.ZZ.res <- YLp[[2]]$sample.clz.ZZ.res |
| 433 | ! |
sample.clz.ZZ.XX <- YLp[[2]]$sample.clz.ZZ.XX |
| 434 | ! |
sample.clz.ZZ.B <- YLp[[2]]$sample.clz.ZZ.B |
| 435 | ! |
sample.clz.YZ.res <- YLp[[2]]$sample.clz.YZ.res |
| 436 | ! |
sample.clz.YZ.XX <- YLp[[2]]$sample.clz.YZ.XX |
| 437 | ! |
sample.clz.YresXZ <- YLp[[2]]$sample.clz.YresXZ # zero? |
| 438 | ! |
sample.clz.XWZres <- YLp[[2]]$sample.clz.XWZres |
| 439 |
} |
|
| 440 | ||
| 441 |
# reconstruct S.PW |
|
| 442 | ! |
wb1.diff <- sample.wb - beta.wb |
| 443 | ! |
Y1Y1.wb.res <- (sample.YYres.wb1 + |
| 444 | ! |
t(wb1.diff) %*% sample.XX.wb1 %*% (wb1.diff)) |
| 445 | ||
| 446 |
# this one is weighted -- not the same as crossprod(Y2w.res) |
|
| 447 | ! |
wb2.diff <- sample.wb2 - beta.wb |
| 448 | ! |
Y2Y2w.res <- (sample.YYres.wb2 + |
| 449 | ! |
sample.YresX.wb2 %*% (wb2.diff) + |
| 450 | ! |
t(wb2.diff) %*% t(sample.YresX.wb2) + |
| 451 | ! |
t(wb2.diff) %*% sample.XX.wb2 %*% (wb2.diff)) |
| 452 | ! |
S.PW <- (Y1Y1.wb.res - Y2Y2w.res) / sum(cluster.size - 1) |
| 453 | ||
| 454 |
# common parts: |
|
| 455 | ! |
sigma.w.inv <- lav_matrix_symmetric_inverse(S = sigma.w) |
| 456 | ||
| 457 | ! |
G.beta.w <- matrix(0, ncluster.sizes, length(beta.w)) |
| 458 | ! |
G.beta.b <- matrix(0, ncluster.sizes, length(beta.b)) |
| 459 | ! |
G.beta.wb <- matrix(0, ncluster.sizes, length(beta.wb)) |
| 460 | ! |
G.sigma.w1 <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.w))) |
| 461 | ! |
G.sigma.b <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.b))) |
| 462 | ||
| 463 | ! |
if (length(between.y.idx) > 0L) {
|
| 464 | ! |
G.beta.z <- matrix(0, ncluster.sizes, length(beta.z)) |
| 465 | ! |
G.sigma.zz <- matrix(0, ncluster.sizes, length(lav_matrix_vech(sigma.zz))) |
| 466 | ! |
G.sigma.yz <- matrix(0, ncluster.sizes, length(sigma.yz)) |
| 467 | ||
| 468 | ! |
sigma.zz.inv <- lav_matrix_symmetric_inverse(S = sigma.zz) |
| 469 | ! |
sigma.yz.zi <- sigma.yz %*% sigma.zz.inv |
| 470 | ! |
sigma.zi.zy <- t(sigma.yz.zi) |
| 471 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 472 | ||
| 473 | ! |
for (clz in seq_len(ncluster.sizes)) {
|
| 474 |
# cluster size |
|
| 475 | ! |
nj <- cluster.sizes[clz] |
| 476 | ||
| 477 | ! |
y2.diff <- sample.clz.Y2.B[[clz]] - beta.wb |
| 478 | ! |
XX.y2.diff <- sample.clz.Y2.XX[[clz]] %*% y2.diff |
| 479 | ! |
Y2Yc.yy <- sample.clz.Y2.res[[clz]] + crossprod(y2.diff, XX.y2.diff) |
| 480 | ||
| 481 | ! |
zz.diff <- sample.clz.ZZ.B[[clz]] - beta.z |
| 482 | ! |
Y2Yc.zz <- (sample.clz.ZZ.res[[clz]] + |
| 483 | ! |
t(zz.diff) %*% sample.clz.ZZ.XX[[clz]] %*% (zz.diff)) |
| 484 | ! |
Y2Yc.yz <- (sample.clz.YZ.res[[clz]] + |
| 485 | ! |
sample.clz.YresXZ[[clz]] %*% zz.diff + # zero? |
| 486 | ! |
t(y2.diff) %*% sample.clz.XWZres[[clz]] + |
| 487 | ! |
t(y2.diff) %*% sample.clz.YZ.XX[[clz]] %*% zz.diff) |
| 488 | ||
| 489 |
# construct sigma.j |
|
| 490 | ! |
sigma.j <- (nj * sigma.b.z) + sigma.w |
| 491 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j) |
| 492 | ! |
sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi |
| 493 | ! |
sigma.zi.zy.ji <- t(sigma.ji.yz.zi) |
| 494 | ! |
sigma.ji.yz <- sigma.j.inv %*% sigma.yz |
| 495 | ! |
ns.sigma.j.inv <- n.s[clz] * sigma.j.inv |
| 496 | ! |
ns.sigma.zz.inv <- n.s[clz] * sigma.zz.inv |
| 497 | ! |
ns.sigma.yz <- n.s[clz] * sigma.yz |
| 498 | ! |
ns.sigma.ji.yz.zi <- n.s[clz] * sigma.ji.yz.zi |
| 499 | ||
| 500 |
# common parts |
|
| 501 | ! |
ZZ.zi.yz.ji <- Y2Yc.zz %*% sigma.zi.zy.ji |
| 502 | ! |
ji.YZ.zi <- sigma.j.inv %*% Y2Yc.yz %*% sigma.zz.inv |
| 503 | ||
| 504 | ! |
jYZj.yy <- sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv |
| 505 | ! |
jYZj.yz <- tcrossprod(ji.YZ.zi, sigma.ji.yz) |
| 506 | ! |
jYZj.zz <- sigma.ji.yz.zi %*% ZZ.zi.yz.ji |
| 507 | ||
| 508 | ! |
jYZj <- nj * (jYZj.yy + jYZj.zz - jYZj.yz - t(jYZj.yz)) |
| 509 | ||
| 510 |
# SIGMA.W (between part) |
|
| 511 | ! |
g.sigma.w1 <- ns.sigma.j.inv - jYZj |
| 512 | ! |
tmp <- g.sigma.w1 * 2 |
| 513 | ! |
diag(tmp) <- diag(g.sigma.w1) |
| 514 | ! |
G.sigma.w1[clz, ] <- lav_matrix_vech(tmp) |
| 515 | ||
| 516 |
# SIGMA.B |
|
| 517 | ! |
g.sigma.b <- nj * g.sigma.w1 |
| 518 | ! |
tmp <- g.sigma.b * 2 |
| 519 | ! |
diag(tmp) <- diag(g.sigma.b) |
| 520 | ! |
G.sigma.b[clz, ] <- lav_matrix_vech(tmp) |
| 521 | ||
| 522 |
# SIGMA.ZZ |
|
| 523 | ! |
YZ1 <- ZZ.zi.yz.ji %*% sigma.yz |
| 524 | ! |
YZ2 <- crossprod(Y2Yc.yz, sigma.ji.yz) |
| 525 | ! |
tmp <- (t(sigma.yz) %*% g.sigma.w1 %*% sigma.yz |
| 526 | ! |
- 1 / nj * Y2Yc.zz - t(YZ1) - YZ1 + t(YZ2) + YZ2) |
| 527 | ! |
g.sigma.zz <- (ns.sigma.zz.inv + |
| 528 | ! |
nj * sigma.zz.inv %*% tmp %*% sigma.zz.inv) |
| 529 | ! |
tmp <- g.sigma.zz * 2 |
| 530 | ! |
diag(tmp) <- diag(g.sigma.zz) |
| 531 | ! |
G.sigma.zz[clz, ] <- lav_matrix_vech(tmp) |
| 532 | ||
| 533 |
# SIGMA.ZY |
|
| 534 | ! |
tmp1 <- crossprod(ZZ.zi.yz.ji, sigma.zz.inv) |
| 535 | ! |
tmp2 <- ns.sigma.ji.yz.zi |
| 536 | ! |
tmp3 <- ji.YZ.zi |
| 537 | ! |
tmp4 <- jYZj %*% sigma.yz.zi |
| 538 | ! |
g.sigma.yz <- 2 * nj * (tmp1 - tmp2 - tmp3 + tmp4) |
| 539 | ! |
G.sigma.yz[clz, ] <- lav_matrix_vec(g.sigma.yz) |
| 540 | ||
| 541 |
# BETA.Z |
|
| 542 | ! |
A <- (sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) # symm! |
| 543 | ! |
B <- nj * (sigma.zi.zy.ji) |
| 544 | ! |
tmp.z <- (sample.clz.ZZ.XX[[clz]] %*% zz.diff %*% A - |
| 545 | ! |
(t(sample.clz.YresXZ[[clz]]) + |
| 546 | ! |
t(sample.clz.YZ.XX[[clz]]) %*% y2.diff) %*% t(B)) |
| 547 | ! |
G.beta.z[clz, ] <- as.vector(-2 * tmp.z) |
| 548 | ||
| 549 |
# BETA.W (between part only) + BETA.B |
|
| 550 | ! |
tmp <- (sample.clz.XWZres[[clz]] + |
| 551 | ! |
sample.clz.YZ.XX[[clz]] %*% zz.diff) |
| 552 | ! |
out.b <- tmp %*% sigma.zi.zy.ji - XX.y2.diff %*% sigma.j.inv |
| 553 | ! |
out.w <- out.b + XX.y2.diff %*% sigma.w.inv |
| 554 | ! |
tmp.b <- out.b[b1.idx, , drop = FALSE] |
| 555 | ! |
tmp.w <- out.w[w1.idx, , drop = FALSE] |
| 556 | ! |
G.beta.b[clz, ] <- as.vector(2 * nj * tmp.b) |
| 557 | ! |
G.beta.w[clz, ] <- as.vector(2 * nj * tmp.w) |
| 558 |
} # clz |
|
| 559 | ||
| 560 | ! |
d.beta.w1 <- matrix(colSums(G.beta.w), nrow(beta.w), ncol(beta.w)) |
| 561 | ! |
d.beta.b <- matrix(colSums(G.beta.b), nrow(beta.b), ncol(beta.b)) |
| 562 | ! |
d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.sigma.w1)) |
| 563 | ! |
d.sigma.b <- lav_matrix_vech_reverse(colSums(G.sigma.b)) |
| 564 | ||
| 565 |
# z |
|
| 566 | ! |
d.beta.z <- matrix(colSums(G.beta.z), nrow(beta.z), ncol(beta.z)) |
| 567 | ! |
d.sigma.zz <- lav_matrix_vech_reverse(colSums(G.sigma.zz)) |
| 568 | ! |
d.sigma.yz <- matrix(colSums(G.sigma.yz), nrow(sigma.yz), ncol(sigma.yz)) |
| 569 |
} # between.y.idx |
|
| 570 | ||
| 571 |
else { # no beween.y.idx
|
|
| 572 | ||
| 573 | ! |
for (clz in seq_len(ncluster.sizes)) {
|
| 574 |
# cluster size |
|
| 575 | ! |
nj <- cluster.sizes[clz] |
| 576 | ||
| 577 | ! |
y2.diff <- sample.clz.Y2.B[[clz]] - beta.wb |
| 578 | ! |
XX.y2.diff <- sample.clz.Y2.XX[[clz]] %*% y2.diff |
| 579 | ! |
Y2Yc.yy <- sample.clz.Y2.res[[clz]] + crossprod(y2.diff, XX.y2.diff) |
| 580 | ||
| 581 |
# construct sigma.j |
|
| 582 | ! |
sigma.j <- (nj * sigma.b) + sigma.w |
| 583 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j) |
| 584 | ||
| 585 |
# common part |
|
| 586 | ! |
jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv |
| 587 | ||
| 588 |
# SIGMA.W (between part) |
|
| 589 | ! |
g.sigma.w1 <- (n.s[clz] * sigma.j.inv) - jYYj |
| 590 | ! |
tmp <- g.sigma.w1 * 2 |
| 591 | ! |
diag(tmp) <- diag(g.sigma.w1) |
| 592 | ! |
G.sigma.w1[clz, ] <- lav_matrix_vech(tmp) |
| 593 | ||
| 594 |
# SIGMA.B |
|
| 595 | ! |
g.sigma.b <- nj * g.sigma.w1 |
| 596 | ! |
tmp <- g.sigma.b * 2 |
| 597 | ! |
diag(tmp) <- diag(g.sigma.b) |
| 598 | ! |
G.sigma.b[clz, ] <- lav_matrix_vech(tmp) |
| 599 | ||
| 600 |
# BETA.W (between part only) + BETA.B |
|
| 601 | ! |
out.b <- -1 * XX.y2.diff %*% sigma.j.inv |
| 602 | ! |
out.w <- out.b + XX.y2.diff %*% sigma.w.inv |
| 603 | ! |
tmp.b <- out.b[b1.idx, , drop = FALSE] |
| 604 | ! |
tmp.w <- out.w[w1.idx, , drop = FALSE] |
| 605 | ! |
G.beta.b[clz, ] <- as.vector(2 * nj * tmp.b) |
| 606 | ! |
G.beta.w[clz, ] <- as.vector(2 * nj * tmp.w) |
| 607 |
} # cl |
|
| 608 | ||
| 609 | ! |
d.beta.w1 <- matrix(colSums(G.beta.w), nrow(beta.w), ncol(beta.w)) |
| 610 | ! |
d.beta.b <- matrix(colSums(G.beta.b), nrow(beta.b), ncol(beta.b)) |
| 611 | ! |
d.sigma.w1 <- lav_matrix_vech_reverse(colSums(G.sigma.w1)) |
| 612 | ! |
d.sigma.b <- lav_matrix_vech_reverse(colSums(G.sigma.b)) |
| 613 | ||
| 614 |
# z |
|
| 615 | ! |
d.beta.z <- matrix(0, 0L, 0L) |
| 616 | ! |
d.sigma.zz <- matrix(0, 0L, 0L) |
| 617 | ! |
d.sigma.yz <- matrix(0, 0L, 0L) |
| 618 |
} # no-between-y |
|
| 619 | ||
| 620 |
# Sigma.W (bis) |
|
| 621 | ! |
d.sigma.w2 <- sum(cluster.size - 1) * (sigma.w.inv |
| 622 | ! |
- sigma.w.inv %*% S.PW %*% sigma.w.inv) |
| 623 | ! |
tmp <- d.sigma.w2 * 2 |
| 624 | ! |
diag(tmp) <- diag(d.sigma.w2) |
| 625 | ! |
d.sigma.w2 <- tmp |
| 626 | ||
| 627 | ! |
d.sigma.w <- d.sigma.w1 + d.sigma.w2 |
| 628 | ||
| 629 |
# beta.w (bis) |
|
| 630 | ! |
d.beta.w2 <- -2 * (sample.XX.wb1 %*% (sample.wb - beta.wb))[w1.idx, , drop = FALSE] %*% sigma.w.inv |
| 631 | ||
| 632 | ! |
d.beta.w <- d.beta.w1 + d.beta.w2 |
| 633 | ||
| 634 |
# rearrange |
|
| 635 | ! |
dimplied <- lav_mvreg_cluster_2l2implied(Lp, |
| 636 | ! |
sigma.w = d.sigma.w, sigma.b = d.sigma.b, |
| 637 | ! |
sigma.zz = d.sigma.zz, sigma.yz = d.sigma.yz, |
| 638 | ! |
beta.w = d.beta.w, beta.b = d.beta.b, beta.z = d.beta.z |
| 639 |
) |
|
| 640 | ||
| 641 | ! |
if (return.list) {
|
| 642 | ! |
return(dimplied) |
| 643 |
} |
|
| 644 | ||
| 645 |
# as a single vector |
|
| 646 | ! |
out <- c( |
| 647 | ! |
drop(dimplied$res.int[[1]]), |
| 648 | ! |
lav_matrix_vec(dimplied$res.slopes[[1]]), |
| 649 | ! |
lav_matrix_vech(dimplied$res.cov[[1]]), |
| 650 | ! |
drop(dimplied$res.int[[2]]), |
| 651 | ! |
lav_matrix_vec(dimplied$res.slopes[[2]]), |
| 652 | ! |
lav_matrix_vech(dimplied$res.cov[[2]]) |
| 653 |
) |
|
| 654 | ! |
out |
| 655 |
} |
|
| 656 | ||
| 657 |
# cluster-wise scores -2*logl wrt Beta.W, Beta.B, Sigma.W, Sigma.B |
|
| 658 |
lav_mvreg_cluster_scores_2l <- function(Y1 = NULL, |
|
| 659 |
YLp = NULL, |
|
| 660 |
Lp = NULL, |
|
| 661 |
Res.Sigma.W = NULL, |
|
| 662 |
Res.Int.W = NULL, |
|
| 663 |
Res.Pi.W = NULL, |
|
| 664 |
Res.Sigma.B = NULL, |
|
| 665 |
Res.Int.B = NULL, |
|
| 666 |
Res.Pi.B = NULL, |
|
| 667 |
out = NULL, # 2l |
|
| 668 |
Sinv.method = "eigen") {
|
|
| 669 |
# map implied to 2l matrices |
|
| 670 | ! |
if (is.null(out)) {
|
| 671 | ! |
out <- lav_mvreg_cluster_implied22l( |
| 672 | ! |
Lp = Lp, implied = NULL, |
| 673 | ! |
Res.Sigma.W = Res.Sigma.W, |
| 674 | ! |
Res.Int.W = Res.Int.W, Res.Pi.W = Res.Pi.W, |
| 675 | ! |
Res.Sigma.B = Res.Sigma.B, |
| 676 | ! |
Res.Int.B = Res.Int.B, Res.Pi.B = Res.Pi.B |
| 677 |
) |
|
| 678 |
} |
|
| 679 | ! |
sigma.w <- out$sigma.w |
| 680 | ! |
sigma.b <- out$sigma.b |
| 681 | ! |
sigma.zz <- out$sigma.zz |
| 682 | ! |
sigma.yz <- out$sigma.yz |
| 683 | ! |
beta.w <- out$beta.w |
| 684 | ! |
beta.b <- out$beta.b |
| 685 | ! |
beta.z <- out$beta.z |
| 686 | ! |
beta.wb <- out$beta.wb |
| 687 | ||
| 688 |
# check for beta.wb |
|
| 689 | ! |
if (is.null(out$beta.wb)) {
|
| 690 | ! |
beta.wb <- rbind(beta.w, beta.b[-1, , drop = FALSE]) |
| 691 | ! |
beta.wb[1, ] <- beta.wb[1, , drop = FALSE] + beta.b[1, , drop = FALSE] |
| 692 |
} |
|
| 693 | ||
| 694 |
# Lp |
|
| 695 | ! |
nclusters <- Lp$nclusters[[2]] |
| 696 | ! |
cluster.size <- Lp$cluster.size[[2]] |
| 697 | ! |
cluster.idx <- Lp$cluster.idx[[2]] |
| 698 | ||
| 699 | ! |
within.x.idx <- Lp$within.x.idx[[1]] |
| 700 | ! |
between.idx <- Lp$between.idx[[2]] |
| 701 | ! |
between.y.idx <- Lp$between.y.idx[[2]] |
| 702 | ! |
between.x.idx <- Lp$between.x.idx[[2]] |
| 703 | ||
| 704 | ! |
y1.idx <- Lp$ov.y.idx[[1]] |
| 705 | ! |
x1.idx <- c(within.x.idx, between.x.idx) # in that order |
| 706 | ||
| 707 |
# residuals for 'Y' |
|
| 708 | ! |
Y1.wb <- Y1[, y1.idx, drop = FALSE] |
| 709 | ||
| 710 | ! |
if (length(x1.idx) > 0L) {
|
| 711 | ! |
EXO.wb <- cbind(1, Y1[, x1.idx, drop = FALSE]) |
| 712 | ! |
Y1.wb.hat <- EXO.wb %*% beta.wb |
| 713 | ! |
Y1.wb.res <- Y1.wb - Y1.wb.hat |
| 714 |
} else {
|
|
| 715 | ! |
Y1.wb.res <- Y1.wb |
| 716 |
} |
|
| 717 | ||
| 718 |
# residuals 'Y' (level 2) |
|
| 719 | ! |
Y2 <- YLp[[2]]$Y2 |
| 720 | ! |
if (length(x1.idx) > 0L) {
|
| 721 | ! |
EXO.wb2 <- cbind(1, Y2[, x1.idx, drop = FALSE]) |
| 722 | ! |
Y2w.res <- Y2[, y1.idx, drop = FALSE] - EXO.wb2 %*% beta.wb |
| 723 |
} else {
|
|
| 724 | ! |
EXO.wb2 <- matrix(1, nrow(Y2), 1L) |
| 725 | ! |
Y2w.res <- Y2[, y1.idx, drop = FALSE] |
| 726 |
} |
|
| 727 | ||
| 728 |
# residual 'Z' (level 2) |
|
| 729 | ! |
if (length(between.y.idx) > 0L) {
|
| 730 | ! |
if (length(between.x.idx) > 0L) {
|
| 731 | ! |
EXO.z <- cbind(1, Y2[, between.x.idx, drop = FALSE]) |
| 732 | ! |
Y2.z <- Y2[, between.y.idx, drop = FALSE] |
| 733 | ! |
Y2z.res <- Y2.z - EXO.z %*% beta.z |
| 734 |
# sample.z |
|
| 735 |
# XX.z <- crossprod(EXO.z) |
|
| 736 |
# sample.z <- try(solve(XX.z, crossprod(EXO.z, Y2.z))) |
|
| 737 |
# if(inherits(sample.z, "try-error")) {
|
|
| 738 |
# sample.z <- MASS::ginv(XX.z) %*% crossprod(EXO.z, Y2.z) |
|
| 739 |
# } |
|
| 740 | ||
| 741 |
# sample.wb2 |
|
| 742 |
# sample.wb2 <- YLp[[2]]$sample.wb2 |
|
| 743 |
} else {
|
|
| 744 | ! |
Y2z.res <- Y2[, between.y.idx, drop = FALSE] |
| 745 |
} |
|
| 746 |
} |
|
| 747 | ||
| 748 |
# common parts: |
|
| 749 | ! |
sigma.w.inv <- lav_matrix_symmetric_inverse(S = sigma.w) |
| 750 | ||
| 751 | ! |
G.beta.w1 <- matrix(0, nclusters, length(beta.w)) |
| 752 | ! |
G.beta.b <- matrix(0, nclusters, length(beta.b)) |
| 753 | ! |
G.beta.wb <- matrix(0, nclusters, length(beta.wb)) |
| 754 | ! |
G.sigma.w1 <- matrix(0, nclusters, length(lav_matrix_vech(sigma.w))) |
| 755 | ! |
G.sigma.b <- matrix(0, nclusters, length(lav_matrix_vech(sigma.b))) |
| 756 | ||
| 757 | ||
| 758 | ! |
if (length(between.y.idx) > 0L) {
|
| 759 | ! |
G.beta.z <- matrix(0, nclusters, length(beta.z)) |
| 760 | ! |
G.sigma.zz <- matrix(0, nclusters, length(lav_matrix_vech(sigma.zz))) |
| 761 | ! |
G.sigma.yz <- matrix(0, nclusters, length(sigma.yz)) |
| 762 | ||
| 763 | ! |
sigma.zz.inv <- lav_matrix_symmetric_inverse(S = sigma.zz) |
| 764 | ! |
sigma.yz.zi <- sigma.yz %*% sigma.zz.inv |
| 765 | ! |
sigma.zi.zy <- t(sigma.yz.zi) |
| 766 | ! |
sigma.b.z <- sigma.b - sigma.yz %*% sigma.zi.zy |
| 767 | ||
| 768 | ! |
for (cl in seq_len(nclusters)) {
|
| 769 |
# cluster size |
|
| 770 | ! |
nj <- cluster.size[cl] |
| 771 | ||
| 772 |
# data within for the cluster (centered) |
|
| 773 | ! |
Y1m <- Y1.wb.res[cluster.idx == cl, , drop = FALSE] |
| 774 | ! |
yc <- Y2w.res[cl, ] |
| 775 | ||
| 776 |
# data between |
|
| 777 | ! |
zc <- Y2z.res[cl, ] |
| 778 | ! |
Y2Yc.yy <- tcrossprod(Y2w.res[cl, ]) |
| 779 | ! |
Y2Yc.zz <- tcrossprod(Y2z.res[cl, ]) |
| 780 | ! |
Y2Yc.yz <- tcrossprod(Y2w.res[cl, ], Y2z.res[cl, ]) |
| 781 | ||
| 782 |
# construct sigma.j |
|
| 783 | ! |
sigma.j <- (nj * sigma.b.z) + sigma.w |
| 784 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j) |
| 785 | ! |
sigma.ji.yz.zi <- sigma.j.inv %*% sigma.yz.zi |
| 786 | ! |
sigma.zi.zy.ji <- t(sigma.ji.yz.zi) |
| 787 | ! |
sigma.ji.yz <- sigma.j.inv %*% sigma.yz |
| 788 | ||
| 789 |
# common parts |
|
| 790 | ! |
ZZ.zi.yz.ji <- Y2Yc.zz %*% sigma.zi.zy.ji |
| 791 | ! |
ji.YZ.zi <- sigma.j.inv %*% Y2Yc.yz %*% sigma.zz.inv |
| 792 | ||
| 793 | ! |
jYZj.yy <- sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv |
| 794 | ! |
jYZj.yz <- tcrossprod(ji.YZ.zi, sigma.ji.yz) |
| 795 | ! |
jYZj.zz <- sigma.ji.yz.zi %*% ZZ.zi.yz.ji |
| 796 | ||
| 797 | ! |
jYZj <- nj * (jYZj.yy + jYZj.zz - jYZj.yz - t(jYZj.yz)) |
| 798 | ||
| 799 |
# SIGMA.W (between part) |
|
| 800 | ! |
g.sigma.w1 <- sigma.j.inv - jYZj |
| 801 | ! |
tmp <- g.sigma.w1 * 2 |
| 802 | ! |
diag(tmp) <- diag(g.sigma.w1) |
| 803 | ! |
G.sigma.w1[cl, ] <- lav_matrix_vech(tmp) |
| 804 | ||
| 805 |
# SIGMA.W (within part) |
|
| 806 |
# g.sigma.w2 <- ( (nj-1) * sigma.w.inv |
|
| 807 |
# - sigma.w.inv %*% (crossprod(Y1m) - nj*Y2Yc.yy) %*% sigma.w.inv ) |
|
| 808 |
# tmp <- g.sigma.w2*2; diag(tmp) <- diag(g.sigma.w2) |
|
| 809 |
# G.sigma.w2[cl,] <- lav_matrix_vech(tmp) |
|
| 810 |
# G.sigma.w[cl,] <- G.sigma.w1[cl,] + G.sigma.w2[cl,] |
|
| 811 | ||
| 812 |
# SIGMA.B |
|
| 813 | ! |
g.sigma.b <- nj * g.sigma.w1 |
| 814 | ! |
tmp <- g.sigma.b * 2 |
| 815 | ! |
diag(tmp) <- diag(g.sigma.b) |
| 816 | ! |
G.sigma.b[cl, ] <- lav_matrix_vech(tmp) |
| 817 | ||
| 818 |
# SIGMA.ZZ |
|
| 819 | ! |
YZ1 <- ZZ.zi.yz.ji %*% sigma.yz |
| 820 | ! |
YZ2 <- crossprod(Y2Yc.yz, sigma.ji.yz) |
| 821 | ! |
tmp <- (t(sigma.yz) %*% g.sigma.w1 %*% sigma.yz |
| 822 | ! |
- (1 / nj * Y2Yc.zz + t(YZ1) + YZ1 - t(YZ2) - YZ2)) |
| 823 | ! |
g.sigma.zz <- (sigma.zz.inv + |
| 824 | ! |
nj * sigma.zz.inv %*% tmp %*% sigma.zz.inv) |
| 825 | ! |
tmp <- g.sigma.zz * 2 |
| 826 | ! |
diag(tmp) <- diag(g.sigma.zz) |
| 827 | ! |
G.sigma.zz[cl, ] <- lav_matrix_vech(tmp) |
| 828 | ||
| 829 |
# SIGMA.ZY |
|
| 830 |
# g.sigma.yz <- 2 * nj * ( |
|
| 831 |
# (sigma.j.inv %*% |
|
| 832 |
# (sigma.yz.zi %*% Y2Yc.zz - sigma.yz - Y2Yc.yz) |
|
| 833 |
# + jYZj %*% sigma.yz) %*% sigma.zz.inv ) |
|
| 834 | ! |
tmp1 <- crossprod(ZZ.zi.yz.ji, sigma.zz.inv) |
| 835 | ! |
tmp2 <- sigma.ji.yz.zi |
| 836 | ! |
tmp3 <- ji.YZ.zi |
| 837 | ! |
tmp4 <- jYZj %*% sigma.yz.zi |
| 838 | ! |
g.sigma.yz <- 2 * nj * (tmp1 - tmp2 - tmp3 + tmp4) |
| 839 | ! |
G.sigma.yz[cl, ] <- lav_matrix_vec(g.sigma.yz) |
| 840 | ||
| 841 |
# BETA.Z |
|
| 842 |
# here, we avoid the (sample.z - beta.z) approach |
|
| 843 | ! |
exo.z <- cbind(1, Y2[cl, between.x.idx, drop = FALSE]) |
| 844 | ! |
tmp1 <- (sigma.zz.inv + nj * (sigma.zi.zy.ji %*% sigma.yz.zi)) %*% zc |
| 845 | ! |
tmp2 <- nj * (sigma.zi.zy.ji) %*% yc |
| 846 | ! |
tmp.z <- crossprod(exo.z, drop(tmp1 - tmp2)) |
| 847 | ! |
G.beta.z[cl, ] <- as.vector(-2 * tmp.z) |
| 848 | ||
| 849 |
# BETA.W |
|
| 850 |
# exo.w <- cbind(1, |
|
| 851 |
# Y1[cluster.idx == cl, within.x.idx, drop = FALSE]) |
|
| 852 |
# G.beta.w[cl,] <- as.vector( 2 * t(exo.w) %*% ( |
|
| 853 |
# matrix(1, nj, 1) %x% (zc %*% sigma.zi.zy.ji - |
|
| 854 |
# yc %*% sigma.j.inv + |
|
| 855 |
# yc %*% sigma.w.inv) - |
|
| 856 |
# Y1m %*% sigma.w.inv) ) |
|
| 857 | ||
| 858 |
# BETA.W (between part only) |
|
| 859 | ! |
exo2.w <- cbind(1, Y2[cl, within.x.idx, drop = FALSE]) |
| 860 | ! |
tmp2 <- (zc %*% sigma.zi.zy.ji - |
| 861 | ! |
yc %*% sigma.j.inv + |
| 862 | ! |
yc %*% sigma.w.inv) |
| 863 | ! |
G.beta.w1[cl, ] <- as.vector(2 * nj * crossprod(exo2.w, tmp2)) |
| 864 | ||
| 865 |
# BETA.W (within part only) |
|
| 866 |
# exo.w <- cbind(1, |
|
| 867 |
# Y1[cluster.idx == cl, within.x.idx, drop = FALSE]) |
|
| 868 |
# tmp1 <- - Y1m %*% sigma.w.inv |
|
| 869 |
# G.beta.ww <- as.vector( 2 * crossprod(exo.w, tmp1) ) |
|
| 870 |
# G.beta.w[cl,] <- G.beta.w1 + G.beta.ww |
|
| 871 |
# G.beta.w2[cl,] <- G.beta.ww |
|
| 872 | ||
| 873 |
# BETA.B |
|
| 874 | ! |
exo2.b <- cbind(1, Y2[cl, between.x.idx, drop = FALSE]) |
| 875 | ! |
tmp <- (zc %*% sigma.zi.zy.ji - yc %*% sigma.j.inv) |
| 876 | ! |
G.beta.b[cl, ] <- as.vector(2 * nj * crossprod(exo2.b, tmp)) |
| 877 |
} # cl |
|
| 878 |
} # between.y.idx |
|
| 879 | ||
| 880 |
else { # no beween.y.idx
|
|
| 881 | ||
| 882 | ! |
for (cl in seq_len(nclusters)) {
|
| 883 |
# cluster size |
|
| 884 | ! |
nj <- cluster.size[cl] |
| 885 | ||
| 886 |
# data within for the cluster (centered) |
|
| 887 | ! |
Y1m <- Y1.wb.res[cluster.idx == cl, , drop = FALSE] |
| 888 | ! |
yc <- Y2w.res[cl, ] |
| 889 | ||
| 890 |
# data between |
|
| 891 | ! |
Y2Yc.yy <- tcrossprod(Y2w.res[cl, ]) |
| 892 | ||
| 893 |
# construct sigma.j |
|
| 894 | ! |
sigma.j <- (nj * sigma.b) + sigma.w |
| 895 | ! |
sigma.j.inv <- lav_matrix_symmetric_inverse(S = sigma.j) |
| 896 | ||
| 897 |
# common part |
|
| 898 | ! |
jYYj <- nj * sigma.j.inv %*% Y2Yc.yy %*% sigma.j.inv |
| 899 | ||
| 900 |
# SIGMA.W |
|
| 901 |
# g.sigma.w <- ( (nj-1) * sigma.w.inv |
|
| 902 |
# - sigma.w.inv %*% (crossprod(Y1m) - nj*Y2Yc.yy) %*% sigma.w.inv |
|
| 903 |
# + sigma.j.inv - jYYj ) |
|
| 904 |
# tmp <- g.sigma.w*2; diag(tmp) <- diag(g.sigma.w) |
|
| 905 |
# G.sigma.w[cl,] <- lav_matrix_vech(tmp) |
|
| 906 | ||
| 907 |
# SIGMA.W (between part) |
|
| 908 | ! |
g.sigma.w1 <- sigma.j.inv - jYYj |
| 909 | ! |
tmp <- g.sigma.w1 * 2 |
| 910 | ! |
diag(tmp) <- diag(g.sigma.w1) |
| 911 | ! |
G.sigma.w1[cl, ] <- lav_matrix_vech(tmp) |
| 912 | ||
| 913 |
# SIGMA.B |
|
| 914 | ! |
g.sigma.b <- nj * (sigma.j.inv - jYYj) |
| 915 | ! |
tmp <- g.sigma.b * 2 |
| 916 | ! |
diag(tmp) <- diag(g.sigma.b) |
| 917 | ! |
G.sigma.b[cl, ] <- lav_matrix_vech(tmp) |
| 918 | ||
| 919 |
# BETA.W (between part only) |
|
| 920 | ! |
exo2.w <- cbind(1, Y2[cl, within.x.idx, drop = FALSE]) |
| 921 | ! |
tmp2 <- (-yc %*% sigma.j.inv + yc %*% sigma.w.inv) |
| 922 | ! |
G.beta.w1[cl, ] <- as.vector(2 * nj * crossprod(exo2.w, tmp2)) |
| 923 | ||
| 924 |
# BETA.B |
|
| 925 | ! |
exo2.b <- cbind(1, Y2[cl, between.x.idx, drop = FALSE]) |
| 926 | ! |
tmp <- -yc %*% sigma.j.inv |
| 927 | ! |
G.beta.b[cl, ] <- as.vector(2 * nj * crossprod(exo2.b, tmp)) |
| 928 |
} # cl |
|
| 929 |
} # no-between-y |
|
| 930 | ||
| 931 |
# beta.w (bis) |
|
| 932 | ||
| 933 |
# d.beta.w2 <- -2 * t(EXO.wb[,1:(length(within.x.idx) + 1L), drop = FALSE]) %*% Y1.wb.res %*% sigma.w.inv |
|
| 934 | ||
| 935 | ! |
Y1.wb.res.i <- Y1.wb.res %*% sigma.w.inv |
| 936 | ! |
w1.idx <- seq_len(length(within.x.idx) + 1L) |
| 937 | ! |
a1.idx <- rep(w1.idx, times = ncol(Y1.wb.res.i)) |
| 938 | ! |
b1.idx <- rep(seq_len(ncol(Y1.wb.res.i)), each = length(w1.idx)) |
| 939 | ! |
TMP <- EXO.wb[, a1.idx, drop = FALSE] * Y1.wb.res.i[, b1.idx, drop = FALSE] |
| 940 | ! |
G.beta.w2 <- -2 * rowsum.default(TMP, cluster.idx, |
| 941 | ! |
reorder = FALSE, |
| 942 | ! |
na.rm = TRUE |
| 943 |
) |
|
| 944 | ! |
G.beta.w <- G.beta.w1 + G.beta.w2 |
| 945 | ||
| 946 |
# Sigma.W (bis) |
|
| 947 |
# d.sigma.w2 <- sum(cluster.size - 1) * ( sigma.w.inv |
|
| 948 |
# - sigma.w.inv %*% S.PW %*% sigma.w.inv ) |
|
| 949 |
# tmp <- d.sigma.w2*2; diag(tmp) <- diag(d.sigma.w2) |
|
| 950 |
# d.sigma.w2 <- tmp |
|
| 951 | ||
| 952 |
# g.sigma.w2 <- ( (nj-1) * sigma.w.inv |
|
| 953 |
# - sigma.w.inv %*% (crossprod(Y1m) - nj*Y2Yc.yy) %*% sigma.w.inv ) |
|
| 954 | ||
| 955 | ! |
Y1a.res <- Y1.wb.res - Y2w.res[cluster.idx, , drop = FALSE] |
| 956 | ! |
Y1a.res.i <- Y1a.res %*% sigma.w.inv |
| 957 | ! |
idx1 <- lav_matrix_vech_col_idx(nrow(sigma.w)) |
| 958 | ! |
idx2 <- lav_matrix_vech_row_idx(nrow(sigma.w)) |
| 959 | ! |
SW2 <- matrix(lav_matrix_vech(sigma.w.inv), |
| 960 | ! |
nrow = nclusters, |
| 961 | ! |
length(lav_matrix_vech(sigma.w.inv)), byrow = TRUE |
| 962 |
) |
|
| 963 | ! |
SW2 <- SW2 * (cluster.size - 1) |
| 964 | ! |
TMP <- Y1a.res.i[, idx1, drop = FALSE] * Y1a.res.i[, idx2, drop = FALSE] |
| 965 | ! |
TMP2 <- rowsum.default(TMP, cluster.idx, reorder = FALSE, na.rm = TRUE) |
| 966 | ! |
G.sigma.w2 <- 2 * (SW2 - TMP2) |
| 967 | ! |
diagh.idx <- lav_matrix_diagh_idx(nrow(sigma.w)) |
| 968 | ! |
G.sigma.w2[, diagh.idx] <- G.sigma.w2[, diagh.idx, drop = FALSE] / 2 |
| 969 | ! |
G.sigma.w <- G.sigma.w1 + G.sigma.w2 |
| 970 | ||
| 971 | ||
| 972 | ||
| 973 |
# rearrange columns to Res.Int.W, Res.Pi.W, Res.Sigma.W, |
|
| 974 |
# Res.Int.B, Res.Pi.B, Res.Sigma.B |
|
| 975 | ||
| 976 |
# ov.idx per level |
|
| 977 | ! |
ov.idx <- Lp$ov.idx |
| 978 | ||
| 979 |
# 'tilde' matrices: ALL variables within and between |
|
| 980 | ! |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 981 | ! |
p.tilde.star <- p.tilde * (p.tilde + 1) / 2 |
| 982 | ! |
B.tilde <- lav_matrix_vech_reverse(seq_len(p.tilde.star)) |
| 983 | ||
| 984 |
# only 'y' |
|
| 985 | ! |
ov.y.idx <- Lp$ov.y.idx |
| 986 | ||
| 987 |
# two levels only (for now) |
|
| 988 | ! |
ov.y.idx1 <- ov.y.idx[[1]] |
| 989 | ! |
ov.y.idx2 <- ov.y.idx[[2]] |
| 990 | ||
| 991 |
# WITHIN (is easy) |
|
| 992 | ! |
BETA.W.idx <- matrix(seq_len(length(beta.w)), nrow(beta.w), ncol(beta.w)) |
| 993 | ! |
BETA.B.idx <- matrix(seq_len(length(beta.b)), nrow(beta.b), ncol(beta.b)) |
| 994 | ||
| 995 | ! |
Res.Int.W <- G.beta.w[, BETA.W.idx[1L, ], drop = FALSE] |
| 996 | ! |
Res.Pi.W <- G.beta.w[, lav_matrix_vecr(BETA.W.idx[-1L, ]), drop = FALSE] |
| 997 | ! |
Res.Sigma.W <- G.sigma.w |
| 998 | ||
| 999 |
# Sigma.B |
|
| 1000 | ! |
Sigma.B.tilde <- matrix(0, nclusters, p.tilde.star) |
| 1001 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.y.idx1, ov.y.idx1, drop = FALSE]) |
| 1002 | ! |
Sigma.B.tilde[, col.idx] <- G.sigma.b |
| 1003 | ||
| 1004 |
# Int.B |
|
| 1005 | ! |
BETA.B.tilde <- matrix(seq_len(nrow(beta.b) * p.tilde), nrow(beta.b), p.tilde) |
| 1006 | ! |
Int.B <- matrix(0, nclusters, p.tilde) |
| 1007 | ! |
Int.B[, ov.y.idx1] <- G.beta.b[, BETA.B.idx[1L, ]] |
| 1008 | ||
| 1009 |
# Pi.B |
|
| 1010 | ! |
Pi.B <- matrix(0, nclusters, p.tilde * (nrow(beta.b) - 1L)) |
| 1011 | ! |
col.idx <- lav_matrix_vecr(BETA.B.tilde[-1L, ov.y.idx1, drop = FALSE]) |
| 1012 | ! |
Pi.B[, col.idx] <- G.beta.b[, lav_matrix_vecr(BETA.B.idx[-1L, ]), drop = FALSE] |
| 1013 | ||
| 1014 | ! |
if (length(between.y.idx) > 0L) {
|
| 1015 |
# Sigma.B: add yz/zz parts |
|
| 1016 | ! |
col.idx <- lav_matrix_vec(B.tilde[ov.y.idx1, between.y.idx, drop = FALSE]) |
| 1017 | ! |
Sigma.B.tilde[, col.idx] <- G.sigma.yz |
| 1018 | ! |
col.idx <- lav_matrix_vech(B.tilde[between.y.idx, between.y.idx, |
| 1019 | ! |
drop = FALSE |
| 1020 |
]) |
|
| 1021 | ! |
Sigma.B.tilde[, col.idx] <- G.sigma.zz |
| 1022 | ||
| 1023 |
# Int.B: add z-part |
|
| 1024 | ! |
BETA.Z.idx <- matrix(seq_len(length(beta.z)), nrow(beta.z), ncol(beta.z)) |
| 1025 | ! |
Int.B[, between.y.idx] <- G.beta.z[, BETA.Z.idx[1L, ], drop = FALSE] |
| 1026 | ||
| 1027 |
# Pi.B: add beta.z |
|
| 1028 | ! |
col.idx <- lav_matrix_vecr(BETA.B.tilde[-1L, between.y.idx, drop = FALSE]) |
| 1029 | ! |
Pi.B[, col.idx] <- |
| 1030 | ! |
G.beta.z[, lav_matrix_vecr(BETA.Z.idx[-1L, ]), drop = FALSE] |
| 1031 |
} |
|
| 1032 | ||
| 1033 |
# only extract ov.y.idx2 for BETWEEN |
|
| 1034 | ! |
col.idx <- lav_matrix_vech(B.tilde[ov.y.idx2, ov.y.idx2, drop = FALSE]) |
| 1035 | ! |
Res.Sigma.B <- Sigma.B.tilde[, col.idx, drop = FALSE] |
| 1036 | ||
| 1037 | ! |
Res.Int.B <- Int.B[, ov.y.idx2, drop = FALSE] |
| 1038 | ||
| 1039 | ! |
col.idx <- lav_matrix_vecr(BETA.B.tilde[-1, ov.y.idx2]) |
| 1040 | ! |
Res.Pi.B <- Pi.B[, col.idx, drop = FALSE] |
| 1041 | ||
| 1042 | ! |
SCORES <- cbind( |
| 1043 | ! |
Res.Int.W, Res.Pi.W, Res.Sigma.W, |
| 1044 | ! |
Res.Int.B, Res.Pi.B, Res.Sigma.B |
| 1045 |
) |
|
| 1046 | ||
| 1047 | ! |
SCORES |
| 1048 |
} |
|
| 1049 | ||
| 1050 |
# first-order information: outer crossprod of scores per cluster |
|
| 1051 |
lav_mvreg_cluster_information_firstorder <- function(Y1 = NULL, |
|
| 1052 |
YLp = NULL, |
|
| 1053 |
Lp = NULL, |
|
| 1054 |
Res.Sigma.W = NULL, |
|
| 1055 |
Res.Int.W = NULL, |
|
| 1056 |
Res.Pi.W = NULL, |
|
| 1057 |
Res.Sigma.B = NULL, |
|
| 1058 |
Res.Int.B = NULL, |
|
| 1059 |
Res.Pi.B = NULL, |
|
| 1060 |
divide.by.two = FALSE, |
|
| 1061 |
Sinv.method = "eigen") {
|
|
| 1062 | ! |
N <- NROW(Y1) |
| 1063 | ||
| 1064 | ! |
SCORES <- lav_mvreg_cluster_scores_2l( |
| 1065 | ! |
Y1 = Y1, |
| 1066 | ! |
YLp = YLp, |
| 1067 | ! |
Lp = Lp, |
| 1068 | ! |
Res.Sigma.W = Res.Sigma.W, |
| 1069 | ! |
Res.Int.W = Res.Int.W, |
| 1070 | ! |
Res.Pi.W = Res.Pi.W, |
| 1071 | ! |
Res.Sigma.B = Res.Sigma.B, |
| 1072 | ! |
Res.Int.B = Res.Int.B, |
| 1073 | ! |
Res.Pi.B = Res.Pi.B, |
| 1074 | ! |
Sinv.method = Sinv.method |
| 1075 |
) |
|
| 1076 | ||
| 1077 |
# divide by 2 (if we want scores wrt objective function) |
|
| 1078 | ! |
if (divide.by.two) {
|
| 1079 | ! |
SCORES <- SCORES / 2 |
| 1080 |
} |
|
| 1081 | ||
| 1082 |
# unit information |
|
| 1083 | ! |
information <- crossprod(SCORES) / Lp$nclusters[[2]] |
| 1084 | ||
| 1085 | ! |
information |
| 1086 |
} |
| 1 |
# here, we generate new models based on the original model in lavobject |
|
| 2 |
# 1. the independence model |
|
| 3 |
# 2. the unrestricted model |
|
| 4 |
# 3. model + extra parameters (for modindices/lavTestScore) |
|
| 5 |
# 4. catML fit based on DWLS fit (for robust RMSEA/CFI) |
|
| 6 | ||
| 7 | ||
| 8 |
# 1. fit an 'independence/baseline' model |
|
| 9 |
# note that for ML (and ULS and DWLS), the 'estimates' of the |
|
| 10 |
# independence model are simply the observed variances |
|
| 11 |
# but for GLS and WLS, this is not the case!! |
|
| 12 |
# |
|
| 13 |
# - YR 01 Feb 2026: allow for baseline.type = "nested" |
|
| 14 |
lav_object_independence <- lav_object_baseline <- function(object = NULL, |
|
| 15 |
# or |
|
| 16 |
lavsamplestats = NULL, |
|
| 17 |
lavdata = NULL, |
|
| 18 |
lavcache = NULL, |
|
| 19 |
lavoptions = NULL, |
|
| 20 |
lavpartable = NULL, |
|
| 21 |
lavh1 = NULL, |
|
| 22 |
# local options |
|
| 23 |
se = FALSE) {
|
|
| 24 |
# object or slots? |
|
| 25 | 61x |
if (!is.null(object)) {
|
| 26 | 16x |
stopifnot(inherits(object, "lavaan")) |
| 27 | 16x |
object <- lav_object_check_version(object) |
| 28 | ||
| 29 |
# extract needed slots |
|
| 30 | 16x |
lavsamplestats <- object@SampleStats |
| 31 | 16x |
lavdata <- object@Data |
| 32 | 16x |
lavcache <- object@Cache |
| 33 | 16x |
lavoptions <- object@Options |
| 34 | 16x |
lavpartable <- object@ParTable |
| 35 | 16x |
lavpta <- object@pta |
| 36 | 16x |
lavh1 <- object@h1 |
| 37 | 16x |
if (is.null(lavoptions$estimator.args)) {
|
| 38 | ! |
lavoptions$estimator.args <- list() |
| 39 |
} |
|
| 40 |
} else {
|
|
| 41 | 45x |
lavpta <- lav_partable_attributes(lavpartable) |
| 42 | 45x |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 43 |
} |
|
| 44 | ||
| 45 |
# if two-level, force conditional.x = FALSE (for now) |
|
| 46 | 61x |
if (lavdata@nlevels > 1L && lavoptions$conditional.x) {
|
| 47 | ! |
lavoptions$conditional.x <- FALSE |
| 48 |
} |
|
| 49 | ||
| 50 |
# construct parameter table for independence model |
|
| 51 | 61x |
if (!is.null(lavoptions$baseline.type) && |
| 52 | 61x |
lavoptions$baseline.type == "nested") {
|
| 53 | ! |
lavpartable <- lav_partable_baseline( |
| 54 | ! |
lavobject = NULL, |
| 55 | ! |
lavpartable = lavpartable, lavh1 = lavh1 |
| 56 |
) |
|
| 57 |
} else {
|
|
| 58 | 61x |
lavpartable <- lav_partable_indep_or_unrestricted( |
| 59 | 61x |
lavobject = NULL, |
| 60 | 61x |
lavdata = lavdata, lavpta = lavpta, lavoptions = lavoptions, |
| 61 | 61x |
lavsamplestats = lavsamplestats, lavh1 = lavh1, independent = TRUE |
| 62 |
) |
|
| 63 |
} |
|
| 64 | ||
| 65 |
# new in 0.6-6: add lower bounds for ov.var |
|
| 66 | 61x |
if (!is.null(lavoptions$optim.bounds)) {
|
| 67 | 61x |
lavoptions$bounds <- "doe.maar" |
| 68 | 61x |
lavoptions$effect.coding <- "" # to avoid warning |
| 69 | 61x |
lavoptions$optim.bounds <- list(lower = "ov.var") |
| 70 | 61x |
lavpartable <- lav_partable_add_bounds( |
| 71 | 61x |
partable = lavpartable, |
| 72 | 61x |
lavh1 = lavh1, lavdata = lavdata, |
| 73 | 61x |
lavsamplestats = lavsamplestats, lavoptions = lavoptions |
| 74 |
) |
|
| 75 |
} |
|
| 76 | ||
| 77 |
# new in 0.6-8: if DLS, change to sample-based |
|
| 78 | 61x |
if (lavoptions$estimator == "DLS") {
|
| 79 | ! |
if (lavoptions$estimator.args$dls.GammaNT == "sample") {
|
| 80 |
# nothing to do |
|
| 81 |
} else {
|
|
| 82 | ! |
lavoptions$estimator.args$dls.GammaNT <- "sample" |
| 83 | ! |
dls.a <- lavoptions$estimator.args$dls.a |
| 84 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 85 | ! |
GammaNT <- lav_samplestats_Gamma_NT( |
| 86 | ! |
COV = lavsamplestats@cov[[g]], |
| 87 | ! |
MEAN = lavsamplestats@mean[[g]], |
| 88 | ! |
rescale = FALSE, |
| 89 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 90 | ! |
fixed.x = lavoptions$fixed.x, |
| 91 | ! |
conditional.x = lavoptions$conditional.x, |
| 92 | ! |
meanstructure = lavoptions$meanstructure, |
| 93 | ! |
slopestructure = lavoptions$conditional.x |
| 94 |
) |
|
| 95 | ! |
W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT |
| 96 |
# overwrite |
|
| 97 | ! |
lavsamplestats@WLS.V[[g]] <- lav_matrix_symmetric_inverse(W.DLS) |
| 98 |
} |
|
| 99 |
} |
|
| 100 |
} |
|
| 101 | ||
| 102 |
# se |
|
| 103 | 61x |
if (se) {
|
| 104 | ! |
if (lavoptions$se == "none") {
|
| 105 | ! |
lavoptions$se <- "standard" |
| 106 |
} |
|
| 107 |
} else {
|
|
| 108 |
# 0.6-18: slower, but safer to just keep it |
|
| 109 | ||
| 110 |
# 0.6-20 -- except if se = "bootstrap" -> "none" |
|
| 111 | 61x |
if (lavoptions$se == "bootstrap") {
|
| 112 | 1x |
lavoptions$se <- "none" |
| 113 |
} |
|
| 114 | ||
| 115 |
## FIXME: if test = scaled, we need it anyway? |
|
| 116 |
# if(lavoptions$missing %in% c("two.stage", "two.stage.robust")) {
|
|
| 117 |
# don't touch it |
|
| 118 |
# } else {
|
|
| 119 |
# lavoptions$se <- "none" |
|
| 120 |
# } |
|
| 121 |
} |
|
| 122 | ||
| 123 |
# change options |
|
| 124 | 61x |
lavoptions$h1 <- FALSE # already provided by lavh1 |
| 125 | 61x |
lavoptions$baseline <- FALSE # of course |
| 126 | 61x |
lavoptions$loglik <- TRUE # eg for multilevel |
| 127 | 61x |
lavoptions$implied <- TRUE # needed for loglik (multilevel) |
| 128 | 61x |
lavoptions$check.start <- FALSE |
| 129 | 61x |
lavoptions$check.gradient <- FALSE |
| 130 | 61x |
lavoptions$check.post <- FALSE |
| 131 | 61x |
lavoptions$check.vcov <- FALSE |
| 132 | 61x |
lavoptions$optim.bounds <- list() # we already have the bounds |
| 133 | 61x |
lavoptions$start <- "default" # don't re-use user-specified starting values |
| 134 | 61x |
lavoptions$rstarts <- 0L # no random starts |
| 135 | ||
| 136 |
# ALWAYS do.fit and set optim.method = "nlminb" (if npar > 0) |
|
| 137 | 61x |
npar <- lav_partable_npar(lavpartable) |
| 138 | 61x |
if (npar > 0L) {
|
| 139 | 61x |
lavoptions$do.fit <- TRUE |
| 140 | 61x |
if(lavoptions$optim.method != "noniter") {
|
| 141 | 61x |
lavoptions$optim.method <- "nlminb" |
| 142 |
} |
|
| 143 |
} else {
|
|
| 144 |
# perhaps a correlation structure? |
|
| 145 | ! |
lavoptions$optim.method <- "none" |
| 146 | ! |
lavoptions$optim.force.converged <- TRUE |
| 147 |
} |
|
| 148 | ||
| 149 |
# needed? |
|
| 150 | 39x |
if (any(lavpartable$op == "~1")) lavoptions$meanstructure <- TRUE |
| 151 | ||
| 152 |
# FIXME: it is crucial that the order of the ov's, as returned by |
|
| 153 |
# lav_object_vnames() remains the same |
|
| 154 |
# so lav_object_vnames(object) should equal lav_object_vnames(lavpartable) |
|
| 155 |
# otherwise, we will use the wrong sample statistics!!! |
|
| 156 |
# |
|
| 157 |
# this seems ok now, because we first generate the covariances in |
|
| 158 |
# lavpartable, and they should be in the right order (unlike the |
|
| 159 |
# intercepts) |
|
| 160 | ||
| 161 | 61x |
FIT <- lavaan(lavpartable, |
| 162 | 61x |
slotOptions = lavoptions, |
| 163 | 61x |
slotSampleStats = lavsamplestats, |
| 164 | 61x |
slotData = lavdata, |
| 165 | 61x |
slotCache = lavcache, |
| 166 | 61x |
sloth1 = lavh1 |
| 167 |
) |
|
| 168 | ||
| 169 | 61x |
FIT |
| 170 |
} |
|
| 171 | ||
| 172 | ||
| 173 |
# 2. unrestricted model |
|
| 174 |
lav_object_unrestricted <- function(object, se = FALSE) {
|
|
| 175 | ! |
object <- lav_object_check_version(object) |
| 176 |
# construct parameter table for unrestricted model |
|
| 177 | ! |
lavpartable <- lav_partable_unrestricted(object) |
| 178 | ||
| 179 |
# adapt options |
|
| 180 | ! |
lavoptions <- object@Options |
| 181 | ||
| 182 |
# se |
|
| 183 | ! |
if (se) {
|
| 184 | ! |
if (lavoptions$se == "none") {
|
| 185 | ! |
lavoptions$se <- "standard" |
| 186 |
} |
|
| 187 |
} else {
|
|
| 188 |
## FIXME: if test = scaled, we need it anyway? |
|
| 189 | ! |
lavoptions$se <- "none" |
| 190 |
} |
|
| 191 | ||
| 192 |
# ALWAYS do.fit |
|
| 193 | ! |
lavoptions$do.fit <- TRUE |
| 194 | ||
| 195 |
# needed? |
|
| 196 | ! |
if (any(lavpartable$op == "~1")) lavoptions$meanstructure <- TRUE |
| 197 | ||
| 198 | ! |
lavh1 <- object@h1 |
| 199 | ||
| 200 | ! |
FIT <- lavaan(lavpartable, |
| 201 | ! |
slotOptions = lavoptions, |
| 202 | ! |
slotSampleStats = object@SampleStats, |
| 203 | ! |
slotData = object@Data, |
| 204 | ! |
slotCache = object@Cache, |
| 205 | ! |
sloth1 = lavh1 |
| 206 |
) |
|
| 207 | ||
| 208 | ! |
FIT |
| 209 |
} |
|
| 210 | ||
| 211 | ||
| 212 |
# 3. extended model (used for modification indices) |
|
| 213 |
lav_object_extended <- function(object, add = NULL, |
|
| 214 |
remove.duplicated = TRUE, |
|
| 215 |
all.free = FALSE, |
|
| 216 |
do.fit = FALSE) {
|
|
| 217 | ! |
object <- lav_object_check_version(object) |
| 218 |
# partable original model |
|
| 219 | ! |
partable <- object@ParTable[c( |
| 220 | ! |
"lhs", "op", "rhs", "free", "exo", "label", |
| 221 | ! |
"plabel" |
| 222 |
)] |
|
| 223 | ||
| 224 |
# new in 0.6-3: check for non-parameters |
|
| 225 | ! |
nonpar.idx <- which(partable$op %in% c("==", ":=", "<", ">"))
|
| 226 | ||
| 227 |
# always add block/group/level |
|
| 228 | ! |
if (!is.null(object@ParTable$group)) {
|
| 229 | ! |
partable$group <- object@ParTable$group |
| 230 |
} else {
|
|
| 231 | ! |
partable$group <- rep(1L, length(partable$lhs)) |
| 232 | ! |
if (length(nonpar.idx) > 0L) {
|
| 233 | ! |
partable$group[nonpar.idx] <- 0L |
| 234 |
} |
|
| 235 |
} |
|
| 236 | ! |
if (!is.null(object@ParTable$level)) {
|
| 237 | ! |
partable$level <- object@ParTable$level |
| 238 |
} else {
|
|
| 239 | ! |
partable$level <- rep(1L, length(partable$lhs)) |
| 240 | ! |
if (length(nonpar.idx) > 0L) {
|
| 241 | ! |
partable$level[nonpar.idx] <- 0L |
| 242 |
} |
|
| 243 |
} |
|
| 244 | ! |
if (!is.null(object@ParTable$block)) {
|
| 245 | ! |
partable$block <- object@ParTable$block |
| 246 |
} else {
|
|
| 247 | ! |
partable$block <- rep(1L, length(partable$lhs)) |
| 248 | ! |
if (length(nonpar.idx) > 0L) {
|
| 249 | ! |
partable$block[nonpar.idx] <- 0L |
| 250 |
} |
|
| 251 |
} |
|
| 252 | ||
| 253 |
# TDJ: Added to prevent error when lav_partable_merge() is called below. |
|
| 254 |
# Problematic if object@ParTable is missing one of the requested slots, |
|
| 255 |
# which returns a NULL slot with a missing <NA> name. For example: |
|
| 256 |
# example(cfa) |
|
| 257 |
# lav_partable_independence(lavdata = fit@Data, lavpta = fit@pta, |
|
| 258 |
# lavoptions = lavInspect(fit, "options")) |
|
| 259 |
# Has no "label" or "plabel" elements. |
|
| 260 | ! |
empties <- which(sapply(partable, is.null)) |
| 261 | ! |
if (length(empties)) {
|
| 262 | ! |
partable[empties] <- NULL |
| 263 |
} |
|
| 264 | ||
| 265 | ! |
if (all.free) {
|
| 266 | ! |
partable$user <- rep(1L, length(partable$lhs)) |
| 267 | ! |
non.free.idx <- which(partable$free == 0L & partable$op != "==" & |
| 268 | ! |
partable$op != ":=" & partable$op != "<" & |
| 269 | ! |
partable$op != ">") |
| 270 | ! |
partable$free[non.free.idx] <- 1L |
| 271 | ! |
partable$user[non.free.idx] <- 10L |
| 272 |
} |
|
| 273 | ||
| 274 |
# replace 'start' column, since lav_model will fill these in in GLIST |
|
| 275 | ! |
partable$start <- lavParameterEstimates(object, |
| 276 | ! |
remove.system.eq = FALSE, |
| 277 | ! |
remove.def = FALSE, |
| 278 | ! |
remove.eq = FALSE, |
| 279 | ! |
remove.ineq = FALSE, |
| 280 | ! |
remove.nonfree = FALSE, |
| 281 | ! |
remove.unused = FALSE |
| 282 | ! |
)$est |
| 283 | ||
| 284 |
# add new parameters, extend model |
|
| 285 | ! |
if (is.list(add)) {
|
| 286 | ! |
stopifnot( |
| 287 | ! |
!is.null(add$lhs), |
| 288 | ! |
!is.null(add$op), |
| 289 | ! |
!is.null(add$rhs) |
| 290 |
) |
|
| 291 | ! |
ADD <- add |
| 292 | ! |
} else if (is.character(add)) {
|
| 293 | ! |
ngroups <- lav_partable_ngroups(partable) |
| 294 | ! |
ADD.orig <- lav_model_partable(add, ngroups = ngroups) |
| 295 | ! |
ADD <- ADD.orig[, c("lhs", "op", "rhs", "user", "label")] # minimum
|
| 296 | ||
| 297 |
# always add block/group/level |
|
| 298 | ! |
if (!is.null(ADD.orig$group)) {
|
| 299 | ! |
ADD$group <- ADD.orig$group |
| 300 |
} else {
|
|
| 301 | ! |
ADD$group <- rep(1L, length(ADD$lhs)) |
| 302 |
} |
|
| 303 | ! |
if (!is.null(ADD.orig$level)) {
|
| 304 | ! |
ADD$level <- ADD.orig$level |
| 305 |
} else {
|
|
| 306 | ! |
ADD$level <- rep(1L, length(ADD$lhs)) |
| 307 |
} |
|
| 308 | ! |
if (!is.null(ADD.orig$block)) {
|
| 309 | ! |
ADD$block <- ADD.orig$block |
| 310 |
} else {
|
|
| 311 | ! |
ADD$block <- rep(1L, length(ADD$lhs)) |
| 312 |
} |
|
| 313 | ||
| 314 | ! |
remove.idx <- which(ADD$user == 0) |
| 315 | ! |
if (length(remove.idx) > 0L) {
|
| 316 | ! |
ADD <- ADD[-remove.idx, ] |
| 317 |
} |
|
| 318 | ! |
ADD$start <- rep(0, nrow(ADD)) |
| 319 | ! |
ADD$free <- rep(1, nrow(ADD)) |
| 320 | ! |
ADD$user <- rep(10, nrow(ADD)) |
| 321 |
} |
|
| 322 | ||
| 323 |
# merge |
|
| 324 | ! |
LIST <- lav_partable_merge(partable, ADD, |
| 325 | ! |
remove.duplicated = remove.duplicated, |
| 326 | ! |
warn = FALSE |
| 327 |
) |
|
| 328 | ||
| 329 |
# remove nonpar? |
|
| 330 |
# if(remove.nonpar) {
|
|
| 331 |
# nonpar.idx <- which(LIST$op %in% c("==", ":=", "<", ">"))
|
|
| 332 |
# if(length(nonpar.idx) > 0L) {
|
|
| 333 |
# LIST <- LIST[-nonpar.idx,] |
|
| 334 |
# } |
|
| 335 |
# } |
|
| 336 | ||
| 337 |
# redo 'free' |
|
| 338 | ! |
free.idx <- which(LIST$free > 0) |
| 339 | ! |
LIST$free[free.idx] <- 1:length(free.idx) |
| 340 | ||
| 341 |
# adapt options |
|
| 342 | ! |
lavoptions <- object@Options |
| 343 | ||
| 344 |
# do.fit? |
|
| 345 | ! |
lavoptions$do.fit <- do.fit |
| 346 | ||
| 347 |
# needed? |
|
| 348 | ! |
if (any(LIST$op == "~1")) lavoptions$meanstructure <- TRUE |
| 349 | ||
| 350 |
# switch off 'consider switching to parameterization = theta' warning |
|
| 351 |
# (modindices!) |
|
| 352 | ! |
lavoptions$check.delta.cat.mediator <- FALSE |
| 353 | ||
| 354 | ! |
FIT <- lavaan(LIST, |
| 355 | ! |
slotOptions = lavoptions, |
| 356 | ! |
slotSampleStats = object@SampleStats, |
| 357 | ! |
slotData = object@Data, |
| 358 | ! |
slotCache = object@Cache, |
| 359 | ! |
sloth1 = object@h1 |
| 360 |
) |
|
| 361 | ||
| 362 | ! |
FIT |
| 363 |
} |
|
| 364 | ||
| 365 |
# 4. catml model |
|
| 366 |
lav_object_catml <- function(lavobject = NULL) {
|
|
| 367 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 368 | ! |
stopifnot(lavobject@Model@categorical) |
| 369 | ||
| 370 |
# extract slots |
|
| 371 | ! |
lavdata <- lavobject@Data |
| 372 | ! |
lavsamplestats <- lavobject@SampleStats |
| 373 | ! |
lavoptions <- lavobject@Options |
| 374 | ! |
lavpta <- lavobject@pta |
| 375 | ||
| 376 |
# if only categorical variables: remove thresholds and intercepts |
|
| 377 | ! |
refit <- FALSE |
| 378 | ! |
partable.catml <- parTable(lavobject) |
| 379 | ! |
rm.idx <- which(partable.catml$op %in% c("|", "~1"))
|
| 380 |
# remove also any constraints that refer to the labels that belong |
|
| 381 |
# to these intercepts/thresholds (new in 0.6-20) |
|
| 382 | ! |
th.int.labels <- unique( |
| 383 | ! |
partable.catml$label[rm.idx], |
| 384 | ! |
partable.catml$plabel[rm.idx] |
| 385 |
) |
|
| 386 | ! |
if (any(nchar(th.int.labels) == 0L)) {
|
| 387 | ! |
th.int.labels <- th.int.labels[-which(nchar(th.int.labels) == 0L)] |
| 388 |
} |
|
| 389 | ! |
con.idx <- which(partable.catml$op %in% c("==", "<", ">", ":=") &
|
| 390 | ! |
(partable.catml$lhs %in% th.int.labels | |
| 391 | ! |
partable.catml$rhs %in% th.int.labels)) |
| 392 | ! |
partable.catml <- partable.catml[-c(rm.idx, con.idx), ] |
| 393 |
# never rotate (new in 0.6-19), as we only need fit measures |
|
| 394 | ! |
if (!is.null(partable.catml$efa)) {
|
| 395 | ! |
partable.catml$efa <- NULL |
| 396 | ! |
partable.catml$free <- partable.catml$free.unrotated |
| 397 |
} |
|
| 398 | ||
| 399 | ! |
if (!all(lavdata@ov$type == "ordered")) {
|
| 400 | ! |
refit <- TRUE |
| 401 | ! |
partable.catml$start <- partable.catml$est |
| 402 | ! |
partable.catml$se <- NULL |
| 403 | ! |
partable.catml$ustart <- partable.catml$est |
| 404 | ! |
for (b in seq_len(lavpta$nblocks)) {
|
| 405 | ! |
ov.names.num <- lavpta$vnames$ov.num[[b]] |
| 406 | ! |
ov.var.idx <- which(partable.catml$op == "~~" & |
| 407 | ! |
partable.catml$lhs %in% ov.names.num & |
| 408 | ! |
partable.catml$lhs == partable.catml$rhs) |
| 409 | ! |
partable.catml$free[ov.var.idx] <- 0L |
| 410 |
} |
|
| 411 |
} |
|
| 412 | ! |
partable.catml <- lav_partable_complete(partable.catml) |
| 413 | ||
| 414 |
# adapt lavsamplestats |
|
| 415 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 416 | ! |
lavsamplestats@WLS.V[[g]] <- NULL |
| 417 | ! |
lavsamplestats@WLS.VD[[g]] <- NULL |
| 418 | ! |
COR <- lavsamplestats@cov[[g]] |
| 419 |
# check if COV is pd or not |
|
| 420 | ! |
ev <- eigen(COR, symmetric = TRUE, only.values = TRUE)$values |
| 421 | ! |
if (any(ev < .Machine$double.eps^(1 / 2))) {
|
| 422 |
# not PD! |
|
| 423 | ! |
COV <- cov2cor(lav_matrix_symmetric_force_pd(COR, tol = 1e-04)) |
| 424 | ! |
lavsamplestats@cov[[g]] <- COV |
| 425 | ! |
lavsamplestats@var[[g]] <- diag(COV) |
| 426 | ! |
refit <- TRUE |
| 427 |
} else {
|
|
| 428 | ! |
COV <- COR |
| 429 |
} |
|
| 430 | ||
| 431 | ! |
current.warn <- lav_warn() |
| 432 | ! |
if (lav_warn(FALSE)) {
|
| 433 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 434 |
} |
|
| 435 | ! |
out <- lav_samplestats_icov( |
| 436 | ! |
COV = COV, ridge = 1e-05, |
| 437 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 438 | ! |
ngroups = lavdata@ngroups, g = g |
| 439 |
) |
|
| 440 | ! |
lav_warn(current.warn) |
| 441 | ! |
lavsamplestats@icov[[g]] <- out$icov |
| 442 | ! |
lavsamplestats@cov.log.det[[g]] <- out$cov.log.det |
| 443 | ||
| 444 |
# NACOV <- lavsamplestats@NACOV[[g]] |
|
| 445 |
# nvar <- nrow(COV) |
|
| 446 |
# ntotal <- nrow(NACOV) |
|
| 447 |
# pstar <- nvar*(nvar-1)/2 |
|
| 448 |
# nocor <- ntotal - pstar |
|
| 449 |
# if(length(nocor) > 0L) {
|
|
| 450 |
# lavsamplestats@NACOV[[g]] <- NACOV[-seq_len(nocor), |
|
| 451 |
# -seq_len(nocor)] |
|
| 452 |
# } |
|
| 453 |
} |
|
| 454 | ||
| 455 |
# adapt lavoptions |
|
| 456 | ! |
lavoptions$estimator <- "catML" |
| 457 | ! |
lavoptions$.categorical <- FALSE |
| 458 | ! |
lavoptions$categorical <- FALSE |
| 459 | ! |
lavoptions$correlation <- TRUE |
| 460 | ! |
lavoptions$meanstructure <- FALSE |
| 461 | ! |
lavoptions$conditional.x <- FALSE # fixme |
| 462 | ! |
lavoptions$information <- c("expected", "expected")
|
| 463 | ! |
lavoptions$h1.information <- c("structured", "structured") # unlike DWLS
|
| 464 | ! |
lavoptions$se <- "none" |
| 465 | ! |
lavoptions$test <- "standard" # always for now |
| 466 | ! |
lavoptions$rotation <- "none" # new in 0.6-19 |
| 467 | ! |
lavoptions$baseline <- TRUE # also for RMSEA? |
| 468 | ! |
if (!refit) {
|
| 469 | ! |
lavoptions$optim.method <- "none" |
| 470 | ! |
lavoptions$optim.force.converged <- TRUE |
| 471 |
} else {
|
|
| 472 | ! |
lavoptions$optim.gradient <- "numerical" |
| 473 |
} |
|
| 474 | ||
| 475 |
# dummy fit |
|
| 476 | ! |
FIT <- lavaan( |
| 477 | ! |
slotParTable = partable.catml, |
| 478 | ! |
slotSampleStats = lavsamplestats, |
| 479 | ! |
slotData = lavdata, |
| 480 | ! |
slotOptions = lavoptions |
| 481 |
) |
|
| 482 | ||
| 483 | ! |
FIT |
| 484 |
} |
| 1 |
# YR 11 feb 2017: initial version |
|
| 2 | ||
| 3 |
# given a parameter table (PT), extract a part of the model: |
|
| 4 |
# eg.: |
|
| 5 |
# - only the measurement model (with saturated latent variables) |
|
| 6 |
# - only the stuctural part |
|
| 7 |
# - a single measurement block |
|
| 8 |
# ... |
|
| 9 | ||
| 10 |
# YR 25 June 2021: - add.exo.cov = TRUE for structural model |
|
| 11 |
# - fixed.x = FALSE/TRUE -> exo flags |
|
| 12 | ||
| 13 | ||
| 14 |
# FIXME: |
|
| 15 |
# - but fixed-to-zero covariances may not be present in PT... |
|
| 16 |
# - if indicators are regressed on exogenous covariates, should we |
|
| 17 |
# add them here? (no for now, unless add.ind.predictors = TRUE) |
|
| 18 |
# - new in 0.6-20: - check for 2nd, 3rd order lv.names... |
|
| 19 |
# - allow for conditional.x (global SAM) |
|
| 20 |
lav_partable_subset_measurement_model <- function(PT = NULL, |
|
| 21 |
lv.names = NULL, |
|
| 22 |
add.lv.cov = TRUE, |
|
| 23 |
add.ind.predictors = FALSE, |
|
| 24 |
add.idx = FALSE, |
|
| 25 |
idx.only = FALSE) {
|
|
| 26 |
# PT |
|
| 27 | ! |
PT <- as.data.frame(PT, stringsAsFactors = FALSE) |
| 28 | ||
| 29 |
# check if we have free.unrotated column (rotation!) |
|
| 30 | ! |
if (!is.null(PT$free.unrotated)) {
|
| 31 | ! |
PT$free.orig <- PT$free |
| 32 | ! |
PT$free <- PT$free.unrotated |
| 33 | ! |
PT$est.unrotated <- NULL |
| 34 | ! |
PT$free.unrotated <- NULL |
| 35 | ! |
PT$est.std <- NULL |
| 36 |
} |
|
| 37 | ||
| 38 |
# lavpta |
|
| 39 | ! |
lavpta <- lav_partable_attributes(PT) |
| 40 | ||
| 41 |
# nblocks |
|
| 42 | ! |
nblocks <- lavpta$nblocks |
| 43 | ! |
block.values <- lav_partable_block_values(PT) |
| 44 | ||
| 45 |
# lv.names: list with element per block |
|
| 46 | ! |
if (is.null(lv.names)) {
|
| 47 | ! |
lv.names <- lavpta$vnames$lv.regular |
| 48 | ! |
} else if (!is.list(lv.names)) {
|
| 49 | ! |
lv.names <- rep(list(lv.names), nblocks) |
| 50 |
} |
|
| 51 | ||
| 52 |
# if lv.names contains a higher-order latent variable, |
|
| 53 |
# add its (latent) indicators |
|
| 54 | ! |
for (g in 1:nblocks) {
|
| 55 | ! |
if (length(lavpta$vnames$lv.ind[[g]]) == 0L) {
|
| 56 | ! |
next |
| 57 |
} |
|
| 58 |
# ALL lv names |
|
| 59 | ! |
LV.names <- lavpta$vnames$lv[[g]] |
| 60 | ||
| 61 |
# lv.names in this block |
|
| 62 | ! |
this.lv <- lv.names[[g]] |
| 63 | ||
| 64 | ! |
all.ind.are.observed.flag <- FALSE |
| 65 | ! |
new.lv <- character(0L) |
| 66 | ! |
while (!all.ind.are.observed.flag) {
|
| 67 |
# check indicators of all this.lv |
|
| 68 | ! |
RHS <- PT$rhs[which(PT$op == "=~" & PT$block == g & |
| 69 | ! |
PT$lhs %in% this.lv)] |
| 70 | ! |
lv.idx <- which(RHS %in% LV.names) |
| 71 | ! |
if (length(lv.idx) > 0L) {
|
| 72 |
# add these 'new' ones to new.lv |
|
| 73 | ! |
new.lv <- c(new.lv, RHS[lv.idx]) |
| 74 | ! |
this.lv <- RHS[lv.idx] |
| 75 |
} else {
|
|
| 76 | ! |
all.ind.are.observed.flag <- TRUE |
| 77 |
} |
|
| 78 |
} |
|
| 79 | ||
| 80 |
# update lv.names for this block |
|
| 81 | ! |
lv.names[[g]] <- unique(c(lv.names[[g]], new.lv)) |
| 82 |
} |
|
| 83 | ||
| 84 |
# keep rows idx |
|
| 85 | ! |
keep.idx <- integer(0L) |
| 86 | ||
| 87 |
# remove not-needed measurement models |
|
| 88 | ! |
for (g in 1:nblocks) {
|
| 89 |
# indicators for latent variables we keep |
|
| 90 | ! |
IND.idx <- which(PT$op == "=~" & |
| 91 | ! |
PT$lhs %in% lv.names[[g]] & |
| 92 | ! |
PT$block == block.values[g]) |
| 93 | ! |
IND <- PT$rhs[IND.idx] |
| 94 | ! |
IND.plabel <- PT$plabel[IND.idx] |
| 95 | ||
| 96 |
# keep =~ |
|
| 97 | ! |
keep.idx <- c(keep.idx, IND.idx) |
| 98 | ||
| 99 |
# new in 0.6-17: indicators regressed on predictors |
|
| 100 | ! |
if (add.ind.predictors) {
|
| 101 | ! |
PRED.idx <- which(PT$op == "~" & |
| 102 | ! |
PT$lhs %in% IND & |
| 103 | ! |
PT$block == block.values[g]) |
| 104 | ! |
EXTRA <- unique(PT$rhs[PRED.idx]) |
| 105 | ! |
keep.idx <- c(keep.idx, PRED.idx) |
| 106 |
# add them to IND, so we include their variances/intercepts |
|
| 107 | ! |
IND <- c(IND, EXTRA) |
| 108 |
} |
|
| 109 | ||
| 110 |
# keep ~~ |
|
| 111 | ! |
OV.VAR.idx <- which(PT$op == "~~" & |
| 112 | ! |
PT$lhs %in% IND & |
| 113 | ! |
PT$rhs %in% IND & |
| 114 | ! |
PT$block == block.values[g]) |
| 115 | ! |
keep.idx <- c(keep.idx, OV.VAR.idx) |
| 116 | ||
| 117 | ! |
LV.VAR.idx <- which(PT$op == "~~" & |
| 118 | ! |
PT$lhs %in% lv.names[[g]] & |
| 119 | ! |
PT$rhs %in% lv.names[[g]] & |
| 120 | ! |
PT$block == block.values[g]) |
| 121 | ! |
keep.idx <- c(keep.idx, LV.VAR.idx) |
| 122 | ||
| 123 |
# intercepts indicators |
|
| 124 | ! |
OV.INT.idx <- which(PT$op == "~1" & |
| 125 | ! |
PT$lhs %in% IND & |
| 126 | ! |
PT$block == block.values[g]) |
| 127 | ! |
keep.idx <- c(keep.idx, OV.INT.idx) |
| 128 | ||
| 129 |
# intercepts latent variables |
|
| 130 | ! |
LV.INT.idx <- which(PT$op == "~1" & |
| 131 | ! |
PT$lhs %in% lv.names[[g]] & |
| 132 | ! |
PT$block == block.values[g]) |
| 133 | ! |
keep.idx <- c(keep.idx, LV.INT.idx) |
| 134 | ||
| 135 |
# thresholds |
|
| 136 | ! |
TH.idx <- which(PT$op == "|" & |
| 137 | ! |
PT$lhs %in% IND & |
| 138 | ! |
PT$block == block.values[g]) |
| 139 | ! |
keep.idx <- c(keep.idx, TH.idx) |
| 140 | ||
| 141 |
# scaling factors |
|
| 142 | ! |
SC.idx <- which(PT$op == "~*~" & |
| 143 | ! |
PT$lhs %in% IND & |
| 144 | ! |
PT$block == block.values[g]) |
| 145 | ! |
keep.idx <- c(keep.idx, SC.idx) |
| 146 | ||
| 147 |
# defined/constraints |
|
| 148 | ! |
if (any(PT$op %in% c("==", "<", ">", ":="))) {
|
| 149 |
# get the 'id' numbers and the labels involved in def/constraints |
|
| 150 | ! |
PT2 <- PT |
| 151 | ! |
PT2$free <- PT$id # us 'id' numbers instead of 'free' indices |
| 152 | ! |
ID <- lav_partable_constraints_label_id(PT2, def = TRUE) |
| 153 | ! |
LABEL <- names(ID) |
| 154 | ||
| 155 |
# what are the row indices that we currently keep? |
|
| 156 | ! |
FREE.id <- PT$id[keep.idx] |
| 157 |
} |
|
| 158 | ||
| 159 |
# defined parameters |
|
| 160 | ! |
def.idx <- which(PT$op == ":=") |
| 161 | ! |
if (length(def.idx) > 0L) {
|
| 162 | ! |
def.keep <- logical(length(def.idx)) |
| 163 | ! |
for (def in seq_len(length(def.idx))) {
|
| 164 |
# rhs |
|
| 165 | ! |
RHS.labels <- all.vars(as.formula(paste( |
| 166 |
"~", |
|
| 167 | ! |
PT[def.idx[def], "rhs"] |
| 168 |
))) |
|
| 169 | ! |
if (length(RHS.labels) > 0L) {
|
| 170 |
# par id |
|
| 171 | ! |
RHS.freeid <- ID[match(RHS.labels, LABEL)] |
| 172 | ||
| 173 |
# keep? |
|
| 174 | ! |
if (all(RHS.freeid %in% FREE.id)) {
|
| 175 | ! |
def.keep[def] <- TRUE |
| 176 |
} |
|
| 177 |
} else { # only constants?
|
|
| 178 | ! |
def.keep[def] <- TRUE |
| 179 |
} |
|
| 180 |
} |
|
| 181 | ! |
keep.idx <- c(keep.idx, def.idx[def.keep]) |
| 182 |
# add 'id' numbers of := definitions that we keep |
|
| 183 | ! |
FREE.id <- c(FREE.id, PT$id[def.idx[def.keep]]) |
| 184 |
} |
|
| 185 | ||
| 186 |
# (in)equality constraints |
|
| 187 | ! |
con.idx <- which(PT$op %in% c("==", "<", ">"))
|
| 188 | ! |
if (length(con.idx) > 0L) {
|
| 189 | ! |
con.keep <- logical(length(con.idx)) |
| 190 | ! |
for (con in seq_len(length(con.idx))) {
|
| 191 | ! |
lhs.keep <- FALSE |
| 192 | ! |
rhs.keep <- FALSE |
| 193 | ||
| 194 |
# lhs |
|
| 195 | ! |
LHS.labels <- all.vars(as.formula(paste( |
| 196 |
"~", |
|
| 197 | ! |
PT[con.idx[con], "lhs"] |
| 198 |
))) |
|
| 199 | ! |
if (length(LHS.labels) > 0L) {
|
| 200 |
# par id |
|
| 201 | ! |
LHS.freeid <- ID[match(LHS.labels, LABEL)] |
| 202 | ||
| 203 |
# keep? |
|
| 204 | ! |
if (all(LHS.freeid %in% FREE.id)) {
|
| 205 | ! |
lhs.keep <- TRUE |
| 206 |
} |
|
| 207 |
} else {
|
|
| 208 | ! |
lhs.keep <- TRUE |
| 209 |
} |
|
| 210 | ||
| 211 |
# rhs |
|
| 212 | ! |
RHS.labels <- all.vars(as.formula(paste( |
| 213 |
"~", |
|
| 214 | ! |
PT[con.idx[con], "rhs"] |
| 215 |
))) |
|
| 216 | ! |
if (length(RHS.labels) > 0L) {
|
| 217 |
# par id |
|
| 218 | ! |
RHS.freeid <- ID[match(RHS.labels, LABEL)] |
| 219 | ||
| 220 |
# keep? |
|
| 221 | ! |
if (all(RHS.freeid %in% FREE.id)) {
|
| 222 | ! |
rhs.keep <- TRUE |
| 223 |
} |
|
| 224 |
} else {
|
|
| 225 | ! |
rhs.keep <- TRUE |
| 226 |
} |
|
| 227 | ||
| 228 | ! |
if (lhs.keep && rhs.keep) {
|
| 229 | ! |
con.keep[con] <- TRUE |
| 230 |
} |
|
| 231 |
} |
|
| 232 | ||
| 233 | ! |
keep.idx <- c(keep.idx, con.idx[con.keep]) |
| 234 |
} # con |
|
| 235 |
} # block |
|
| 236 | ||
| 237 |
# remove any duplicated (only with higher-order factors) |
|
| 238 | ! |
keep.idx <- keep.idx[!duplicated(keep.idx)] |
| 239 | ||
| 240 | ! |
if (idx.only) {
|
| 241 | ! |
return(keep.idx) |
| 242 |
} |
|
| 243 | ||
| 244 | ! |
PT <- PT[keep.idx, , drop = FALSE] |
| 245 | ||
| 246 |
# check if we have enough indicators? |
|
| 247 |
# TODO |
|
| 248 | ||
| 249 |
# add covariances among latent variables? |
|
| 250 | ! |
if (add.lv.cov) {
|
| 251 | ! |
PT <- lav_partable_add_lv_cov( |
| 252 | ! |
PT = PT, |
| 253 | ! |
lv.names = lv.names |
| 254 |
) |
|
| 255 |
} |
|
| 256 | ||
| 257 |
# clean up |
|
| 258 | ! |
PT <- lav_partable_complete(PT) |
| 259 | ||
| 260 | ! |
if (add.idx) {
|
| 261 | ! |
attr(PT, "idx") <- keep.idx |
| 262 |
} |
|
| 263 | ||
| 264 | ! |
PT |
| 265 |
} |
|
| 266 | ||
| 267 |
# NOTE: only within same level |
|
| 268 |
lav_partable_add_lv_cov <- function(PT, lv.names = NULL) {
|
|
| 269 |
# PT |
|
| 270 | ! |
if (!is.data.frame(PT)) {
|
| 271 | ! |
PT <- as.data.frame(PT, stringsAsFactors = FALSE) |
| 272 |
} |
|
| 273 | ||
| 274 |
# lavpta |
|
| 275 | ! |
lavpta <- lav_partable_attributes(PT) |
| 276 | ||
| 277 |
# nblocks |
|
| 278 | ! |
nblocks <- lavpta$nblocks |
| 279 | ! |
block.values <- lav_partable_block_values(PT) |
| 280 | ||
| 281 |
# lv.names: list with element per block |
|
| 282 | ! |
if (is.null(lv.names)) {
|
| 283 | ! |
lv.names <- lavpta$vnames$lv.regular |
| 284 | ! |
} else if (!is.list(lv.names)) {
|
| 285 | ! |
lv.names <- rep(list(lv.names), nblocks) |
| 286 |
} |
|
| 287 | ||
| 288 |
# check for higher-order models (new in 0.6-20) |
|
| 289 | ! |
for (b in seq_len(nblocks)) {
|
| 290 | ! |
if (length(lavpta$vnames$lv.ind[[b]]) > 0L) {
|
| 291 | ! |
ind.idx <- which(lv.names[[b]] %in% lavpta$vnames$lv.ind[[b]]) |
| 292 | ! |
if (length(ind.idx) > 0L) {
|
| 293 | ! |
lv.names[[b]] <- lv.names[[b]][-ind.idx] |
| 294 |
} |
|
| 295 |
} |
|
| 296 |
} |
|
| 297 | ||
| 298 |
# remove lv.names if not present at same level/block |
|
| 299 | ! |
if (nblocks > 1L) {
|
| 300 | ! |
for (b in seq_len(nblocks)) {
|
| 301 | ! |
rm.idx <- which(!lv.names[[b]] %in% lavpta$vnames$lv.regular[[b]]) |
| 302 | ! |
if (length(rm.idx) > 0L) {
|
| 303 | ! |
lv.names[[b]] <- lv.names[[b]][-rm.idx] |
| 304 |
} |
|
| 305 |
} # b |
|
| 306 |
} |
|
| 307 | ||
| 308 |
# add covariances among latent variables |
|
| 309 | ! |
for (b in seq_len(nblocks)) {
|
| 310 | ! |
if (length(lv.names[[b]]) > 1L) {
|
| 311 | ! |
tmp <- utils::combn(lv.names[[b]], 2L) |
| 312 | ! |
for (i in seq_len(ncol(tmp))) {
|
| 313 |
# already present? |
|
| 314 | ! |
cov1.idx <- which(PT$op == "~~" & |
| 315 | ! |
PT$block == block.values[b] & |
| 316 | ! |
PT$lhs == tmp[1, i] & PT$rhs == tmp[2, i]) |
| 317 | ! |
cov2.idx <- which(PT$op == "~~" & |
| 318 | ! |
PT$block == block.values[b] & |
| 319 | ! |
PT$lhs == tmp[2, i] & PT$rhs == tmp[1, i]) |
| 320 | ||
| 321 |
# if not, add |
|
| 322 | ! |
if (length(c(cov1.idx, cov2.idx)) == 0L) {
|
| 323 | ! |
ADD <- list( |
| 324 | ! |
lhs = tmp[1, i], |
| 325 | ! |
op = "~~", |
| 326 | ! |
rhs = tmp[2, i], |
| 327 | ! |
user = 3L, |
| 328 | ! |
free = max(PT$free) + 1L, |
| 329 | ! |
block = b |
| 330 |
) |
|
| 331 |
# add group column |
|
| 332 | ! |
if (!is.null(PT$group)) {
|
| 333 | ! |
ADD$group <- unique(PT$block[PT$block == b]) |
| 334 |
} |
|
| 335 |
# add level column |
|
| 336 | ! |
if (!is.null(PT$level)) {
|
| 337 | ! |
ADD$level <- unique(PT$level[PT$block == b]) |
| 338 |
} |
|
| 339 |
# add lower column |
|
| 340 | ! |
if (!is.null(PT$lower)) {
|
| 341 | ! |
ADD$lower <- as.numeric(-Inf) |
| 342 |
} |
|
| 343 |
# add upper column |
|
| 344 | ! |
if (!is.null(PT$upper)) {
|
| 345 | ! |
ADD$upper <- as.numeric(+Inf) |
| 346 |
} |
|
| 347 | ! |
PT <- lav_partable_add(PT, add = ADD) |
| 348 |
} |
|
| 349 |
} |
|
| 350 |
} # lv.names |
|
| 351 |
} # blocks |
|
| 352 | ||
| 353 | ! |
PT |
| 354 |
} |
|
| 355 | ||
| 356 |
# this function takes a 'full' SEM (measurement models + structural part) |
|
| 357 |
# and returns only the structural part |
|
| 358 |
# |
|
| 359 |
# - what to do if we have no regressions among the latent variables? |
|
| 360 |
# -> we return all covariances among the latent variables |
|
| 361 |
# |
|
| 362 |
lav_partable_subset_structural_model <- function(PT = NULL, |
|
| 363 |
add.idx = FALSE, |
|
| 364 |
idx.only = FALSE, |
|
| 365 |
add.exo.cov = FALSE, |
|
| 366 |
fixed.x = FALSE, |
|
| 367 |
conditional.x = FALSE, |
|
| 368 |
free.fixed.var = FALSE, |
|
| 369 |
meanstructure = FALSE) {
|
|
| 370 |
# PT |
|
| 371 | ! |
PT <- PT.orig <- as.data.frame(PT, stringsAsFactors = FALSE) |
| 372 | ||
| 373 |
# remove any EFA related information -- new in 0.6-18 |
|
| 374 | ! |
if (!is.null(PT$efa)) {
|
| 375 | ! |
PT$efa <- NULL |
| 376 | ! |
PT$est.unrotated <- NULL |
| 377 | ! |
seven.idx <- which(PT$user == 7L & PT$op == "~~") |
| 378 | ! |
if (length(seven.idx) > 0L) {
|
| 379 | ! |
PT$user[seven.idx] <- 0L |
| 380 | ! |
PT$free[seven.idx] <- 1L |
| 381 | ! |
PT$ustart[seven.idx] <- as.numeric(NA) |
| 382 | ! |
PT$est[seven.idx] <- PT$est.std[seven.idx] |
| 383 |
} |
|
| 384 | ! |
PT$est.std <- NULL |
| 385 |
} |
|
| 386 | ||
| 387 |
# lavpta |
|
| 388 | ! |
lavpta <- lav_partable_attributes(PT) |
| 389 | ||
| 390 |
# nblocks |
|
| 391 | ! |
nblocks <- lavpta$nblocks |
| 392 | ! |
block.values <- lav_partable_block_values(PT) |
| 393 | ||
| 394 |
# eqs.names |
|
| 395 | ! |
eqs.x.names <- lavpta$vnames$eqs.x |
| 396 | ! |
eqs.y.names <- lavpta$vnames$eqs.y |
| 397 | ! |
lv.names <- lavpta$vnames$lv.regular |
| 398 | ||
| 399 |
# keep rows idx |
|
| 400 | ! |
keep.idx <- integer(0L) |
| 401 | ||
| 402 |
# remove not-needed measurement models |
|
| 403 | ! |
for (g in 1:nblocks) {
|
| 404 | ||
| 405 |
# eqs.names |
|
| 406 | ! |
eqs.names <- unique(c( |
| 407 | ! |
lavpta$vnames$eqs.x[[g]], |
| 408 | ! |
lavpta$vnames$eqs.y[[g]] |
| 409 |
)) |
|
| 410 | ! |
if (length(eqs.names) == 0L) { # no structural model
|
| 411 | ! |
eqs.names <- lv.names[[g]] |
| 412 |
} |
|
| 413 |
# all.names <- unique(c( |
|
| 414 |
# eqs.names, |
|
| 415 |
# lavpta$vnames$lv.regular[[g]] |
|
| 416 |
# )) |
|
| 417 | ||
| 418 |
# regressions |
|
| 419 | ! |
reg.idx <- which(PT$op == "~" & PT$block == block.values[g] & |
| 420 | ! |
PT$lhs %in% eqs.names & |
| 421 | ! |
PT$rhs %in% eqs.names) |
| 422 | ||
| 423 |
# the variances |
|
| 424 | ! |
var.idx <- which(PT$op == "~~" & PT$block == block.values[g] & |
| 425 | ! |
PT$lhs %in% eqs.names & |
| 426 | ! |
PT$rhs %in% eqs.names & |
| 427 | ! |
PT$lhs == PT$rhs) |
| 428 | ||
| 429 |
# optionally covariances (exo!) |
|
| 430 | ! |
cov.idx <- which(PT$op == "~~" & PT$block == block.values[g] & |
| 431 | ! |
PT$lhs %in% eqs.names & |
| 432 | ! |
PT$rhs %in% eqs.names & |
| 433 | ! |
PT$lhs != PT$rhs) |
| 434 | ||
| 435 |
# means/intercepts |
|
| 436 | ! |
int.idx <- which(PT$op == "~1" & PT$block == block.values[g] & |
| 437 | ! |
PT$lhs %in% eqs.names) |
| 438 | ||
| 439 | ! |
keep.idx <- c( |
| 440 | ! |
keep.idx, reg.idx, var.idx, cov.idx, int.idx |
| 441 |
) |
|
| 442 | ||
| 443 |
# defined/constraints |
|
| 444 | ! |
if (any(PT$op %in% c("==", "<", ">", ":="))) {
|
| 445 |
# get the 'id' numbers and the labels involved in def/constraints |
|
| 446 | ! |
PT2 <- PT |
| 447 | ! |
PT2$free <- PT$id # us 'id' numbers instead of 'free' indices |
| 448 | ! |
ID <- lav_partable_constraints_label_id(PT2, def = TRUE) |
| 449 | ! |
LABEL <- names(ID) |
| 450 | ||
| 451 |
# what are the row indices that we currently keep? |
|
| 452 | ! |
FREE.id <- PT$id[keep.idx] |
| 453 |
} |
|
| 454 | ||
| 455 |
# defined parameters |
|
| 456 | ! |
def.idx <- which(PT$op == ":=") |
| 457 | ! |
if (length(def.idx) > 0L) {
|
| 458 | ! |
def.keep <- logical(length(def.idx)) |
| 459 | ! |
for (def in seq_len(length(def.idx))) {
|
| 460 |
# rhs |
|
| 461 | ! |
RHS.labels <- all.vars(as.formula(paste( |
| 462 |
"~", |
|
| 463 | ! |
PT[def.idx[def], "rhs"] |
| 464 |
))) |
|
| 465 | ! |
if (length(RHS.labels) > 0L) {
|
| 466 |
# par id |
|
| 467 | ! |
RHS.freeid <- ID[match(RHS.labels, LABEL)] |
| 468 | ||
| 469 |
# keep? |
|
| 470 | ! |
if (all(RHS.freeid %in% FREE.id)) {
|
| 471 | ! |
def.keep[def] <- TRUE |
| 472 |
} |
|
| 473 |
} else { # only constants?
|
|
| 474 | ! |
def.keep[def] <- TRUE |
| 475 |
} |
|
| 476 |
} |
|
| 477 | ! |
keep.idx <- c(keep.idx, def.idx[def.keep]) |
| 478 |
# add 'id' numbers of := definitions that we keep |
|
| 479 | ! |
FREE.id <- c(FREE.id, PT$id[def.idx[def.keep]]) |
| 480 |
} |
|
| 481 | ||
| 482 |
# (in)equality constraints |
|
| 483 | ! |
con.idx <- which(PT$op %in% c("==", "<", ">"))
|
| 484 | ! |
if (length(con.idx) > 0L) {
|
| 485 | ! |
con.keep <- logical(length(con.idx)) |
| 486 | ! |
for (con in seq_len(length(con.idx))) {
|
| 487 | ! |
lhs.keep <- FALSE |
| 488 | ! |
rhs.keep <- FALSE |
| 489 | ||
| 490 |
# lhs |
|
| 491 | ! |
LHS.labels <- all.vars(as.formula(paste( |
| 492 |
"~", |
|
| 493 | ! |
PT[con.idx[con], "lhs"] |
| 494 |
))) |
|
| 495 | ! |
if (length(LHS.labels) > 0L) {
|
| 496 |
# par id |
|
| 497 | ! |
LHS.freeid <- ID[match(LHS.labels, LABEL)] |
| 498 | ||
| 499 |
# keep? |
|
| 500 | ! |
if (all(LHS.freeid %in% FREE.id)) {
|
| 501 | ! |
lhs.keep <- TRUE |
| 502 |
} |
|
| 503 |
} else {
|
|
| 504 | ! |
lhs.keep <- TRUE |
| 505 |
} |
|
| 506 | ||
| 507 |
# rhs |
|
| 508 | ! |
RHS.labels <- all.vars(as.formula(paste( |
| 509 |
"~", |
|
| 510 | ! |
PT[con.idx[con], "rhs"] |
| 511 |
))) |
|
| 512 | ! |
if (length(RHS.labels) > 0L) {
|
| 513 |
# par id |
|
| 514 | ! |
RHS.freeid <- ID[match(RHS.labels, LABEL)] |
| 515 | ||
| 516 |
# keep? |
|
| 517 | ! |
if (all(RHS.freeid %in% FREE.id)) {
|
| 518 | ! |
rhs.keep <- TRUE |
| 519 |
} |
|
| 520 |
} else {
|
|
| 521 | ! |
rhs.keep <- TRUE |
| 522 |
} |
|
| 523 | ||
| 524 | ! |
if (lhs.keep && rhs.keep) {
|
| 525 | ! |
con.keep[con] <- TRUE |
| 526 |
} |
|
| 527 |
} |
|
| 528 | ||
| 529 | ! |
keep.idx <- c(keep.idx, con.idx[con.keep]) |
| 530 |
} # con |
|
| 531 |
} # block |
|
| 532 | ||
| 533 | ! |
if (idx.only) {
|
| 534 | ! |
return(keep.idx) |
| 535 |
} |
|
| 536 | ||
| 537 | ! |
PT <- PT[keep.idx, , drop = FALSE] |
| 538 | ||
| 539 |
# add any missing covariances among exogenous variables |
|
| 540 | ! |
if (add.exo.cov) {
|
| 541 | ! |
if (conditional.x) {
|
| 542 | ! |
PT <- lav_partable_add_exo_cov(PT, ov.names.x = lavpta$vnames$ov.x) |
| 543 |
} else {
|
|
| 544 | ! |
PT <- lav_partable_add_exo_cov(PT) |
| 545 |
} |
|
| 546 |
} |
|
| 547 | ||
| 548 |
# if meanstructure, 'free' user=0 intercepts |
|
| 549 | ! |
if (meanstructure) {
|
| 550 | ! |
int.idx <- which(PT$op == "~1" & PT$user == 0L & PT$free == 0L) |
| 551 | ! |
if (length(int.idx) > 0L) {
|
| 552 | ! |
PT$free[int.idx] <- max(PT$free) + seq_len(length(int.idx)) |
| 553 | ! |
PT$ustart[int.idx] <- as.numeric(NA) |
| 554 | ! |
PT$user[int.idx] <- 3L |
| 555 |
} |
|
| 556 |
} |
|
| 557 | ||
| 558 |
# if fixed.x = FALSE, remove all remaining (free) exo=1 elements |
|
| 559 | ! |
if (!fixed.x) {
|
| 560 | ! |
exo.idx <- which(PT$exo != 0L) |
| 561 | ! |
if (length(exo.idx) > 0L) {
|
| 562 | ! |
PT$exo[exo.idx] <- 0L |
| 563 | ! |
PT$user[exo.idx] <- 3L |
| 564 | ! |
PT$free[exo.idx] <- max(PT$free) + seq_len(length(exo.idx)) |
| 565 |
} |
|
| 566 | ||
| 567 | ! |
} else if (conditional.x) {
|
| 568 |
# don't change exo column! |
|
| 569 |
} else {
|
|
| 570 |
# first, wipe out exo column |
|
| 571 | ! |
exo.idx <- which(PT$exo != 0L) |
| 572 | ! |
if (length(exo.idx) > 0L) {
|
| 573 | ! |
PT$exo[exo.idx] <- 0L |
| 574 |
} |
|
| 575 | ||
| 576 |
# keep ov.x as in global model! |
|
| 577 | ! |
for (g in 1:nblocks) {
|
| 578 |
# ov.names.x <- lav_partable_vnames(PT, |
|
| 579 |
# type = "ov.x", |
|
| 580 |
# block = block.values[g] |
|
| 581 |
# ) |
|
| 582 | ! |
ov.names.x <- lavpta$vnames$ov.x[[g]] |
| 583 | ! |
if (length(ov.names.x) == 0L) {
|
| 584 | ! |
next |
| 585 |
} |
|
| 586 | ||
| 587 |
# 1. variances/covariances |
|
| 588 | ! |
exo.var.idx <- which( |
| 589 | ! |
PT$op == "~~" & |
| 590 | ! |
PT$block == block.values[g] & |
| 591 | ! |
PT$rhs %in% ov.names.x & |
| 592 | ! |
PT$lhs %in% ov.names.x & |
| 593 | ! |
PT$user %in% c(0L, 3L) |
| 594 |
) |
|
| 595 | ! |
if (length(exo.var.idx) > 0L) {
|
| 596 | ! |
PT$ustart[exo.var.idx] <- as.numeric(NA) # to be overriden |
| 597 | ! |
PT$free[exo.var.idx] <- 0L |
| 598 | ! |
PT$exo[exo.var.idx] <- 1L |
| 599 | ! |
PT$user[exo.var.idx] <- 3L |
| 600 |
} |
|
| 601 | ||
| 602 |
# 2. intercepts |
|
| 603 | ! |
exo.int.idx <- which( |
| 604 | ! |
PT$op == "~1" & |
| 605 | ! |
PT$block == block.values[g] & |
| 606 | ! |
PT$lhs %in% ov.names.x & |
| 607 | ! |
PT$user == 0L |
| 608 |
) |
|
| 609 | ! |
if (length(exo.int.idx) > 0L) {
|
| 610 | ! |
PT$ustart[exo.int.idx] <- as.numeric(NA) # to be overriden |
| 611 | ! |
PT$free[exo.int.idx] <- 0L |
| 612 | ! |
PT$exo[exo.int.idx] <- 1L |
| 613 | ! |
PT$user[exo.int.idx] <- 3L |
| 614 |
} |
|
| 615 |
} # blocks |
|
| 616 |
} # fixed.x |
|
| 617 | ||
| 618 |
# if conditional.x, check if we have 'additional' ov.x variables |
|
| 619 |
# that were not ov.x in the global model |
|
| 620 | ! |
if (conditional.x) {
|
| 621 | ! |
for (b in 1:nblocks) {
|
| 622 | ! |
global.ov.x <- lavpta$vnames$ov.x[[b]] |
| 623 | ! |
local.ov.x <- lav_partable_vnames(PT, type = "ov.x", |
| 624 | ! |
block = block.values[b] |
| 625 |
) |
|
| 626 | ! |
extra.idx <- which(!local.ov.x %in% global.ov.x) |
| 627 | ! |
if (length(extra.idx) > 0L) {
|
| 628 | ! |
extra.ov.names <- local.ov.x[extra.idx] |
| 629 | ! |
for (i in seq_len(length(extra.idx))) {
|
| 630 | ! |
ADD <- list( |
| 631 | ! |
lhs = extra.ov.names[i], |
| 632 | ! |
op = "~", |
| 633 | ! |
rhs = global.ov.x[1], |
| 634 | ! |
user = 3L, |
| 635 | ! |
free = 0L, |
| 636 | ! |
block = b, |
| 637 | ! |
ustart = 0, |
| 638 | ! |
exo = 1L |
| 639 |
) |
|
| 640 |
# add group column |
|
| 641 | ! |
if (!is.null(PT$group)) {
|
| 642 | ! |
ADD$group <- unique(PT$block[PT$block == b]) |
| 643 |
} |
|
| 644 |
# add level column |
|
| 645 | ! |
if (!is.null(PT$level)) {
|
| 646 | ! |
ADD$level <- unique(PT$level[PT$block == b]) |
| 647 |
} |
|
| 648 |
# add lower column |
|
| 649 | ! |
if (!is.null(PT$lower)) {
|
| 650 | ! |
ADD$lower <- as.numeric(-Inf) |
| 651 |
} |
|
| 652 |
# add upper column |
|
| 653 | ! |
if (!is.null(PT$upper)) {
|
| 654 | ! |
ADD$upper <- as.numeric(+Inf) |
| 655 |
} |
|
| 656 | ! |
PT <- lav_partable_add(PT, add = ADD) |
| 657 |
} # i |
|
| 658 |
} # extra.idx |
|
| 659 |
} # b |
|
| 660 |
} # conditional.x |
|
| 661 | ||
| 662 |
# if free.fixed.var, free up all 'fixed (to unity)' variances |
|
| 663 | ! |
if (free.fixed.var) {
|
| 664 | ! |
fixed.var.idx <- which(PT$op == "~~" & PT$lhs == PT$rhs & PT$free == 0 & |
| 665 | ! |
PT$user == 0L & PT$ustart == 1) |
| 666 | ! |
if (length(fixed.var.idx) > 0L) {
|
| 667 | ! |
PT$free[ fixed.var.idx] <- max(PT$free) + seq_len(length(fixed.var.idx)) |
| 668 | ! |
PT$ustart[fixed.var.idx] <- as.numeric(NA) |
| 669 |
} |
|
| 670 |
} |
|
| 671 | ||
| 672 |
# clean up |
|
| 673 | ! |
PT <- lav_partable_complete(PT) |
| 674 | ||
| 675 | ! |
if (add.idx) {
|
| 676 | ! |
attr(PT, "idx") <- keep.idx |
| 677 |
} |
|
| 678 | ||
| 679 | ! |
PT |
| 680 |
} |
|
| 681 | ||
| 682 |
# NOTE: only within same level |
|
| 683 |
lav_partable_add_exo_cov <- function(PT, ov.names.x = NULL) {
|
|
| 684 |
# PT |
|
| 685 | ! |
PT <- as.data.frame(PT, stringsAsFactors = FALSE) |
| 686 | ||
| 687 |
# lavpta |
|
| 688 | ! |
lavpta <- lav_partable_attributes(PT) |
| 689 | ||
| 690 |
# nblocks |
|
| 691 | ! |
nblocks <- lavpta$nblocks |
| 692 | ! |
block.values <- lav_partable_block_values(PT) |
| 693 | ||
| 694 | ||
| 695 |
# ov.names.x: list with element per block |
|
| 696 | ! |
if (is.null(ov.names.x)) {
|
| 697 | ! |
ov.names.x <- lavpta$vnames$ov.x |
| 698 | ! |
} else if (!is.list(ov.names.x)) {
|
| 699 | ! |
ov.names.x <- rep(list(ov.names.x), nblocks) |
| 700 |
} |
|
| 701 | ||
| 702 |
# remove ov.names.x if not present at same level/block |
|
| 703 | ! |
if (nblocks > 1L) {
|
| 704 | ! |
for (b in seq_len(nblocks)) {
|
| 705 | ! |
rm.idx <- which(!ov.names.x[[b]] %in% lavpta$vnames$ov.x[[b]]) |
| 706 | ! |
if (length(rm.idx) > 0L) {
|
| 707 | ! |
ov.names.x[[b]] <- ov.names.x[[b]][-rm.idx] |
| 708 |
} |
|
| 709 |
} # b |
|
| 710 |
} |
|
| 711 | ||
| 712 |
# add covariances among latent variables |
|
| 713 | ! |
for (b in seq_len(nblocks)) {
|
| 714 | ! |
if (length(ov.names.x[[b]]) > 1L) {
|
| 715 | ! |
tmp <- utils::combn(ov.names.x[[b]], 2L) |
| 716 | ! |
for (i in seq_len(ncol(tmp))) {
|
| 717 |
# already present? |
|
| 718 | ! |
cov1.idx <- which(PT$op == "~~" & |
| 719 | ! |
PT$block == block.values[b] & |
| 720 | ! |
PT$lhs == tmp[1, i] & PT$rhs == tmp[2, i]) |
| 721 | ! |
cov2.idx <- which(PT$op == "~~" & |
| 722 | ! |
PT$block == block.values[b] & |
| 723 | ! |
PT$lhs == tmp[2, i] & PT$rhs == tmp[1, i]) |
| 724 | ||
| 725 |
# if not, add |
|
| 726 | ! |
if (length(c(cov1.idx, cov2.idx)) == 0L) {
|
| 727 | ! |
ADD <- list( |
| 728 | ! |
lhs = tmp[1, i], |
| 729 | ! |
op = "~~", |
| 730 | ! |
rhs = tmp[2, i], |
| 731 | ! |
user = 3L, |
| 732 | ! |
free = max(PT$free) + 1L, |
| 733 | ! |
block = b, |
| 734 | ! |
ustart = as.numeric(NA) |
| 735 |
) |
|
| 736 |
# add group column |
|
| 737 | ! |
if (!is.null(PT$group)) {
|
| 738 | ! |
ADD$group <- unique(PT$block[PT$block == b]) |
| 739 |
} |
|
| 740 |
# add level column |
|
| 741 | ! |
if (!is.null(PT$level)) {
|
| 742 | ! |
ADD$level <- unique(PT$level[PT$block == b]) |
| 743 |
} |
|
| 744 |
# add lower column |
|
| 745 | ! |
if (!is.null(PT$lower)) {
|
| 746 | ! |
ADD$lower <- as.numeric(-Inf) |
| 747 |
} |
|
| 748 |
# add upper column |
|
| 749 | ! |
if (!is.null(PT$upper)) {
|
| 750 | ! |
ADD$upper <- as.numeric(+Inf) |
| 751 |
} |
|
| 752 | ! |
PT <- lav_partable_add(PT, add = ADD) |
| 753 |
} |
|
| 754 |
} |
|
| 755 |
} # ov.names.x |
|
| 756 |
} # blocks |
|
| 757 | ||
| 758 | ! |
PT |
| 759 |
} |
| 1 |
# add parameter bounds to the parameter table |
|
| 2 |
# lavoptions$optim.bounds |
|
| 3 |
lav_partable_add_bounds <- function(partable = NULL, |
|
| 4 |
lavh1 = NULL, |
|
| 5 |
lavdata = NULL, |
|
| 6 |
lavsamplestats = NULL, |
|
| 7 |
lavoptions = NULL) {
|
|
| 8 |
# no support (yet) for multilevel |
|
| 9 | 201x |
if (lav_partable_nlevels(partable) > 1L) {
|
| 10 | 6x |
return(partable) |
| 11 |
} |
|
| 12 | ||
| 13 |
# check optim.bounds |
|
| 14 | 195x |
if (is.null(lavoptions$optim.bounds)) {
|
| 15 |
# <0.6-6 version |
|
| 16 | ! |
return(partable) |
| 17 | 195x |
} else if (!is.null(lavoptions$samplestats) && !lavoptions$samplestats) {
|
| 18 |
# no sample statistics |
|
| 19 | ! |
return(partable) |
| 20 |
} else {
|
|
| 21 | 195x |
if (!is.null(lavoptions$bounds) && lavoptions$bounds == "none") {
|
| 22 |
# no bounds needed |
|
| 23 | 73x |
return(partable) |
| 24 |
} |
|
| 25 | ||
| 26 |
# no support from effect.coding (for now) |
|
| 27 | 122x |
if (!is.null(lavoptions$effect.coding) && |
| 28 | 122x |
nchar(lavoptions$effect.coding[1L]) > 0L) {
|
| 29 | ! |
lav_msg_warn(gettext( |
| 30 | ! |
"automatic bounds not available (yet) if effect.coding is used" |
| 31 |
)) |
|
| 32 | ! |
return(partable) |
| 33 |
} |
|
| 34 | ||
| 35 | 122x |
optim.bounds <- lavoptions$optim.bounds |
| 36 | ||
| 37 |
# check the elements |
|
| 38 | 122x |
if (is.null(optim.bounds$lower)) {
|
| 39 | 59x |
optim.bounds$lower <- character(0L) |
| 40 |
} else {
|
|
| 41 | 63x |
optim.bounds$lower <- as.character(optim.bounds$lower) |
| 42 |
} |
|
| 43 | 122x |
if (is.null(optim.bounds$upper)) {
|
| 44 | 122x |
optim.bounds$upper <- character(0L) |
| 45 |
} else {
|
|
| 46 | ! |
optim.bounds$upper <- as.character(optim.bounds$upper) |
| 47 |
} |
|
| 48 | ||
| 49 | 122x |
if (is.null(optim.bounds$min.reliability.marker)) {
|
| 50 | 118x |
optim.bounds$min.reliability.marker <- 0.0 |
| 51 |
} else {
|
|
| 52 | 4x |
if (optim.bounds$min.reliability.marker < 0 || |
| 53 | 4x |
optim.bounds$min.reliability.marker > 1.0) {
|
| 54 | ! |
lav_msg_stop(gettextf( |
| 55 | ! |
"optim.bounds$min.reliability.marker is out of range: %s", |
| 56 | ! |
optim.bounds$min.reliability.marker |
| 57 |
)) |
|
| 58 |
} |
|
| 59 |
} |
|
| 60 | ||
| 61 | 122x |
if (is.null(optim.bounds$min.var.ov)) {
|
| 62 | 122x |
optim.bounds$min.var.ov <- -Inf |
| 63 |
} |
|
| 64 | ||
| 65 | 122x |
if (is.null(optim.bounds$min.var.lv.exo)) {
|
| 66 | 118x |
optim.bounds$min.var.lv.exo <- 0.0 |
| 67 |
} |
|
| 68 | ||
| 69 | 122x |
if (is.null(optim.bounds$min.var.lv.endo)) {
|
| 70 | 118x |
optim.bounds$min.var.lv.endo <- 0.0 |
| 71 |
} |
|
| 72 | ||
| 73 | 122x |
if (is.null(optim.bounds$max.r2.lv.endo)) {
|
| 74 | 122x |
optim.bounds$max.r2.lv.endo <- 1.0 |
| 75 |
} |
|
| 76 | ||
| 77 | 122x |
if (is.null(optim.bounds$lower.factor)) {
|
| 78 | 118x |
optim.bounds$lower.factor <- rep(1.0, length(optim.bounds$lower)) |
| 79 |
} else {
|
|
| 80 | 4x |
if (length(optim.bounds$lower.factor) == 1L && |
| 81 | 4x |
is.numeric(optim.bounds$lower.factor)) {
|
| 82 | ! |
optim.bounds$lower.factor <- rep( |
| 83 | ! |
optim.bounds$lower.factor, |
| 84 | ! |
length(optim.bounds$lower) |
| 85 |
) |
|
| 86 | 4x |
} else if (length(optim.bounds$lower.factor) != |
| 87 | 4x |
length(optim.bounds$lower)) {
|
| 88 | ! |
lav_msg_stop( |
| 89 | ! |
gettext("length(optim.bounds$lower.factor) is not equal to
|
| 90 | ! |
length(optim.bounds$lower)") |
| 91 |
) |
|
| 92 |
} |
|
| 93 |
} |
|
| 94 | 122x |
lower.factor <- optim.bounds$lower.factor |
| 95 | ||
| 96 | 122x |
if (is.null(optim.bounds$upper.factor)) {
|
| 97 | 122x |
optim.bounds$upper.factor <- rep(1.0, length(optim.bounds$upper)) |
| 98 |
} else {
|
|
| 99 | ! |
if (length(optim.bounds$upper.factor) == 1L && |
| 100 | ! |
is.numeric(optim.bounds$upper.factor)) {
|
| 101 | ! |
optim.bounds$upper.factor <- rep( |
| 102 | ! |
optim.bounds$upper.factor, |
| 103 | ! |
length(optim.bounds$upper) |
| 104 |
) |
|
| 105 | ! |
} else if (length(optim.bounds$upper.factor) != |
| 106 | ! |
length(optim.bounds$upper)) {
|
| 107 | ! |
lav_msg_stop( |
| 108 | ! |
gettext("length(optim.bounds$lower.factor) is not equal to
|
| 109 | ! |
length(optim.bounds$upper)") |
| 110 |
) |
|
| 111 |
} |
|
| 112 |
} |
|
| 113 | 122x |
upper.factor <- optim.bounds$upper.factor |
| 114 |
} |
|
| 115 | ||
| 116 |
# new in 0.6-17: check if we have theta parameterization |
|
| 117 | 122x |
theta.parameterization.flag <- FALSE |
| 118 | 122x |
if (any(partable$op == "~*~") && lavoptions$parameterization == "theta") {
|
| 119 |
# some fixed-to-1 theta elements? |
|
| 120 | ! |
ov.scaled <- partable$lhs[partable$op == "~*~"] |
| 121 | ! |
ov.var.idx <- which(partable$op == "~~" & |
| 122 | ! |
partable$lhs %in% ov.scaled & |
| 123 | ! |
partable$free == 0L & |
| 124 | ! |
partable$ustart == 1) |
| 125 | ! |
if (length(ov.var.idx) > 0L) {
|
| 126 | ! |
theta.parameterization.flag <- TRUE |
| 127 | ! |
theta.parameterization.names <- partable$lhs[ov.var.idx] |
| 128 |
} |
|
| 129 |
} |
|
| 130 | ||
| 131 |
# shortcut |
|
| 132 | 122x |
REL <- optim.bounds$min.reliability.marker |
| 133 | ||
| 134 |
# nothing to do |
|
| 135 | 122x |
if (length(optim.bounds$lower) == 0L && |
| 136 | 122x |
length(optim.bounds$upper) == 0L) {
|
| 137 | 59x |
return(partable) |
| 138 |
} else {
|
|
| 139 |
# we compute ALL bounds, then we select what we need |
|
| 140 |
# (otherwise, we can not use the 'factor') |
|
| 141 | ||
| 142 | 63x |
if (!is.null(partable$lower)) {
|
| 143 | ! |
lower.user <- partable$lower |
| 144 |
} else {
|
|
| 145 | 63x |
partable$lower <- lower.user <- rep(-Inf, length(partable$lhs)) |
| 146 |
} |
|
| 147 | 63x |
if (!is.null(partable$upper)) {
|
| 148 | ! |
upper.user <- partable$upper |
| 149 |
} else {
|
|
| 150 | 63x |
partable$upper <- upper.user <- rep(+Inf, length(partable$lhs)) |
| 151 |
} |
|
| 152 | ||
| 153 |
# the 'automatic' bounds |
|
| 154 | 63x |
lower.auto <- rep(-Inf, length(partable$lhs)) |
| 155 | 63x |
upper.auto <- rep(+Inf, length(partable$lhs)) |
| 156 |
} |
|
| 157 | ||
| 158 | 63x |
lavpta <- lav_partable_attributes(partable) |
| 159 | ||
| 160 |
# check blocks |
|
| 161 | 63x |
if (is.null(partable$block)) {
|
| 162 | ! |
partable$block <- rep(1L, length(partable$lhs)) |
| 163 |
} |
|
| 164 | 63x |
block.values <- lav_partable_block_values(partable) |
| 165 | ||
| 166 |
# check groups |
|
| 167 | 63x |
if (is.null(partable$group)) {
|
| 168 | ! |
partable$group <- rep(1L, length(partable$lhs)) |
| 169 |
} |
|
| 170 | 63x |
group.values <- lav_partable_group_values(partable) |
| 171 | 63x |
ngroups <- length(group.values) |
| 172 | ||
| 173 |
# compute bounds per group ### TODO: add levels/classes/... |
|
| 174 | 63x |
b <- 0L |
| 175 | 63x |
for (g in seq_len(ngroups)) {
|
| 176 |
# next block |
|
| 177 | 65x |
b <- b + 1L |
| 178 | ||
| 179 |
# for this block |
|
| 180 | 65x |
ov.names <- lavpta$vnames$ov[[b]] |
| 181 | 65x |
lv.names <- lavpta$vnames$lv[[b]] |
| 182 | 65x |
lv.names.x <- lavpta$vnames$lv.x[[b]] |
| 183 | 65x |
if (length(lv.names.x) > 0L) {
|
| 184 | 4x |
lv.names.endo <- lv.names[!lv.names %in% lv.names.x] |
| 185 |
} else {
|
|
| 186 | 61x |
lv.names.endo <- lv.names |
| 187 |
} |
|
| 188 | 65x |
lv.marker <- lavpta$vnames$lv.marker[[b]] |
| 189 | ||
| 190 |
# OV.VAR for this group |
|
| 191 | 65x |
if (lavsamplestats@missing.flag && lavdata@nlevels == 1L) {
|
| 192 | 24x |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 193 | 24x |
OV.VAR <- diag(lavh1$implied$cov[[g]]) |
| 194 |
} else {
|
|
| 195 | ! |
OV.VAR <- diag(lavsamplestats@missing.h1[[g]]$sigma) |
| 196 |
} |
|
| 197 |
} else {
|
|
| 198 | 41x |
if (lavoptions$conditional.x) {
|
| 199 | 2x |
OV.VAR <- diag(lavsamplestats@res.cov[[g]]) |
| 200 |
} else {
|
|
| 201 | 39x |
OV.VAR <- diag(lavsamplestats@cov[[g]]) |
| 202 |
} |
|
| 203 |
} |
|
| 204 | ||
| 205 |
# new in 0.6-17: increase observed variances for 'scaled' parameters |
|
| 206 |
# if theta parameterization |
|
| 207 | 65x |
if (theta.parameterization.flag) {
|
| 208 | ! |
sc.idx <- match(theta.parameterization.names, ov.names) |
| 209 | ! |
OV.VAR[sc.idx] <- OV.VAR[sc.idx] / REL |
| 210 |
} |
|
| 211 | ||
| 212 | ||
| 213 |
# we 'process' the parameters per 'type', so we can choose |
|
| 214 |
# to apply (or not) upper/lower bounds for each type separately |
|
| 215 | ||
| 216 |
################################ |
|
| 217 |
## 1. (residual) ov variances ## |
|
| 218 |
################################ |
|
| 219 | 65x |
par.idx <- which(partable$group == group.values[g] & |
| 220 | 65x |
partable$op == "~~" & |
| 221 | 65x |
partable$lhs %in% ov.names & |
| 222 | 65x |
partable$lhs == partable$rhs) |
| 223 | ||
| 224 | 65x |
if (length(par.idx) > 0L) {
|
| 225 |
# lower == 0 |
|
| 226 | 65x |
lower.auto[par.idx] <- 0 |
| 227 | ||
| 228 |
# upper == var(ov) |
|
| 229 | 65x |
var.idx <- match(partable$lhs[par.idx], ov.names) |
| 230 | 65x |
upper.auto[par.idx] <- OV.VAR[var.idx] |
| 231 | ||
| 232 |
# if reliability > 0, adapt marker indicators only |
|
| 233 | 65x |
if (REL > 0) {
|
| 234 | ! |
marker.idx <- which(partable$group == group.values[g] & |
| 235 | ! |
partable$op == "~~" & |
| 236 | ! |
partable$lhs %in% lv.marker & |
| 237 | ! |
partable$lhs == partable$rhs) |
| 238 | ! |
marker.var.idx <- match(partable$lhs[marker.idx], ov.names) |
| 239 | ||
| 240 |
# upper = (1-REL)*OVAR |
|
| 241 | ! |
upper.auto[marker.idx] <- (1 - REL) * OV.VAR[marker.var.idx] |
| 242 |
} |
|
| 243 | ||
| 244 |
# range |
|
| 245 | 65x |
bound.range <- upper.auto[par.idx] - pmax(lower.auto[par.idx], 0) |
| 246 | ||
| 247 |
# enlarge lower? |
|
| 248 | 65x |
if ("ov.var" %in% optim.bounds$lower) {
|
| 249 | 65x |
factor <- lower.factor[which(optim.bounds$lower == "ov.var")] |
| 250 | 65x |
if (is.finite(factor) && factor != 1.0) {
|
| 251 | ! |
new.range <- bound.range * factor |
| 252 | ! |
diff <- abs(new.range - bound.range) |
| 253 | ! |
lower.auto[par.idx] <- lower.auto[par.idx] - diff |
| 254 |
} |
|
| 255 |
} |
|
| 256 | ||
| 257 |
# enlarge upper? |
|
| 258 | 65x |
if ("ov.var" %in% optim.bounds$upper) {
|
| 259 | ! |
factor <- upper.factor[which(optim.bounds$upper == "ov.var")] |
| 260 | ! |
if (is.finite(factor) && factor != 1.0) {
|
| 261 | ! |
new.range <- bound.range * factor |
| 262 | ! |
diff <- abs(new.range - bound.range) |
| 263 | ! |
upper.auto[par.idx] <- upper.auto[par.idx] + diff |
| 264 | ! |
} else if (is.finite(factor) && factor == 1.0) {
|
| 265 |
# new in 0.6-20 |
|
| 266 |
# enlarge anyway, but only with 0.5% |
|
| 267 |
# this is in particular useful for exogenous variances, otherwise, |
|
| 268 |
# they will always end up on the boundary |
|
| 269 | ! |
new.range <- bound.range * 1.005 |
| 270 | ! |
diff <- abs(new.range - bound.range) |
| 271 | ! |
upper.auto[par.idx] <- upper.auto[par.idx] + diff |
| 272 |
} |
|
| 273 |
} |
|
| 274 | ||
| 275 |
# min.var.ov? |
|
| 276 | 65x |
min.idx <- which(lower.auto[par.idx] < optim.bounds$min.var.ov) |
| 277 | 65x |
if (length(min.idx) > 0L) {
|
| 278 | ! |
lower.auto[par.idx[min.idx]] <- optim.bounds$min.var.ov |
| 279 |
} |
|
| 280 | ||
| 281 |
# requested? |
|
| 282 | 65x |
if ("ov.var" %in% optim.bounds$lower) {
|
| 283 | 65x |
partable$lower[par.idx] <- lower.auto[par.idx] |
| 284 |
} |
|
| 285 | 65x |
if ("ov.var" %in% optim.bounds$upper) {
|
| 286 | ! |
partable$upper[par.idx] <- upper.auto[par.idx] |
| 287 |
} |
|
| 288 |
} # (res) ov variances |
|
| 289 | ||
| 290 |
################################ |
|
| 291 |
## 2. (residual) lv variances ## |
|
| 292 |
################################ |
|
| 293 | ||
| 294 |
# first collect lower/upper bounds for TOTAL variances in lv.names |
|
| 295 | 65x |
LV.VAR.LB <- numeric(length(lv.names)) |
| 296 | 65x |
LV.VAR.UB <- numeric(length(lv.names)) |
| 297 | ||
| 298 | 65x |
if (lavoptions$std.lv) {
|
| 299 | ! |
LV.VAR.LB <- rep(1.0, length(lv.names)) |
| 300 | ! |
LV.VAR.UB <- rep(1.0, length(lv.names)) |
| 301 |
} else {
|
|
| 302 | 65x |
for (i in seq_len(length(lv.names))) {
|
| 303 | 10x |
this.lv.name <- lv.names[i] |
| 304 | 10x |
this.lv.marker <- lv.marker[i] |
| 305 | ||
| 306 | 10x |
if (nchar(this.lv.marker) > 0L && this.lv.marker %in% ov.names) {
|
| 307 | ! |
marker.var <- OV.VAR[match(this.lv.marker, ov.names)] |
| 308 | ! |
LOWER <- marker.var - (1 - REL) * marker.var |
| 309 | ! |
LV.VAR.LB[i] <- max(LOWER, optim.bounds$min.var.lv.exo) |
| 310 |
# LV.VAR.UB[i] <- marker.var - REL*marker.var |
|
| 311 | ! |
LV.VAR.UB[i] <- marker.var |
| 312 | ||
| 313 |
# new in 0.6-17 |
|
| 314 | ! |
if (theta.parameterization.flag) {
|
| 315 | ! |
LV.VAR.LB[i] <- REL |
| 316 |
} |
|
| 317 |
} else {
|
|
| 318 | 10x |
LV.VAR.LB[i] <- optim.bounds$min.var.lv.exo |
| 319 | 10x |
LV.VAR.UB[i] <- max(OV.VAR) |
| 320 |
} |
|
| 321 |
} |
|
| 322 |
} |
|
| 323 | ||
| 324 |
# use these bounds for the free parameters |
|
| 325 | 65x |
par.idx <- which(partable$group == group.values[g] & |
| 326 | 65x |
partable$op == "~~" & |
| 327 | 65x |
partable$lhs %in% lv.names & |
| 328 | 65x |
partable$lhs == partable$rhs) |
| 329 | ||
| 330 | 65x |
if (length(par.idx) > 0L) {
|
| 331 |
# adjust for endogenenous lv |
|
| 332 | 4x |
LV.VAR.LB2 <- LV.VAR.LB |
| 333 | 4x |
endo.idx <- which(lv.names %in% lv.names.endo) |
| 334 | 4x |
if (length(endo.idx) > 0L) {
|
| 335 | ! |
LV.VAR.LB2[endo.idx] <- optim.bounds$min.var.lv.endo |
| 336 | ! |
if (optim.bounds$max.r2.lv.endo != 1) {
|
| 337 | ! |
LV.VAR.LB2[endo.idx] <- (1 - optim.bounds$max.r2.lv.endo) * LV.VAR.UB[endo.idx] |
| 338 |
} |
|
| 339 |
} |
|
| 340 | 4x |
exo.idx <- which(!lv.names %in% lv.names.endo) |
| 341 | 4x |
if (length(exo.idx) > 0L && optim.bounds$min.var.lv.exo != 0) {
|
| 342 | ! |
LV.VAR.LB2[exo.idx] <- optim.bounds$min.var.lv.exo |
| 343 |
} |
|
| 344 | ||
| 345 | 4x |
lower.auto[par.idx] <- LV.VAR.LB2[match( |
| 346 | 4x |
partable$lhs[par.idx], |
| 347 | 4x |
lv.names |
| 348 |
)] |
|
| 349 | 4x |
upper.auto[par.idx] <- LV.VAR.UB[match( |
| 350 | 4x |
partable$lhs[par.idx], |
| 351 | 4x |
lv.names |
| 352 |
)] |
|
| 353 | ||
| 354 |
# range |
|
| 355 | 4x |
bound.range <- upper.auto[par.idx] - pmax(lower.auto[par.idx], 0) |
| 356 | ||
| 357 |
# enlarge lower? |
|
| 358 | 4x |
if ("lv.var" %in% optim.bounds$lower) {
|
| 359 | 4x |
factor <- lower.factor[which(optim.bounds$lower == "lv.var")] |
| 360 | 4x |
if (is.finite(factor) && factor != 1.0) {
|
| 361 | ! |
new.range <- bound.range * factor |
| 362 | ! |
diff <- abs(new.range - bound.range) |
| 363 | ! |
lower.auto[par.idx] <- lower.auto[par.idx] - diff |
| 364 |
} |
|
| 365 |
} |
|
| 366 | ||
| 367 |
# enlarge upper? |
|
| 368 | 4x |
if ("lv.var" %in% optim.bounds$upper) {
|
| 369 | ! |
factor <- upper.factor[which(optim.bounds$upper == "lv.var")] |
| 370 | ! |
if (is.finite(factor) && factor != 1.0) {
|
| 371 | ! |
new.range <- bound.range * factor |
| 372 | ! |
diff <- abs(new.range - bound.range) |
| 373 | ! |
upper.auto[par.idx] <- upper.auto[par.idx] + diff |
| 374 |
} |
|
| 375 |
} |
|
| 376 | ||
| 377 |
# requested? |
|
| 378 | 4x |
if ("lv.var" %in% optim.bounds$lower) {
|
| 379 | 4x |
partable$lower[par.idx] <- lower.auto[par.idx] |
| 380 |
} |
|
| 381 | 4x |
if ("lv.var" %in% optim.bounds$upper) {
|
| 382 | ! |
partable$upper[par.idx] <- upper.auto[par.idx] |
| 383 |
} |
|
| 384 |
} # lv variances |
|
| 385 | ||
| 386 | ||
| 387 |
############################################# |
|
| 388 |
## 3. factor loadings (ov indicators only) ## |
|
| 389 |
############################################# |
|
| 390 | ||
| 391 |
# lambda_p^(u) = sqrt( upper(res.var.indicators_p) / |
|
| 392 |
# lower(var.factor) ) |
|
| 393 | ||
| 394 | 65x |
ov.ind.names <- lavpta$vnames$ov.ind[[b]] |
| 395 | 65x |
par.idx <- which(partable$group == group.values[g] & |
| 396 | 65x |
partable$op == "=~" & |
| 397 | 65x |
partable$lhs %in% lv.names & |
| 398 | 65x |
partable$rhs %in% ov.ind.names) |
| 399 | ||
| 400 | 65x |
if (length(par.idx) > 0L) {
|
| 401 |
# if negative LV variances are allowed (due to factor > 1) |
|
| 402 |
# make them equal to zero |
|
| 403 | 4x |
LV.VAR.LB[LV.VAR.LB < 0] <- 0.0 |
| 404 | ||
| 405 | 4x |
var.all <- OV.VAR[match(partable$rhs[par.idx], ov.names)] |
| 406 | 4x |
tmp <- LV.VAR.LB[match(partable$lhs[par.idx], lv.names)] |
| 407 | 4x |
tmp[is.na(tmp)] <- 0 # just in case... |
| 408 | 4x |
lower.auto[par.idx] <- -1 * sqrt(var.all / tmp) # -Inf if tmp==0 |
| 409 | 4x |
upper.auto[par.idx] <- +1 * sqrt(var.all / tmp) # +Inf if tmp==0 |
| 410 | ||
| 411 |
# if std.lv = TRUE, force 'first' loading to be positive? |
|
| 412 |
# if(lavoptions$std.lv) {
|
|
| 413 |
# # get index 'first' indicators |
|
| 414 |
# first.idx <- which(!duplicated(partable$lhs[par.idx])) |
|
| 415 |
# lower.auto[par.idx][first.idx] <- 0 |
|
| 416 |
# } |
|
| 417 | ||
| 418 |
# range |
|
| 419 | 4x |
bound.range <- upper.auto[par.idx] - lower.auto[par.idx] |
| 420 | ||
| 421 |
# enlarge lower? |
|
| 422 | 4x |
if ("loadings" %in% optim.bounds$lower) {
|
| 423 | ! |
factor <- lower.factor[which(optim.bounds$lower == "loadings")] |
| 424 | ! |
if (is.finite(factor) && factor != 1.0) {
|
| 425 | ! |
new.range <- bound.range * factor |
| 426 | ! |
ok.idx <- is.finite(new.range) |
| 427 | ! |
if (length(ok.idx) > 0L) {
|
| 428 | ! |
diff <- abs(new.range[ok.idx] - bound.range[ok.idx]) |
| 429 | ! |
lower.auto[par.idx][ok.idx] <- |
| 430 | ! |
lower.auto[par.idx][ok.idx] - diff |
| 431 |
} |
|
| 432 |
} |
|
| 433 |
} |
|
| 434 | ||
| 435 |
# enlarge upper? |
|
| 436 | 4x |
if ("loadings" %in% optim.bounds$upper) {
|
| 437 | ! |
factor <- upper.factor[which(optim.bounds$upper == "loadings")] |
| 438 | ! |
if (is.finite(factor) && factor != 1.0) {
|
| 439 | ! |
new.range <- bound.range * factor |
| 440 | ! |
ok.idx <- is.finite(new.range) |
| 441 | ! |
if (length(ok.idx) > 0L) {
|
| 442 | ! |
diff <- abs(new.range[ok.idx] - bound.range[ok.idx]) |
| 443 | ! |
upper.auto[par.idx][ok.idx] <- |
| 444 | ! |
upper.auto[par.idx][ok.idx] + diff |
| 445 |
} |
|
| 446 |
} |
|
| 447 |
} |
|
| 448 | ||
| 449 | ||
| 450 | ||
| 451 |
# requested? |
|
| 452 | 4x |
if ("loadings" %in% optim.bounds$lower) {
|
| 453 | ! |
partable$lower[par.idx] <- lower.auto[par.idx] |
| 454 |
} |
|
| 455 | 4x |
if ("loadings" %in% optim.bounds$upper) {
|
| 456 | ! |
partable$upper[par.idx] <- upper.auto[par.idx] |
| 457 |
} |
|
| 458 |
} # lambda |
|
| 459 | ||
| 460 | ||
| 461 |
#################### |
|
| 462 |
## 4. covariances ## |
|
| 463 |
#################### |
|
| 464 | ||
| 465 |
# | sqrt(var(x)) sqrt(var(y)) | <= cov(x,y) |
|
| 466 | ||
| 467 | 65x |
par.idx <- which(partable$group == group.values[g] & |
| 468 | 65x |
partable$op == "~~" & |
| 469 | 65x |
partable$lhs != partable$rhs) |
| 470 | ||
| 471 | 65x |
if (length(par.idx) > 0L) {
|
| 472 | 29x |
for (i in seq_len(length(par.idx))) {
|
| 473 |
# this lhs/rhs |
|
| 474 | 88x |
this.lhs <- partable$lhs[par.idx[i]] |
| 475 | 88x |
this.rhs <- partable$rhs[par.idx[i]] |
| 476 | ||
| 477 |
# 2 possibilities: |
|
| 478 |
# - variances are free parameters |
|
| 479 |
# - variances are fixed (eg std.lv = TRUE) |
|
| 480 | ||
| 481 |
# var idx |
|
| 482 | 88x |
lhs.var.idx <- which(partable$group == group.values[g] & |
| 483 | 88x |
partable$op == "~~" & |
| 484 | 88x |
partable$lhs == this.lhs & |
| 485 | 88x |
partable$lhs == partable$rhs) |
| 486 | 88x |
rhs.var.idx <- which(partable$group == group.values[g] & |
| 487 | 88x |
partable$op == "~~" & |
| 488 | 88x |
partable$lhs == this.rhs & |
| 489 | 88x |
partable$lhs == partable$rhs) |
| 490 |
# upper bounds |
|
| 491 | 88x |
lhs.upper <- upper.auto[lhs.var.idx] |
| 492 | 88x |
rhs.upper <- upper.auto[rhs.var.idx] |
| 493 | ||
| 494 |
# compute upper bounds for this cov (assuming >0 vars) |
|
| 495 | 88x |
if (is.finite(lhs.upper) && is.finite(rhs.upper)) {
|
| 496 | 88x |
upper.cov <- sqrt(lhs.upper) * sqrt(rhs.upper) |
| 497 | 88x |
upper.auto[par.idx[i]] <- +1 * upper.cov |
| 498 | 88x |
lower.auto[par.idx[i]] <- -1 * upper.cov |
| 499 |
} |
|
| 500 |
} |
|
| 501 | ||
| 502 |
# range |
|
| 503 | 29x |
bound.range <- upper.auto[par.idx] - lower.auto[par.idx] |
| 504 | ||
| 505 |
# enlarge lower? |
|
| 506 | 29x |
if ("covariances" %in% optim.bounds$lower) {
|
| 507 | ! |
factor <- |
| 508 | ! |
lower.factor[which(optim.bounds$lower == "covariances")] |
| 509 | ! |
if (is.finite(factor) && factor != 1.0) {
|
| 510 | ! |
new.range <- bound.range * factor |
| 511 | ! |
ok.idx <- is.finite(new.range) |
| 512 | ! |
if (length(ok.idx) > 0L) {
|
| 513 | ! |
diff <- new.range[ok.idx] - bound.range[ok.idx] |
| 514 | ! |
lower.auto[par.idx][ok.idx] <- |
| 515 | ! |
lower.auto[par.idx][ok.idx] - diff |
| 516 |
} |
|
| 517 |
} |
|
| 518 |
} |
|
| 519 | ||
| 520 |
# enlarge upper? |
|
| 521 | 29x |
if ("covariances" %in% optim.bounds$upper) {
|
| 522 | ! |
factor <- |
| 523 | ! |
upper.factor[which(optim.bounds$upper == "covariances")] |
| 524 | ! |
if (is.finite(factor) && factor != 1.0) {
|
| 525 | ! |
new.range <- bound.range * factor |
| 526 | ! |
ok.idx <- is.finite(new.range) |
| 527 | ! |
if (length(ok.idx) > 0L) {
|
| 528 | ! |
diff <- new.range[ok.idx] - bound.range[ok.idx] |
| 529 | ! |
upper.auto[par.idx][ok.idx] <- |
| 530 | ! |
upper.auto[par.idx][ok.idx] + diff |
| 531 |
} |
|
| 532 |
} |
|
| 533 |
} |
|
| 534 | ||
| 535 |
# requested? |
|
| 536 | 29x |
if ("covariances" %in% optim.bounds$lower) {
|
| 537 | ! |
partable$lower[par.idx] <- lower.auto[par.idx] |
| 538 |
} |
|
| 539 | 29x |
if ("covariances" %in% optim.bounds$upper) {
|
| 540 | ! |
partable$upper[par.idx] <- upper.auto[par.idx] |
| 541 |
} |
|
| 542 |
} # covariances |
|
| 543 |
} # g |
|
| 544 | ||
| 545 |
# overwrite with lower.user (except -Inf) |
|
| 546 | 63x |
not.inf.idx <- which(lower.user > -Inf) |
| 547 | 63x |
if (length(not.inf.idx) > 0L) {
|
| 548 | ! |
partable$lower[not.inf.idx] <- lower.user[not.inf.idx] |
| 549 |
} |
|
| 550 | ||
| 551 |
# overwrite with upper.user (except +Inf) |
|
| 552 | 63x |
not.inf.idx <- which(upper.user < +Inf) |
| 553 | 63x |
if (length(not.inf.idx) > 0L) {
|
| 554 | ! |
partable$upper[not.inf.idx] <- upper.user[not.inf.idx] |
| 555 |
} |
|
| 556 | ||
| 557 |
# non-free |
|
| 558 | 63x |
non.free.idx <- which(partable$free == 0L) |
| 559 | 63x |
if (length(non.free.idx) > 0L && !is.null(partable$ustart)) {
|
| 560 | 30x |
partable$lower[non.free.idx] <- partable$ustart[non.free.idx] |
| 561 | 30x |
partable$upper[non.free.idx] <- partable$ustart[non.free.idx] |
| 562 |
} |
|
| 563 | ||
| 564 | 63x |
partable |
| 565 |
} |
| 1 |
# This function was written in January 2012 -- Yves Rosseel |
|
| 2 |
# First success: Friday 20 Jan 2012: the standard errors for |
|
| 3 |
# thresholds and polychoric correlations (in an |
|
| 4 |
# unrestricted/saturated model) are spot on! |
|
| 5 |
# Second success: Saturday 9 June 2012: support for mixed (ordinal + metric) |
|
| 6 |
# variables; thanks to the delta method to get the ACOV |
|
| 7 |
# right (see H matrix) |
|
| 8 |
# Third success: Monday 2 July 2012: support for fixed.x covariates |
|
| 9 |
# |
|
| 10 |
# Friday 13 July 2012: merge exo + non-exo code |
|
| 11 |
# Monday 16 July 2012: fixed sign numeric in WLS.W; I think we got it right now |
|
| 12 | ||
| 13 |
# YR 26 Nov 2015: move step1 + step2 to external functions |
|
| 14 |
# |
|
| 15 |
muthen1984 <- function(Data = NULL, |
|
| 16 |
ov.names = NULL, |
|
| 17 |
ov.types = NULL, |
|
| 18 |
ov.levels = NULL, |
|
| 19 |
ov.names.x = character(0L), |
|
| 20 |
eXo = NULL, |
|
| 21 |
wt = NULL, |
|
| 22 |
WLS.W = TRUE, |
|
| 23 |
zero.add = c(0.5, 0.0), |
|
| 24 |
zero.keep.margins = TRUE, |
|
| 25 |
zero.cell.warn = FALSE, |
|
| 26 |
zero.cell.tables = TRUE, |
|
| 27 |
allow.empty.cell = TRUE, |
|
| 28 |
group = 1L) { # group only for error messages
|
|
| 29 | ||
| 30 |
# just in case Data is a vector |
|
| 31 | 2x |
Data <- as.matrix(Data) |
| 32 | ||
| 33 | 2x |
nvar <- NCOL(Data) |
| 34 | 2x |
N <- NROW(Data) |
| 35 | 2x |
num.idx <- which(ov.types == "numeric") |
| 36 | 2x |
ord.idx <- which(ov.types == "ordered") |
| 37 | 2x |
nexo <- length(ov.names.x) |
| 38 | 2x |
if (nexo > 0L) stopifnot(NCOL(eXo) == nexo) |
| 39 | 2x |
pstar <- nvar * (nvar - 1) / 2 |
| 40 | ||
| 41 | 2x |
if (lav_verbose()) {
|
| 42 | ! |
cat("\nPreparing for WLS estimation -- STEP 1 + 2\n")
|
| 43 | ! |
cat("Number of endogenous variables: ", nvar, "\n")
|
| 44 | ! |
cat("Endogenous variable names:\n")
|
| 45 | ! |
print(ov.names) |
| 46 | ! |
cat("\n")
|
| 47 | ! |
cat("Endogenous ov types:\n")
|
| 48 | ! |
print(ov.types) |
| 49 | ! |
cat("\n")
|
| 50 | ! |
cat("Endogenous ov levels:\n ")
|
| 51 | ! |
print(ov.levels) |
| 52 | ! |
cat("\n")
|
| 53 | ! |
cat("Number of exogenous variables: ", nexo, "\n")
|
| 54 | ! |
cat("Exogenous variable names:\n")
|
| 55 | ! |
print(ov.names.x) |
| 56 | ! |
cat("\n")
|
| 57 |
} |
|
| 58 | ||
| 59 | 2x |
step1 <- lav_samplestats_step1( |
| 60 | 2x |
Y = Data, wt = wt, ov.names = ov.names, |
| 61 | 2x |
ov.types = ov.types, ov.levels = ov.levels, ov.names.x = ov.names.x, |
| 62 | 2x |
eXo = eXo, scores.flag = WLS.W, allow.empty.cell = allow.empty.cell, group = group |
| 63 |
) |
|
| 64 | ||
| 65 | 2x |
FIT <- step1$FIT |
| 66 | 2x |
TH <- step1$TH |
| 67 | 2x |
TH.NOX <- step1$TH.NOX |
| 68 | 2x |
TH.IDX <- step1$TH.IDX |
| 69 | 2x |
TH.NAMES <- step1$TH.NAMES |
| 70 | 2x |
VAR <- step1$VAR |
| 71 | 2x |
SLOPES <- step1$SLOPES |
| 72 | 2x |
SC.TH <- step1$SC.TH |
| 73 | 2x |
SC.SL <- step1$SC.SL |
| 74 | 2x |
SC.VAR <- step1$SC.VAR |
| 75 | 2x |
th.start.idx <- step1$th.start.idx |
| 76 | 2x |
th.end.idx <- step1$th.end.idx |
| 77 | ||
| 78 |
# rm SC.VAR columns from ordinal variables |
|
| 79 | 2x |
if (WLS.W && length(ord.idx) > 0L) {
|
| 80 | 2x |
SC.VAR <- SC.VAR[, -ord.idx, drop = FALSE] |
| 81 |
} |
|
| 82 | ||
| 83 | ||
| 84 | 2x |
if (lav_verbose()) {
|
| 85 | ! |
cat("STEP 1: univariate statistics\n")
|
| 86 | ! |
cat("Threshold + means:\n")
|
| 87 | ! |
TTHH <- unlist(TH) |
| 88 | ! |
names(TTHH) <- unlist(TH.NAMES) |
| 89 | ! |
print(TTHH) |
| 90 | ! |
cat("Slopes (if any):\n")
|
| 91 | ! |
colnames(SLOPES) <- ov.names.x |
| 92 | ! |
rownames(SLOPES) <- ov.names |
| 93 | ! |
print(SLOPES) |
| 94 | ! |
cat("Variances:\n")
|
| 95 | ! |
names(VAR) <- ov.names |
| 96 | ! |
print(unlist(VAR)) |
| 97 |
} |
|
| 98 | ||
| 99 |
# stage two -- correlations |
|
| 100 | ||
| 101 | ! |
if (lav_verbose()) cat("\n\nSTEP 2: covariances/correlations:\n")
|
| 102 | 2x |
COR <- lav_samplestats_step2( |
| 103 | 2x |
UNI = FIT, wt = wt, ov.names = ov.names, |
| 104 | 2x |
zero.add = zero.add, |
| 105 | 2x |
zero.keep.margins = zero.keep.margins, |
| 106 | 2x |
zero.cell.warn = zero.cell.warn, |
| 107 | 2x |
zero.cell.tables = zero.cell.tables |
| 108 |
) |
|
| 109 | 2x |
empty.cell.tables <- attr(COR, "zero.cell.tables") |
| 110 | 2x |
attr(COR, "zero.cell.tables") <- NULL |
| 111 | ||
| 112 | 2x |
if (lav_verbose()) {
|
| 113 | ! |
colnames(COR) <- rownames(COR) <- ov.names |
| 114 | ! |
print(COR) |
| 115 |
} |
|
| 116 | ||
| 117 | 2x |
if (!WLS.W) { # we do not need the asymptotic variance matrix
|
| 118 | ! |
if (any("numeric" %in% ov.types)) {
|
| 119 | ! |
COV <- lav_cor2cov(R = COR, sds = sqrt(unlist(VAR))) |
| 120 |
} else {
|
|
| 121 | ! |
COV <- COR |
| 122 |
} |
|
| 123 | ! |
out <- list( |
| 124 | ! |
TH = TH, SLOPES = SLOPES, VAR = VAR, COR = COR, COV = COV, |
| 125 | ! |
SC = NULL, TH.NOX = TH.NOX, TH.NAMES = TH.NAMES, TH.IDX = TH.IDX, |
| 126 | ! |
INNER = NULL, A11 = NULL, A12 = NULL, A21 = NULL, A22 = NULL, |
| 127 | ! |
WLS.W = NULL, H = NULL, zero.cell.tables = matrix("", 0, 2)
|
| 128 |
) |
|
| 129 | ! |
return(out) |
| 130 |
} |
|
| 131 | ||
| 132 | ||
| 133 |
# stage three -- WLS.W |
|
| 134 | 2x |
SC.COR <- matrix(0, N, pstar) |
| 135 | 2x |
PSTAR <- matrix(0, nvar, nvar) |
| 136 | 2x |
PSTAR[lav_matrix_vech_idx(nvar, diagonal = FALSE)] <- 1:pstar |
| 137 | ||
| 138 | 2x |
A11.size <- NCOL(SC.TH) + NCOL(SC.SL) + NCOL(SC.VAR) |
| 139 | ||
| 140 | ||
| 141 | ||
| 142 | ||
| 143 | ||
| 144 | ||
| 145 | ||
| 146 | ||
| 147 |
# A21 |
|
| 148 | 2x |
A21 <- matrix(0, pstar, A11.size) |
| 149 | 2x |
H22 <- diag(pstar) # for the delta rule |
| 150 | 2x |
H21 <- matrix(0, pstar, A11.size) |
| 151 |
# for this one, we need new scores: for each F_ij (cor), the |
|
| 152 |
# scores with respect to the TH, VAR, ... |
|
| 153 | 2x |
for (j in seq_len(nvar - 1L)) {
|
| 154 | 26x |
for (i in (j + 1L):nvar) {
|
| 155 | 182x |
pstar.idx <- PSTAR[i, j] |
| 156 | 182x |
th.idx_i <- th.start.idx[i]:th.end.idx[i] |
| 157 | 182x |
th.idx_j <- th.start.idx[j]:th.end.idx[j] |
| 158 | 182x |
if (nexo > 0L) {
|
| 159 | 182x |
sl.idx_i <- NCOL(SC.TH) + seq(i, by = nvar, length.out = nexo) |
| 160 | 182x |
sl.idx_j <- NCOL(SC.TH) + seq(j, by = nvar, length.out = nexo) |
| 161 | ||
| 162 | 182x |
var.idx_i <- NCOL(SC.TH) + NCOL(SC.SL) + match(i, num.idx) |
| 163 | 182x |
var.idx_j <- NCOL(SC.TH) + NCOL(SC.SL) + match(j, num.idx) |
| 164 |
} else {
|
|
| 165 | ! |
var.idx_i <- NCOL(SC.TH) + match(i, num.idx) |
| 166 | ! |
var.idx_j <- NCOL(SC.TH) + match(j, num.idx) |
| 167 |
} |
|
| 168 | 182x |
if (ov.types[i] == "numeric" && ov.types[j] == "numeric") {
|
| 169 | 90x |
SC.COR.UNI <- lav_bvreg_cor_scores( |
| 170 | 90x |
rho = COR[i, j], |
| 171 | 90x |
fit.y1 = FIT[[i]], |
| 172 | 90x |
fit.y2 = FIT[[j]], |
| 173 | 90x |
wt = wt |
| 174 |
) |
|
| 175 | ||
| 176 |
# RHO |
|
| 177 | 90x |
if (is.null(wt)) {
|
| 178 | 90x |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho |
| 179 |
} else {
|
|
| 180 | ! |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight |
| 181 |
} |
|
| 182 | ||
| 183 |
# TH |
|
| 184 | 90x |
A21[pstar.idx, th.idx_i] <- |
| 185 | 90x |
lav_matrix_crossprod( |
| 186 | 90x |
SC.COR[, pstar.idx], |
| 187 | 90x |
SC.COR.UNI$dx.mu.y1 |
| 188 |
) |
|
| 189 | 90x |
A21[pstar.idx, th.idx_j] <- |
| 190 | 90x |
lav_matrix_crossprod( |
| 191 | 90x |
SC.COR[, pstar.idx], |
| 192 | 90x |
SC.COR.UNI$dx.mu.y2 |
| 193 |
) |
|
| 194 |
# SL |
|
| 195 | 90x |
if (nexo > 0L) {
|
| 196 | 90x |
A21[pstar.idx, sl.idx_i] <- |
| 197 | 90x |
lav_matrix_crossprod( |
| 198 | 90x |
SC.COR[, pstar.idx], |
| 199 | 90x |
SC.COR.UNI$dx.sl.y1 |
| 200 |
) |
|
| 201 | 90x |
A21[pstar.idx, sl.idx_j] <- |
| 202 | 90x |
lav_matrix_crossprod( |
| 203 | 90x |
SC.COR[, pstar.idx], |
| 204 | 90x |
SC.COR.UNI$dx.sl.y2 |
| 205 |
) |
|
| 206 |
} |
|
| 207 |
# VAR |
|
| 208 | 90x |
A21[pstar.idx, var.idx_i] <- |
| 209 | 90x |
lav_matrix_crossprod( |
| 210 | 90x |
SC.COR[, pstar.idx], |
| 211 | 90x |
SC.COR.UNI$dx.var.y1 |
| 212 |
) |
|
| 213 | 90x |
A21[pstar.idx, var.idx_j] <- |
| 214 | 90x |
lav_matrix_crossprod( |
| 215 | 90x |
SC.COR[, pstar.idx], |
| 216 | 90x |
SC.COR.UNI$dx.var.y2 |
| 217 |
) |
|
| 218 |
# H21 only needed for VAR |
|
| 219 | 90x |
H21[pstar.idx, var.idx_i] <- |
| 220 | 90x |
(sqrt(VAR[j]) * COR[i, j]) / (2 * sqrt(VAR[i])) |
| 221 | 90x |
H21[pstar.idx, var.idx_j] <- |
| 222 | 90x |
(sqrt(VAR[i]) * COR[i, j]) / (2 * sqrt(VAR[j])) |
| 223 | 90x |
H22[pstar.idx, pstar.idx] <- sqrt(VAR[i]) * sqrt(VAR[j]) |
| 224 | 92x |
} else if (ov.types[i] == "numeric" && ov.types[j] == "ordered") {
|
| 225 | 32x |
SC.COR.UNI <- lav_bvmix_cor_scores( |
| 226 | 32x |
rho = COR[i, j], |
| 227 | 32x |
fit.y1 = FIT[[i]], |
| 228 | 32x |
fit.y2 = FIT[[j]], |
| 229 | 32x |
wt = wt |
| 230 |
) |
|
| 231 |
# RHO |
|
| 232 | 32x |
if (is.null(wt)) {
|
| 233 | 32x |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho |
| 234 |
} else {
|
|
| 235 | ! |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight |
| 236 |
} |
|
| 237 | ||
| 238 |
# TH |
|
| 239 | 32x |
A21[pstar.idx, th.idx_i] <- |
| 240 | 32x |
lav_matrix_crossprod( |
| 241 | 32x |
SC.COR[, pstar.idx], |
| 242 | 32x |
SC.COR.UNI$dx.mu.y1 |
| 243 |
) |
|
| 244 | 32x |
A21[pstar.idx, th.idx_j] <- |
| 245 | 32x |
lav_matrix_crossprod( |
| 246 | 32x |
SC.COR[, pstar.idx], |
| 247 | 32x |
SC.COR.UNI$dx.th.y2 |
| 248 |
) |
|
| 249 |
# SL |
|
| 250 | 32x |
if (nexo > 0L) {
|
| 251 | 32x |
A21[pstar.idx, sl.idx_i] <- |
| 252 | 32x |
lav_matrix_crossprod( |
| 253 | 32x |
SC.COR[, pstar.idx], |
| 254 | 32x |
SC.COR.UNI$dx.sl.y1 |
| 255 |
) |
|
| 256 | 32x |
A21[pstar.idx, sl.idx_j] <- |
| 257 | 32x |
lav_matrix_crossprod( |
| 258 | 32x |
SC.COR[, pstar.idx], |
| 259 | 32x |
SC.COR.UNI$dx.sl.y2 |
| 260 |
) |
|
| 261 |
} |
|
| 262 |
# VAR |
|
| 263 | 32x |
A21[pstar.idx, var.idx_i] <- |
| 264 | 32x |
lav_matrix_crossprod( |
| 265 | 32x |
SC.COR[, pstar.idx], |
| 266 | 32x |
SC.COR.UNI$dx.var.y1 |
| 267 |
) |
|
| 268 |
# H21 only need for VAR |
|
| 269 | 32x |
H21[pstar.idx, var.idx_i] <- COR[i, j] / (2 * sqrt(VAR[i])) |
| 270 | 32x |
H22[pstar.idx, pstar.idx] <- sqrt(VAR[i]) |
| 271 | 60x |
} else if (ov.types[j] == "numeric" && ov.types[i] == "ordered") {
|
| 272 | 48x |
SC.COR.UNI <- lav_bvmix_cor_scores( |
| 273 | 48x |
rho = COR[i, j], |
| 274 | 48x |
fit.y1 = FIT[[j]], |
| 275 | 48x |
fit.y2 = FIT[[i]], |
| 276 | 48x |
wt = wt |
| 277 |
) |
|
| 278 |
# RHO |
|
| 279 | 48x |
if (is.null(wt)) {
|
| 280 | 48x |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho |
| 281 |
} else {
|
|
| 282 | ! |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight |
| 283 |
} |
|
| 284 | ||
| 285 |
# TH |
|
| 286 | 48x |
A21[pstar.idx, th.idx_j] <- |
| 287 | 48x |
lav_matrix_crossprod( |
| 288 | 48x |
SC.COR[, pstar.idx], |
| 289 | 48x |
SC.COR.UNI$dx.mu.y1 |
| 290 |
) |
|
| 291 | 48x |
A21[pstar.idx, th.idx_i] <- |
| 292 | 48x |
lav_matrix_crossprod( |
| 293 | 48x |
SC.COR[, pstar.idx], |
| 294 | 48x |
SC.COR.UNI$dx.th.y2 |
| 295 |
) |
|
| 296 |
# SL |
|
| 297 | 48x |
if (nexo > 0L) {
|
| 298 | 48x |
A21[pstar.idx, sl.idx_j] <- |
| 299 | 48x |
lav_matrix_crossprod( |
| 300 | 48x |
SC.COR[, pstar.idx], |
| 301 | 48x |
SC.COR.UNI$dx.sl.y1 |
| 302 |
) |
|
| 303 | 48x |
A21[pstar.idx, sl.idx_i] <- |
| 304 | 48x |
lav_matrix_crossprod( |
| 305 | 48x |
SC.COR[, pstar.idx], |
| 306 | 48x |
SC.COR.UNI$dx.sl.y2 |
| 307 |
) |
|
| 308 |
} |
|
| 309 |
# VAR |
|
| 310 | 48x |
A21[pstar.idx, var.idx_j] <- |
| 311 | 48x |
lav_matrix_crossprod( |
| 312 | 48x |
SC.COR[, pstar.idx], |
| 313 | 48x |
SC.COR.UNI$dx.var.y1 |
| 314 |
) |
|
| 315 |
# H21 only for VAR |
|
| 316 | 48x |
H21[pstar.idx, var.idx_j] <- COR[i, j] / (2 * sqrt(VAR[j])) |
| 317 | 48x |
H22[pstar.idx, pstar.idx] <- sqrt(VAR[j]) |
| 318 | 12x |
} else if (ov.types[i] == "ordered" && ov.types[j] == "ordered") {
|
| 319 |
# polychoric correlation |
|
| 320 | 12x |
SC.COR.UNI <- lav_bvord_cor_scores( |
| 321 | 12x |
rho = COR[i, j], |
| 322 | 12x |
fit.y1 = FIT[[i]], |
| 323 | 12x |
fit.y2 = FIT[[j]], |
| 324 | 12x |
wt = wt |
| 325 |
) |
|
| 326 |
# RHO |
|
| 327 | 12x |
if (is.null(wt)) {
|
| 328 | 12x |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho |
| 329 |
} else {
|
|
| 330 | ! |
SC.COR[, pstar.idx] <- SC.COR.UNI$dx.rho / wt # unweight |
| 331 |
} |
|
| 332 | ||
| 333 |
# TH |
|
| 334 | 12x |
A21[pstar.idx, th.idx_i] <- |
| 335 | 12x |
lav_matrix_crossprod( |
| 336 | 12x |
SC.COR[, pstar.idx], |
| 337 | 12x |
SC.COR.UNI$dx.th.y1 |
| 338 |
) |
|
| 339 | 12x |
A21[pstar.idx, th.idx_j] <- |
| 340 | 12x |
lav_matrix_crossprod( |
| 341 | 12x |
SC.COR[, pstar.idx], |
| 342 | 12x |
SC.COR.UNI$dx.th.y2 |
| 343 |
) |
|
| 344 |
# SL |
|
| 345 | 12x |
if (nexo > 0L) {
|
| 346 | 12x |
A21[pstar.idx, sl.idx_i] <- |
| 347 | 12x |
lav_matrix_crossprod( |
| 348 | 12x |
SC.COR[, pstar.idx], |
| 349 | 12x |
SC.COR.UNI$dx.sl.y1 |
| 350 |
) |
|
| 351 | 12x |
A21[pstar.idx, sl.idx_j] <- |
| 352 | 12x |
lav_matrix_crossprod( |
| 353 | 12x |
SC.COR[, pstar.idx], |
| 354 | 12x |
SC.COR.UNI$dx.sl.y2 |
| 355 |
) |
|
| 356 |
} |
|
| 357 |
# NO VAR |
|
| 358 |
} |
|
| 359 |
} |
|
| 360 |
} |
|
| 361 | 2x |
if (!is.null(wt)) {
|
| 362 | ! |
SC.COR <- SC.COR * wt # reweight |
| 363 |
} |
|
| 364 | ||
| 365 | ||
| 366 | ||
| 367 | ||
| 368 | ||
| 369 |
# stage three |
|
| 370 | ||
| 371 | 2x |
SC <- cbind(SC.TH, SC.SL, SC.VAR, SC.COR) |
| 372 | 2x |
INNER <- lav_matrix_crossprod(SC) |
| 373 | ||
| 374 |
# A11 |
|
| 375 |
# new approach (2 June 2012): A11 is just a 'sparse' version of |
|
| 376 |
# (the left upper block of) INNER |
|
| 377 | 2x |
A11 <- matrix(0, A11.size, A11.size) |
| 378 | 2x |
if (!is.null(wt)) {
|
| 379 | ! |
INNER2 <- lav_matrix_crossprod(SC / wt, SC) |
| 380 |
} else {
|
|
| 381 | 2x |
INNER2 <- INNER |
| 382 |
} |
|
| 383 | 2x |
for (i in 1:nvar) {
|
| 384 | 28x |
th.idx <- th.start.idx[i]:th.end.idx[i] |
| 385 | 28x |
sl.idx <- integer(0L) |
| 386 | 28x |
var.idx <- integer(0L) |
| 387 | 28x |
if (nexo > 0L) {
|
| 388 | 28x |
sl.idx <- NCOL(SC.TH) + seq(i, by = nvar, length.out = nexo) |
| 389 |
# sl.end.idx <- (i*nexo); sl.start.idx <- (i-1L)*nexo + 1L |
|
| 390 |
# sl.idx <- NCOL(SC.TH) + (sl.start.idx:sl.end.idx) |
|
| 391 |
} |
|
| 392 | 28x |
if (ov.types[i] == "numeric") {
|
| 393 | 20x |
var.idx <- NCOL(SC.TH) + NCOL(SC.SL) + match(i, num.idx) |
| 394 |
} |
|
| 395 | 28x |
a11.idx <- c(th.idx, sl.idx, var.idx) |
| 396 | 28x |
A11[a11.idx, a11.idx] <- INNER2[a11.idx, a11.idx] |
| 397 |
} |
|
| 398 | ||
| 399 |
##### DEBUG ###### |
|
| 400 |
#### for numeric VAR only, use hessian to get better residual var value |
|
| 401 |
#### |
|
| 402 |
# for(i in 1:nvar) {
|
|
| 403 |
# if(ov.types[i] == "numeric") {
|
|
| 404 |
# tmp.npar <- FIT[[i]]$npar |
|
| 405 |
# e.var <- FIT[[i]]$theta[ tmp.npar ] |
|
| 406 |
# sq.e.var <- sqrt(e.var) |
|
| 407 |
# sq.e.var6 <- sq.e.var*sq.e.var*sq.e.var*sq.e.var*sq.e.var*sq.e.var |
|
| 408 |
# dx2.var <- N/(2*e.var*e.var) - 1/sq.e.var6 * (e.var * N) |
|
| 409 |
# |
|
| 410 |
# var.idx <- NCOL(SC.TH) + NCOL(SC.SL) + match(i, num.idx) |
|
| 411 |
# A11[var.idx, var.idx] <- -1 * dx2.var |
|
| 412 |
# } |
|
| 413 |
# } |
|
| 414 |
################ |
|
| 415 |
################ |
|
| 416 | ||
| 417 |
# A22 (diagonal) |
|
| 418 | 2x |
A22 <- matrix(0, pstar, pstar) |
| 419 | 2x |
for (i in seq_len(pstar)) {
|
| 420 | 182x |
if (is.null(wt)) {
|
| 421 | 182x |
A22[i, i] <- sum(SC.COR[, i] * SC.COR[, i], na.rm = TRUE) |
| 422 |
} else {
|
|
| 423 | ! |
A22[i, i] <- sum(SC.COR[, i] * SC.COR[, i] / wt, na.rm = TRUE) |
| 424 |
} |
|
| 425 |
} |
|
| 426 | ||
| 427 |
# A12 (zero) |
|
| 428 | 2x |
A12 <- matrix(0, NROW(A11), NCOL(A22)) |
| 429 | ||
| 430 | ||
| 431 |
# B <- rbind( cbind(A11,A12), |
|
| 432 |
# cbind(A21,A22) ) |
|
| 433 | ||
| 434 |
# we invert B as a block-triangular matrix (0.5-23) |
|
| 435 |
# |
|
| 436 |
# B.inv = A11^{-1} 0
|
|
| 437 |
# -A22^{-1} A21 A11^{-1} A22^{-1}
|
|
| 438 |
# |
|
| 439 | ||
| 440 |
# invert A |
|
| 441 | 2x |
A11.inv <- try(solve(A11), silent = TRUE) |
| 442 | 2x |
if (inherits(A11.inv, "try-error")) {
|
| 443 |
# brute force |
|
| 444 | ! |
A11.inv <- MASS::ginv(A11) |
| 445 | ! |
lav_msg_warn(gettext("trouble constructing W matrix;
|
| 446 | ! |
used generalized inverse for A11 submatrix")) |
| 447 |
} |
|
| 448 | ||
| 449 |
# invert |
|
| 450 | 2x |
da22 <- diag(A22) |
| 451 | 2x |
if (any(da22 == 0)) {
|
| 452 | ! |
lav_msg_warn(gettext("trouble constructing W matrix;
|
| 453 | ! |
used generalized inverse for A22 submatrix")) |
| 454 | ! |
A22.inv <- MASS::ginv(A22) |
| 455 |
} else {
|
|
| 456 | 2x |
A22.inv <- A22 |
| 457 | 2x |
diag(A22.inv) <- 1 / da22 |
| 458 |
} |
|
| 459 | ||
| 460 |
# lower-left block |
|
| 461 | 2x |
A21.inv <- -A22.inv %*% A21 %*% A11.inv |
| 462 | ||
| 463 |
# upper-left block remains zero |
|
| 464 | 2x |
A12.inv <- A12 |
| 465 | ||
| 466 |
# construct B.inv |
|
| 467 | 2x |
B.inv <- rbind( |
| 468 | 2x |
cbind(A11.inv, A12.inv), |
| 469 | 2x |
cbind(A21.inv, A22.inv) |
| 470 |
) |
|
| 471 | ||
| 472 | ||
| 473 |
# weight matrix (correlation metric) |
|
| 474 | 2x |
WLS.W <- B.inv %*% INNER %*% t(B.inv) |
| 475 | ||
| 476 |
# COV matrix? |
|
| 477 | 2x |
if (any("numeric" %in% ov.types)) {
|
| 478 | 2x |
COV <- lav_cor2cov(R = COR, sds = sqrt(unlist(VAR))) |
| 479 | ||
| 480 |
# construct H matrix to apply delta rule (for the tranformation |
|
| 481 |
# of rho_ij to cov_ij) |
|
| 482 | 2x |
H11 <- diag(NROW(A11)) |
| 483 | 2x |
H12 <- matrix(0, NROW(A11), NCOL(A22)) |
| 484 |
# H22 and H21 already filled in |
|
| 485 | 2x |
H <- rbind( |
| 486 | 2x |
cbind(H11, H12), |
| 487 | 2x |
cbind(H21, H22) |
| 488 |
) |
|
| 489 | ||
| 490 | 2x |
WLS.W <- H %*% WLS.W %*% t(H) |
| 491 |
} else {
|
|
| 492 | ! |
COV <- COR |
| 493 | ! |
H <- diag(NCOL(WLS.W)) |
| 494 |
} |
|
| 495 | ||
| 496 |
# reverse sign numeric TH (because we provide -mu in WLS.obs) |
|
| 497 |
# (WOW, it took me a LOOONGGG time to realize this!) |
|
| 498 |
# YR 16 July 2012 |
|
| 499 | ||
| 500 |
# NOTE: prior to 0.5-17, we used num.idx (instead of NUM.idx) |
|
| 501 |
# which is WRONG if we have more than one threshold per variable |
|
| 502 |
# (thanks to Sacha Epskamp for spotting this!) |
|
| 503 | 2x |
if (length(num.idx) > 0L) {
|
| 504 | 2x |
NUM.idx <- which(unlist(TH.IDX) == 0L) |
| 505 | 2x |
WLS.W[NUM.idx, ] <- -WLS.W[NUM.idx, ] |
| 506 | 2x |
WLS.W[, NUM.idx] <- -WLS.W[, NUM.idx] |
| 507 |
} |
|
| 508 | ||
| 509 | ||
| 510 | 2x |
out <- list( |
| 511 | 2x |
TH = TH, SLOPES = SLOPES, VAR = VAR, COR = COR, COV = COV, |
| 512 | 2x |
SC = SC, TH.NOX = TH.NOX, TH.NAMES = TH.NAMES, TH.IDX = TH.IDX, |
| 513 | 2x |
INNER = INNER, A11 = A11, A12 = A12, A21 = A21, A22 = A22, |
| 514 | 2x |
WLS.W = WLS.W, H = H, |
| 515 | 2x |
zero.cell.tables = empty.cell.tables |
| 516 |
) |
|
| 517 | 2x |
out |
| 518 |
} |
| 1 |
lav_pml_plrt <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, |
|
| 2 |
lavsamplestats = NULL, lavpartable = NULL, |
|
| 3 |
lavoptions = NULL, x = NULL, VCOV = NULL, |
|
| 4 |
lavcache = NULL) {
|
|
| 5 | ! |
lavpta <- NULL |
| 6 | ! |
if (!is.null(lavobject)) {
|
| 7 | ! |
lavmodel <- lavobject@Model |
| 8 | ! |
lavdata <- lavobject@Data |
| 9 | ! |
lavoptions <- lavobject@Options |
| 10 | ! |
lavsamplestats <- lavobject@SampleStats |
| 11 | ! |
lavcache <- lavobject@Cache |
| 12 | ! |
lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta) |
| 13 | ! |
lavpta <- lavobject@pta |
| 14 |
} |
|
| 15 | ! |
if (is.null(lavpta)) {
|
| 16 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 17 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 18 |
} |
|
| 19 | ||
| 20 | ! |
if (is.null(x)) {
|
| 21 |
# compute 'fx' = objective function value |
|
| 22 |
# (NOTE: since 0.5-18, NOT divided by N!!) |
|
| 23 | ! |
fx <- lav_model_objective( |
| 24 | ! |
lavmodel = lavmodel, |
| 25 | ! |
lavsamplestats = lavsamplestats, |
| 26 | ! |
lavdata = lavdata, |
| 27 | ! |
lavcache = lavcache |
| 28 |
) |
|
| 29 | ! |
H0.fx <- as.numeric(fx) |
| 30 | ! |
H0.fx.group <- attr(fx, "fx.group") |
| 31 |
} else {
|
|
| 32 | ! |
H0.fx <- attr(attr(x, "fx"), "fx.pml") |
| 33 | ! |
H0.fx.group <- attr(attr(x, "fx"), "fx.group") |
| 34 |
} |
|
| 35 | ||
| 36 |
# fit a saturated model 'fittedSat' |
|
| 37 | ! |
ModelSat <- lav_partable_unrestricted( |
| 38 | ! |
lavobject = NULL, |
| 39 | ! |
lavdata = lavdata, |
| 40 | ! |
lavoptions = lavoptions, |
| 41 | ! |
lavpta = lavpta, |
| 42 | ! |
lavsamplestats = lavsamplestats |
| 43 |
) |
|
| 44 | ||
| 45 |
# FIXME: se="none", test="none"?? |
|
| 46 | ! |
Options <- lavoptions |
| 47 | ! |
Options$se <- "none" |
| 48 | ! |
Options$test <- "none" |
| 49 | ! |
Options$baseline <- FALSE |
| 50 | ! |
Options$h1 <- FALSE |
| 51 | ! |
fittedSat <- lavaan(ModelSat, |
| 52 | ! |
slotOptions = Options, verbose = FALSE, |
| 53 | ! |
slotSampleStats = lavsamplestats, |
| 54 | ! |
slotData = lavdata, slotCache = lavcache |
| 55 |
) |
|
| 56 | ! |
fx <- lav_model_objective( |
| 57 | ! |
lavmodel = fittedSat@Model, |
| 58 | ! |
lavsamplestats = fittedSat@SampleStats, |
| 59 | ! |
lavdata = fittedSat@Data, |
| 60 | ! |
lavcache = fittedSat@Cache |
| 61 |
) |
|
| 62 | ! |
SAT.fx <- as.numeric(fx) |
| 63 | ! |
SAT.fx.group <- attr(fx, "fx.group") |
| 64 | ||
| 65 |
# we also need a `saturated model', but where the moments are based |
|
| 66 |
# on the model-implied sample statistics under H0 |
|
| 67 | ! |
ModelSat2 <- |
| 68 | ! |
lav_partable_unrestricted( |
| 69 | ! |
lavobject = NULL, |
| 70 | ! |
lavdata = lavdata, |
| 71 | ! |
lavoptions = lavoptions, |
| 72 | ! |
lavsamplestats = NULL, |
| 73 | ! |
sample.cov = lav_model_sigma(lavmodel), |
| 74 | ! |
sample.mean = lav_model_mu(lavmodel), |
| 75 | ! |
sample.th = lav_model_th(lavmodel), |
| 76 | ! |
sample.th.idx = lavsamplestats@th.idx |
| 77 |
) |
|
| 78 | ||
| 79 | ! |
Options2 <- Options |
| 80 | ! |
Options2$optim.method <- "none" |
| 81 | ! |
Options2$optim.force.converged <- TRUE |
| 82 | ! |
Options2$check.start <- FALSE |
| 83 | ! |
Options2$check.gradient <- FALSE |
| 84 | ! |
Options2$check.post <- FALSE |
| 85 | ! |
Options2$check.vcov <- FALSE |
| 86 | ! |
fittedSat2 <- lavaan(ModelSat2, |
| 87 | ! |
slotOptions = Options2, verbose = FALSE, |
| 88 | ! |
slotSampleStats = lavsamplestats, |
| 89 | ! |
slotData = lavdata, slotCache = lavcache |
| 90 |
) |
|
| 91 | ||
| 92 |
# the code below was contributed by Myrsini Katsikatsou (Jan 2015) |
|
| 93 | ||
| 94 |
# for now, only a single group is supported: |
|
| 95 |
# g = 1L |
|
| 96 | ||
| 97 | ||
| 98 |
########################### The code for PLRT for overall goodness of fit |
|
| 99 | ||
| 100 |
# First define the number of non-redundant elements of the (fitted) |
|
| 101 |
# covariance/correlation matrix of the underlying variables. |
|
| 102 |
# nvar <- lavmodel@nvar[[g]] |
|
| 103 |
# dSat <- nvar*(nvar-1)/2 |
|
| 104 |
# if(length(lavmodel@num.idx[[g]]) > 0L) {
|
|
| 105 |
# dSat <- dSat + length(lavmodel@num.idx[[g]]) |
|
| 106 |
# } |
|
| 107 | ||
| 108 |
# select `free' parameters (excluding thresholds) from fittedSat2 model |
|
| 109 | ! |
PT.Sat2 <- fittedSat2@ParTable |
| 110 | ! |
dSat.idx <- PT.Sat2$free[PT.Sat2$free > 0L & PT.Sat2$op != "|"] |
| 111 |
# remove thresholds |
|
| 112 | ||
| 113 |
# Secondly, we need to specify the indices of the rows/columns of vcov(), |
|
| 114 |
# hessian, and variability matrix that refer to all SEM parameters |
|
| 115 |
# except thresholds. |
|
| 116 | ! |
PT <- lavpartable |
| 117 | ! |
index.par <- PT$free[PT$free > 0L & PT$op != "|"] |
| 118 | ||
| 119 |
# Thirdly, specify the sample size. |
|
| 120 |
# nsize <- lavdata@nobs[[g]] |
|
| 121 | ! |
nsize <- lavsamplestats@ntotal |
| 122 | ||
| 123 |
# Now we can proceed to the computation of the quantities needed for PLRT. |
|
| 124 |
# Briefly, to say that PLRT is equal to the difference of two quadratic forms. |
|
| 125 |
# To compute the first and second moment adjusted PLRT we should compute |
|
| 126 |
# the asymptotic mean and variance of each quadratic quantity as well as |
|
| 127 |
# their asymptotic covariance. |
|
| 128 | ||
| 129 |
##### Section 1. Compute the asymptotic mean and variance |
|
| 130 |
##### of the first quadratic quantity |
|
| 131 |
# Below I assume that lavobject is the output of lavaan function. I guess |
|
| 132 |
# vcov(lavobject) can be substituted by VCOV object insed lavaan function |
|
| 133 |
# defined at lines 703 -708. But what is the object inside lavaan function |
|
| 134 |
# for getHessian(lavobject)? |
|
| 135 | ! |
if (is.null(VCOV)) {
|
| 136 | ! |
lavoptions$se <- "robust.huber.white" |
| 137 | ! |
VCOV <- lav_model_vcov( |
| 138 | ! |
lavmodel = lavmodel, |
| 139 | ! |
lavsamplestats = lavsamplestats, |
| 140 | ! |
lavoptions = lavoptions, |
| 141 | ! |
lavdata = lavdata, |
| 142 | ! |
lavpartable = lavpartable, |
| 143 | ! |
lavcache = lavcache |
| 144 |
) |
|
| 145 |
} |
|
| 146 | ! |
InvG_to_psipsi_attheta0 <- (lavsamplestats@ntotal * VCOV)[index.par, |
| 147 | ! |
index.par, drop = FALSE] # G^psipsi(theta0) |
| 148 |
# below the lavaan function getHessian is used |
|
| 149 |
# Hattheta0 <- (-1) * H0.Hessian |
|
| 150 |
# Hattheta0 <- H0.Hessian |
|
| 151 |
# InvHattheta0 <- solve(Hattheta0) |
|
| 152 | ! |
InvHattheta0 <- attr(VCOV, "E.inv") |
| 153 | ! |
InvH_to_psipsi_attheta0 <- InvHattheta0[index.par, index.par, drop = FALSE] |
| 154 |
# H^psipsi(theta0) |
|
| 155 | ! |
if (lavmodel@eq.constraints) {
|
| 156 | ! |
IN <- InvH_to_psipsi_attheta0 |
| 157 | ! |
IN.npar <- ncol(IN) |
| 158 | ||
| 159 |
# create `bordered' matrix |
|
| 160 | ! |
if (nrow(lavmodel@con.jac) > 0L) {
|
| 161 | ! |
H <- lavmodel@con.jac[, index.par, drop = FALSE] |
| 162 | ! |
inactive.idx <- attr(H, "inactive.idx") |
| 163 | ! |
lambda <- lavmodel@con.lambda # lagrangean coefs |
| 164 | ! |
if (length(inactive.idx) > 0L) {
|
| 165 | ! |
H <- H[-inactive.idx, , drop = FALSE] |
| 166 | ! |
lambda <- lambda[-inactive.idx] |
| 167 |
} |
|
| 168 | ! |
if (nrow(H) > 0L) {
|
| 169 | ! |
H0 <- matrix(0, nrow(H), nrow(H)) |
| 170 | ! |
H10 <- matrix(0, ncol(IN), nrow(H)) |
| 171 | ! |
DL <- 2 * diag(lambda, nrow(H), nrow(H)) |
| 172 |
# FIXME: better include inactive + slacks?? |
|
| 173 | ! |
E3 <- rbind( |
| 174 | ! |
cbind(IN, H10, t(H)), |
| 175 | ! |
cbind(t(H10), DL, H0), |
| 176 | ! |
cbind(H, H0, H0) |
| 177 |
) |
|
| 178 | ! |
Inv_of_InvH_to_psipsi_attheta0 <- |
| 179 | ! |
MASS::ginv(IN)[1:IN.npar, 1:IN.npar, drop = FALSE] |
| 180 |
} else {
|
|
| 181 | ! |
Inv_of_InvH_to_psipsi_attheta0 <- solve(IN) |
| 182 |
} |
|
| 183 |
} |
|
| 184 |
} else {
|
|
| 185 |
# YR 26 June 2018: check for empty index.par (eg independence model) |
|
| 186 | ! |
if (length(index.par) > 0L) {
|
| 187 | ! |
Inv_of_InvH_to_psipsi_attheta0 <- |
| 188 | ! |
solve(InvH_to_psipsi_attheta0) # [H^psipsi(theta0)]^(-1) |
| 189 |
} else {
|
|
| 190 | ! |
Inv_of_InvH_to_psipsi_attheta0 <- matrix(0, 0, 0) |
| 191 |
} |
|
| 192 |
} |
|
| 193 | ||
| 194 | ! |
H0tmp_prod1 <- Inv_of_InvH_to_psipsi_attheta0 %*% InvG_to_psipsi_attheta0 |
| 195 | ! |
H0tmp_prod2 <- H0tmp_prod1 %*% H0tmp_prod1 |
| 196 | ! |
E_tww <- sum(diag(H0tmp_prod1)) # expected mean of first quadratic quantity |
| 197 | ! |
var_tww <- 2 * sum(diag(H0tmp_prod2)) # variance of first quadratic quantity |
| 198 | ||
| 199 |
##### Section 2: Compute the asymptotic mean and variance |
|
| 200 |
##### of the second quadratic quantity. |
|
| 201 |
# Now we need to evaluate the fitted (polychoric) correlation/ covariance |
|
| 202 |
# matrix using the estimates of SEM parameters derived under the fitted model |
|
| 203 |
# which is the model of the null hypothesis. We also need to compute the |
|
| 204 |
# vcov matrix of these estimates (estimates of polychoric correlations) |
|
| 205 |
# as well as the related hessian and variability matrix. |
|
| 206 | ! |
tmp.options <- fittedSat2@Options |
| 207 | ! |
tmp.options$se <- lavoptions$se |
| 208 | ! |
VCOV.Sat2 <- lav_model_vcov( |
| 209 | ! |
lavmodel = fittedSat2@Model, |
| 210 | ! |
lavsamplestats = fittedSat2@SampleStats, |
| 211 | ! |
lavoptions = tmp.options, |
| 212 | ! |
lavdata = fittedSat2@Data, |
| 213 | ! |
lavpartable = fittedSat2@ParTable, |
| 214 | ! |
lavcache = fittedSat2@Cache, |
| 215 | ! |
use.ginv = TRUE |
| 216 |
) |
|
| 217 | ! |
InvG_to_sigmasigma_attheta0 <- lavsamplestats@ntotal * VCOV.Sat2[dSat.idx, |
| 218 | ! |
dSat.idx, drop = FALSE] # G^sigmasigma(theta0) |
| 219 |
# Hattheta0 <- (-1)* getHessian(fittedSat2) |
|
| 220 |
# Hattheta0 <- getHessian(fittedSat2) |
|
| 221 |
# InvHattheta0 <- solve(Hattheta0) |
|
| 222 | ! |
InvHattheta0 <- attr(VCOV.Sat2, "E.inv") |
| 223 | ! |
InvH_to_sigmasigma_attheta0 <- InvHattheta0[dSat.idx, dSat.idx, drop = FALSE] |
| 224 |
# H^sigmasigma(theta0) |
|
| 225 |
# Inv_of_InvH_to_sigmasigma_attheta0 <- solve(InvH_to_sigmasigma_attheta0) |
|
| 226 |
# #[H^sigmasigma(theta0)]^(-1) |
|
| 227 | ! |
Inv_of_InvH_to_sigmasigma_attheta0 <- MASS::ginv(InvH_to_sigmasigma_attheta0, |
| 228 | ! |
tol = .Machine$double.eps^(3 / 4) |
| 229 |
) |
|
| 230 | ! |
H1tmp_prod1 <- Inv_of_InvH_to_sigmasigma_attheta0 %*% |
| 231 | ! |
InvG_to_sigmasigma_attheta0 |
| 232 | ! |
H1tmp_prod2 <- H1tmp_prod1 %*% H1tmp_prod1 |
| 233 | ! |
E_tzz <- sum(diag(H1tmp_prod1)) # expected mean of the second |
| 234 |
# quadratic quantity |
|
| 235 | ! |
var_tzz <- 2 * sum(diag(H1tmp_prod2)) # variance of the second |
| 236 |
# quadratic quantity |
|
| 237 | ||
| 238 |
##### Section 3: Compute the asymptotic covariance of |
|
| 239 |
##### the two quadratic quantities |
|
| 240 | ||
| 241 | ! |
drhodpsi_MAT <- vector("list", length = lavsamplestats@ngroups)
|
| 242 | ! |
group.values <- lav_partable_group_values(fittedSat2@ParTable) |
| 243 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 244 |
# delta.g <- lav_model_delta(lavmodel)[[g]] # [[1]] to be substituted by g? |
|
| 245 |
# The above gives the derivatives of thresholds and polychoric correlations |
|
| 246 |
# with respect to SEM param (including thresholds) evaluated under H0. |
|
| 247 |
# From deltamat we need to exclude the rows and columns referring |
|
| 248 |
# to thresholds. |
|
| 249 |
# For this: |
|
| 250 | ||
| 251 |
# order of the rows: first the thresholds, then the correlations |
|
| 252 |
# we need to map the rows of delta.g to the rows/cols of H_at_vartheta0 |
|
| 253 |
# of H1 |
|
| 254 | ||
| 255 | ! |
PT <- fittedSat2@ParTable |
| 256 | ! |
PT$label <- lav_partable_labels(PT) |
| 257 | ! |
free.idx <- which(PT$free > 0 & PT$op != "|" & PT$group == group.values[g]) |
| 258 | ! |
PARLABEL <- PT$label[free.idx] |
| 259 | ||
| 260 |
# for now, we can assume that lav_model_delta will always return |
|
| 261 |
# the thresholds first, then the correlations |
|
| 262 |
# |
|
| 263 |
# later, we should add a (working) add.labels = TRUE option to |
|
| 264 |
# lav_model_delta |
|
| 265 |
# th.names <- lavobject@pta$vnames$th[[g]] |
|
| 266 |
# ov.names <- lavobject@pta$vnames$ov[[g]] |
|
| 267 |
# th.names <- lav_object_vnames(lavpartable, "th") |
|
| 268 |
# ov.names <- lav_object_vnames(lavpartable, "ov.nox") |
|
| 269 |
# ov.names.x <- lav_object_vnames(lavpartable, "ov.x") |
|
| 270 |
# tmp <- utils::combn(ov.names, 2) |
|
| 271 |
# cor.names <- paste(tmp[1,], "~~", tmp[2,], sep = "") |
|
| 272 | ||
| 273 |
# added by YR - 22 Okt 2017 ##################################### |
|
| 274 |
# ov.names.x <- lav_object_vnames(lavpartable, "ov.x") |
|
| 275 |
# if(length(ov.names.x)) {
|
|
| 276 |
# slope.names <- apply(expand.grid(ov.names, ov.names.x), 1L, |
|
| 277 |
# paste, collapse = "~") |
|
| 278 |
# } else {
|
|
| 279 |
# slope.names <- character(0L) |
|
| 280 |
# } |
|
| 281 |
################################################################# |
|
| 282 | ||
| 283 |
# NAMES <- c(th.names, slope.names, cor.names) |
|
| 284 | ||
| 285 |
# added by YR - 26 April 2018, for 0.6-1 |
|
| 286 |
# we now can get 'labelled' delta rownames |
|
| 287 | ! |
delta.g <- lav_object_inspect_delta_internal( |
| 288 | ! |
lavmodel = lavmodel, |
| 289 | ! |
lavdata = lavdata, lavpartable = lavpartable, |
| 290 | ! |
add.labels = TRUE, add.class = FALSE, |
| 291 | ! |
drop.list.single.group = FALSE |
| 292 | ! |
)[[g]] |
| 293 | ! |
NAMES <- rownames(delta.g) |
| 294 | ! |
if (g > 1L) {
|
| 295 | ! |
NAMES <- paste(NAMES, ".g", g, sep = "") |
| 296 |
} |
|
| 297 | ||
| 298 | ! |
par.idx <- match(PARLABEL, NAMES) |
| 299 | ! |
if (any(is.na(par.idx))) {
|
| 300 | ! |
lav_msg_warn(gettextf( |
| 301 | ! |
"mismatch between DELTA labels and PAR labels! |
| 302 | ! |
PARLABEL: %1$s, DELTA LABELS: %2$s", lav_msg_view(PARLABEL), |
| 303 | ! |
lav_msg_view(NAMES))) |
| 304 |
} |
|
| 305 | ||
| 306 | ! |
drhodpsi_MAT[[g]] <- delta.g[par.idx, index.par, drop = FALSE] |
| 307 |
} |
|
| 308 | ! |
drhodpsi_mat <- do.call(rbind, drhodpsi_MAT) |
| 309 | ||
| 310 | ! |
tmp_prod <- t(drhodpsi_mat) %*% Inv_of_InvH_to_sigmasigma_attheta0 %*% |
| 311 | ! |
drhodpsi_mat %*% InvG_to_psipsi_attheta0 %*% H0tmp_prod1 |
| 312 | ! |
cov_tzztww <- 2 * sum(diag(tmp_prod)) |
| 313 | ||
| 314 |
##### Section 4: compute the adjusted PLRT and its p-value |
|
| 315 |
# PLRTH0Sat <- 2*nsize*(lavfit@fx - fittedSat@Fit@fx) |
|
| 316 | ! |
PLRTH0Sat <- 2 * (H0.fx - SAT.fx) |
| 317 | ! |
PLRTH0Sat.group <- 2 * (H0.fx.group - SAT.fx.group) |
| 318 | ! |
asym_mean_PLRTH0Sat <- E_tzz - E_tww |
| 319 |
# catch zero value for asym_mean_PLRTH0Sat |
|
| 320 | ! |
if (asym_mean_PLRTH0Sat == 0) {
|
| 321 | ! |
asym_var_PLRTH0Sat <- 0 |
| 322 | ! |
scaling.factor <- as.numeric(NA) |
| 323 | ! |
FSA_PLRT_SEM <- as.numeric(NA) |
| 324 | ! |
adjusted_df <- as.integer(NA) |
| 325 | ! |
pvalue <- as.numeric(NA) |
| 326 | ! |
} else if (any(is.na(c(var_tzz, var_tww, cov_tzztww)))) {
|
| 327 | ! |
asym_var_PLRTH0Sat <- as.numeric(NA) |
| 328 | ! |
scaling.factor <- as.numeric(NA) |
| 329 | ! |
FSA_PLRT_SEM <- as.numeric(NA) |
| 330 | ! |
adjusted_df <- as.integer(NA) |
| 331 | ! |
pvalue <- as.numeric(NA) |
| 332 |
} else {
|
|
| 333 | ! |
asym_var_PLRTH0Sat <- var_tzz + var_tww - 2 * cov_tzztww |
| 334 | ! |
scaling.factor <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2)) |
| 335 | ! |
FSA_PLRT_SEM <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2)) * PLRTH0Sat |
| 336 | ! |
adjusted_df <- (asym_mean_PLRTH0Sat * asym_mean_PLRTH0Sat) / |
| 337 | ! |
(asym_var_PLRTH0Sat / 2) |
| 338 |
# In some very few cases (simulations show very few cases in small |
|
| 339 |
# sample sizes) the adjusted_df is a negative number, we should then |
|
| 340 |
# print a warning like: "The adjusted df is computed to be a negative number |
|
| 341 |
# and for this the first and second moment adjusted PLRT is not computed." |
|
| 342 | ! |
if (scaling.factor > 0) {
|
| 343 | ! |
pvalue <- 1 - pchisq(FSA_PLRT_SEM, df = adjusted_df) |
| 344 |
} else {
|
|
| 345 | ! |
pvalue <- as.numeric(NA) |
| 346 |
} |
|
| 347 |
} |
|
| 348 | ||
| 349 | ! |
list( |
| 350 | ! |
PLRTH0Sat = PLRTH0Sat, PLRTH0Sat.group = PLRTH0Sat.group, |
| 351 | ! |
stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue, |
| 352 | ! |
scaling.factor = scaling.factor |
| 353 |
) |
|
| 354 |
} |
|
| 355 |
############################################################################ |
|
| 356 | ||
| 357 | ||
| 358 |
lav_pml_object_aic_bic <- function(lavobject) {
|
|
| 359 |
########################## The code for PL version fo AIC and BIC |
|
| 360 |
# The following should be done because it is not the pl log-likelihood |
|
| 361 |
# that is maximized but a fit function that should be minimized. So, we |
|
| 362 |
# should find the value of log-PL at the estimated parameters through the |
|
| 363 |
# value of the fitted function. |
|
| 364 |
# The following may need to be updated if we change the fit function |
|
| 365 |
# so that it is correct for the case of missing values as well. |
|
| 366 | ||
| 367 | ! |
logPL <- lavobject@optim$logl |
| 368 | ! |
nsize <- lavobject@SampleStats@ntotal |
| 369 | ||
| 370 |
# inverted observed unit information |
|
| 371 | ! |
H.inv <- lavTech(lavobject, "inverted.information.observed") |
| 372 | ||
| 373 |
# first order unit information |
|
| 374 | ! |
J <- lavTech(lavobject, "information.first.order") |
| 375 | ||
| 376 |
# trace (J %*% H.inv) = sum (J * t(H.inv)) |
|
| 377 | ! |
dimTheta <- sum(J * H.inv) |
| 378 | ||
| 379 | ||
| 380 |
# computations of PL versions of AIC and BIC |
|
| 381 | ! |
PL_AIC <- (-2) * logPL + 2 * dimTheta |
| 382 | ! |
PL_BIC <- (-2) * logPL + dimTheta * log(nsize) |
| 383 | ||
| 384 | ! |
list(logPL = logPL, PL_AIC = PL_AIC, PL_BIC = PL_BIC) |
| 385 |
} |
| 1 |
# update lavdata object |
|
| 2 |
# - new dataset (lav_data_update) |
|
| 3 |
# - only subset of data (lav_data_update_subset) (for sam()) |
|
| 4 | ||
| 5 |
# YR - 18 Jan 2021 (so we don't need to export lav_data_*_patterns functions) |
|
| 6 |
# - 28 May 2023 lav_data_update_subset() |
|
| 7 | ||
| 8 |
# update lavdata object with new dataset |
|
| 9 |
# - assuming everything else stays the same |
|
| 10 |
# - optionally, also provide boot.idx (per group) to adapt internal slots |
|
| 11 |
lav_data_update <- function(lavdata = NULL, newX = NULL, BOOT.idx = NULL, |
|
| 12 |
lavoptions = NULL) {
|
|
| 13 | ! |
stopifnot(length(newX) == lavdata@ngroups) |
| 14 | ! |
stopifnot(!is.null(lavoptions)) |
| 15 | ! |
newdata <- lavdata |
| 16 | ||
| 17 |
# replace data 'X' slot for each group |
|
| 18 | ! |
for (g in 1:lavdata@ngroups) {
|
| 19 |
# replace raw data |
|
| 20 | ! |
newdata@X[[g]] <- newX[[g]] |
| 21 | ||
| 22 |
# Mp + nobs |
|
| 23 | ! |
if (lavoptions$missing != "listwise") {
|
| 24 | ! |
newdata@Mp[[g]] <- lav_data_missing_patterns(newX[[g]], |
| 25 | ! |
sort.freq = FALSE, coverage = TRUE |
| 26 |
) |
|
| 27 | ! |
newdata@nobs[[g]] <- |
| 28 | ! |
(nrow(newdata@X[[g]]) - length(newdata@Mp[[g]]$empty.idx)) |
| 29 |
} |
|
| 30 | ||
| 31 |
# Rp |
|
| 32 | ! |
if (length(lavdata@ov.names.x[[g]]) == 0L && |
| 33 | ! |
all(lavdata@ov.names[[g]] %in% |
| 34 | ! |
lavdata@ov$name[lavdata@ov$type == "ordered"])) {
|
| 35 | ! |
newdata@Rp[[g]] <- lav_data_resp_patterns(newX[[g]]) |
| 36 |
} |
|
| 37 | ||
| 38 |
# Lp |
|
| 39 | ! |
if (lavdata@nlevels > 1L) {
|
| 40 |
# CHECKME! |
|
| 41 |
# extract cluster variable(s), for this group |
|
| 42 | ! |
clus <- matrix(0, nrow(newX[[g]]), lavdata@nlevels - 1L) |
| 43 | ! |
for (l in 2:lavdata@nlevels) {
|
| 44 | ! |
clus[, (l - 1L)] <- lavdata@Lp[[g]]$cluster.idx[[l]] |
| 45 |
} |
|
| 46 | ! |
newdata@Lp[[g]] <- lav_data_cluster_patterns( |
| 47 | ! |
Y = newX[[g]], |
| 48 | ! |
clus = clus, |
| 49 | ! |
cluster = lavdata@cluster, |
| 50 | ! |
ov.names = lavdata@ov.names[[g]], |
| 51 | ! |
ov.names.l = lavdata@ov.names.l[[g]] |
| 52 |
) |
|
| 53 |
} |
|
| 54 |
} |
|
| 55 | ||
| 56 |
# if boot.idx if provided, also adapt eXo and WT |
|
| 57 | ! |
if (!is.null(BOOT.idx)) {
|
| 58 | ! |
boot.idx <- BOOT.idx[[g]] |
| 59 | ||
| 60 |
# eXo |
|
| 61 | ! |
if (!is.null(lavdata@eXo[[g]])) {
|
| 62 | ! |
newdata@eXo[[g]] <- lavdata@eXo[[g]][boot.idx, , drop = FALSE] |
| 63 |
} |
|
| 64 | ||
| 65 |
# sampling weights |
|
| 66 | ! |
if (!is.null(lavdata@weights[[g]])) {
|
| 67 | ! |
newdata@weights[[g]] <- lavdata@weights[[g]][boot.idx] |
| 68 |
} |
|
| 69 |
} # g |
|
| 70 | ||
| 71 |
# return update data object |
|
| 72 | ! |
newdata |
| 73 |
} |
|
| 74 | ||
| 75 |
# update lavdata, keeping only a subset of the observed variables |
|
| 76 |
# (assuming everything else stays the same) |
|
| 77 |
lav_data_update_subset <- function(lavdata = NULL, ov.names = NULL) {
|
|
| 78 | ! |
stopifnot(length(ov.names) == length(lavdata@ov.names)) |
| 79 | ! |
newdata <- lavdata |
| 80 | ||
| 81 |
# replace ov.names |
|
| 82 | ! |
newdata@ov.names <- ov.names |
| 83 | ||
| 84 |
# ordered? |
|
| 85 | ! |
if (length(lavdata@ordered) > 0L) {
|
| 86 | ! |
newdata@ordered <- lavdata@ordered[lavdata@ordered %in% ov.names] |
| 87 |
} |
|
| 88 | ||
| 89 |
# replace/update slots for each group |
|
| 90 | ! |
for (g in 1:lavdata@ngroups) {
|
| 91 |
# sanity check: |
|
| 92 | ! |
if (all(lavdata@ov.names[[g]] %in% ov.names[[g]])) {
|
| 93 |
# nothing to do |
|
| 94 | ! |
next |
| 95 |
} |
|
| 96 | ||
| 97 |
# replace ov.names.x |
|
| 98 | ! |
if (length(lavdata@ov.names.x[[g]]) > 0L) {
|
| 99 | ! |
newdata@ov.names.x[[g]] <- lavdata@ov.names.x[[g]][lavdata@ov.names.x[[g]] %in% ov.names[[g]]] |
| 100 |
} |
|
| 101 | ||
| 102 |
# replace ov.names.l |
|
| 103 | ! |
if (newdata@nlevels > 1L) {
|
| 104 | ! |
for (l in 1:newdata@nlevels) {
|
| 105 | ! |
newdata@ov.names.l[[g]][[l]] <- lavdata@ov.names.l[[g]][[l]][lavdata@ov.names.l[[g]][[l]] %in% ov.names[[g]]] |
| 106 |
} |
|
| 107 |
} |
|
| 108 | ||
| 109 |
# ov table |
|
| 110 | ! |
keep.idx <- which(lavdata@ov$name %in% unlist(ov.names)) |
| 111 | ! |
newdata@ov <- lapply(lavdata@ov, "[", keep.idx) |
| 112 | ||
| 113 |
# replace raw data |
|
| 114 | ! |
newdata@X[[g]] <- lavdata@X[[g]][, lavdata@ov.names[[g]] %in% ov.names[[g]], drop = FALSE] |
| 115 | ||
| 116 |
# eXo |
|
| 117 | ! |
if (length(newdata@ov.names.x[[g]]) == 0L) {
|
| 118 | ! |
newdata@eXo[g] <- list(NULL) |
| 119 |
} else {
|
|
| 120 | ! |
newdata@eXo[[g]] <- lavdata@eXo[[g]][, lavdata@ov.names.x[[g]] %in% ov.names[[g]], drop = FALSE] |
| 121 |
} |
|
| 122 | ||
| 123 |
# Mp + nobs |
|
| 124 | ! |
if (lavdata@missing != "listwise") {
|
| 125 | ! |
newdata@Mp[[g]] <- lav_data_missing_patterns(newdata@X[[g]], |
| 126 | ! |
sort.freq = FALSE, coverage = TRUE |
| 127 |
) |
|
| 128 | ! |
newdata@nobs[[g]] <- |
| 129 | ! |
(nrow(newdata@X[[g]]) - length(newdata@Mp[[g]]$empty.idx)) |
| 130 |
} |
|
| 131 | ||
| 132 |
# Rp |
|
| 133 | ! |
if (length(newdata@ordered) == 0L) {
|
| 134 |
# nothing to do |
|
| 135 | ! |
} else if (length(newdata@ov.names.x[[g]]) == 0L && |
| 136 | ! |
all(newdata@ov.names[[g]] %in% |
| 137 | ! |
newdata@ov$name[newdata@ov$type == "ordered"])) {
|
| 138 | ! |
newdata@Rp[[g]] <- lav_data_resp_patterns(newdata@X[[g]]) |
| 139 |
} |
|
| 140 | ||
| 141 |
# Lp |
|
| 142 | ! |
if (length(newdata@cluster) > 0L) {
|
| 143 |
# extract cluster variable(s), for this group |
|
| 144 | ! |
clus <- matrix(0, nrow(newdata@X[[g]]), lavdata@nlevels - 1L) |
| 145 | ! |
for (l in 2:lavdata@nlevels) {
|
| 146 | ! |
clus[, (l - 1L)] <- lavdata@Lp[[g]]$cluster.idx[[l]] |
| 147 |
} |
|
| 148 | ! |
if (newdata@nlevels > 1L) {
|
| 149 | ! |
multilevel <- TRUE |
| 150 |
} else {
|
|
| 151 | ! |
multilevel <- FALSE |
| 152 |
} |
|
| 153 | ! |
OV.NAMES <- unique(c(ov.names[[g]], newdata@ov.names.x[[g]])) |
| 154 | ! |
newdata@Lp[[g]] <- lav_data_cluster_patterns( |
| 155 | ! |
Y = newdata@X[[g]], |
| 156 | ! |
clus = clus, |
| 157 | ! |
cluster = newdata@cluster, |
| 158 | ! |
multilevel = multilevel, |
| 159 | ! |
ov.names = OV.NAMES, |
| 160 | ! |
ov.names.x = newdata@ov.names.x[[g]], |
| 161 | ! |
ov.names.l = newdata@ov.names.l[[g]] |
| 162 |
) |
|
| 163 |
} |
|
| 164 |
} # g |
|
| 165 | ||
| 166 |
# return update data object |
|
| 167 | ! |
newdata |
| 168 |
} |
| 1 |
# This code was contributed by Myrsini Katsikatsou (LSE) -- September 2016 |
|
| 2 |
# |
|
| 3 |
# lav_pml_bivprob_unicondprob() |
|
| 4 |
# lav_pml_object_uni_pairwise_prob() |
|
| 5 |
# lav_pml_th_rho_generalised() |
|
| 6 |
# pairwiseExpProbVec_GivenObs_UncMod() |
|
| 7 | ||
| 8 |
lav_pml_bivprob_unicondprob <- function(bivProb, nvar, |
|
| 9 |
idx.pairs, |
|
| 10 |
idx.Y1, |
|
| 11 |
idx.Gy2, |
|
| 12 |
idx.cat.y1.split, |
|
| 13 |
idx.cat.y2.split) {
|
|
| 14 | ! |
bivProb.split <- split(bivProb, idx.pairs) |
| 15 | ! |
lngth <- 2 * length(bivProb) |
| 16 | ! |
idx.vec.el <- 1:lngth |
| 17 | ! |
ProbY1Gy2 <- rep(NA, lngth) |
| 18 | ! |
no.pairs <- nvar * (nvar - 1) / 2 |
| 19 | ! |
idx2.pairs <- combn(nvar, 2) |
| 20 | ||
| 21 | ! |
for (k in 1:no.pairs) {
|
| 22 | ! |
y2Sums <- tapply(bivProb.split[[k]], idx.cat.y2.split[[k]], sum) |
| 23 | ! |
y2Sums.mult <- y2Sums[idx.cat.y2.split[[k]]] |
| 24 | ! |
Y1Gy2 <- bivProb.split[[k]] / y2Sums.mult |
| 25 | ! |
tmp.idx.vec.el <- idx.vec.el[(idx.Y1 == idx2.pairs[1, k]) & |
| 26 | ! |
(idx.Gy2 == idx2.pairs[2, k])] |
| 27 | ! |
ProbY1Gy2[tmp.idx.vec.el] <- Y1Gy2 |
| 28 |
} |
|
| 29 | ||
| 30 | ! |
for (k in 1:no.pairs) {
|
| 31 | ! |
y1Sums <- tapply(bivProb.split[[k]], idx.cat.y1.split[[k]], sum) |
| 32 | ! |
y1Sums.mult <- y1Sums[idx.cat.y1.split[[k]]] |
| 33 | ! |
Y2Gy1 <- bivProb.split[[k]] / y1Sums.mult |
| 34 | ! |
reordered_Y2Gy1 <- Y2Gy1[order(idx.cat.y1.split[[k]])] |
| 35 | ! |
tmp.idx.vec.el <- idx.vec.el[(idx.Y1 == idx2.pairs[2, k]) & |
| 36 | ! |
(idx.Gy2 == idx2.pairs[1, k])] |
| 37 | ! |
ProbY1Gy2[tmp.idx.vec.el] <- reordered_Y2Gy1 |
| 38 |
} |
|
| 39 | ||
| 40 | ! |
ProbY1Gy2 |
| 41 |
} |
|
| 42 | ||
| 43 |
# The input of the function is a lavobject, which, in turn, is the output of the |
|
| 44 |
# sem function having specified estimator="PML", missing="available.cases" |
|
| 45 | ||
| 46 |
# The output of the function is a list of two lists: the pairwiseProbGivObs list and |
|
| 47 |
# the univariateProbGivObs list. Each of the two lists consists of G matrices where G |
|
| 48 |
# is the number of groups in a multigroup analysis. If G=1 each of the lists |
|
| 49 |
# contains only one matrix that can be called as pairwiseProbGivObs[[1]], and |
|
| 50 |
# univariateProbGivObs[[1]]. |
|
| 51 | ||
| 52 |
# Each of the matrices in the pairwiseProbGivObs list is of dimension: nrow=sample size, |
|
| 53 |
# ncol=sum of the number of response categories for all pairs of variables |
|
| 54 |
# (i.e. the length of the vector pxixj.ab where i<j=1,...,p, a=1,...,Ci, b=1,...,Cj; |
|
| 55 |
# a which is the index for the response category for yi variable runs the fastest, |
|
| 56 |
# then b which is the index for the response category for yj variable, |
|
| 57 |
# then j, and last i.) |
|
| 58 |
# The cells in a matrix of the pairwiseProbGivObs list have the value 0 except for |
|
| 59 |
# those cells that correspond to the pairs of variables where both variables |
|
| 60 |
# are missing. Those cells have the value of the bivariate conditional probability |
|
| 61 |
# for the given pair for all their response categories. The bivariate |
|
| 62 |
# probabilities are computed as follows: |
|
| 63 |
# the information in the observed variables is summarised in a factor score |
|
| 64 |
# for each individual and the bivariate probability given the estimated factor |
|
| 65 |
# scores is computed. |
|
| 66 | ||
| 67 | ||
| 68 |
# Each of the matrices in the univariateProbGivObs list is of dimension: |
|
| 69 |
# nrow=sample size, ncol=sum of the number of response categories for all |
|
| 70 |
# variables. The columns are indexed with i and a, where i=1,...,p, and |
|
| 71 |
# a=1,...,Ci, the response categories for yi variable; a runs faster than i. |
|
| 72 |
# The cells in a matrix of the univariateProbGivObs list have the value 0 except for |
|
| 73 |
# those cells that correspond to variables with missing values. |
|
| 74 |
# Those cells have the value of the univariate conditional probability for the |
|
| 75 |
# given variable for all its response categories. The univariate conditional |
|
| 76 |
# probabilities are computed as follows: |
|
| 77 |
# given that the bivariate conditional probabilities have been computed we sum over |
|
| 78 |
# the response categories of each variable at a time (i.e. we compute the marginals). |
|
| 79 | ||
| 80 |
# Version 3 - first compute univariate and then bivariate probabilities |
|
| 81 | ||
| 82 |
lav_pml_object_uni_pairwise_prob <- function(lavobject) {
|
|
| 83 |
# compute yhat where yaht=nu + Lamda*eta + K*x where the parameter estimates are |
|
| 84 |
# used and the factor scores for eta |
|
| 85 |
# Below yhat is a list if lavobject@Data@ngroups >1, it is a list of G matrices |
|
| 86 |
# where G the number of groups and the matrices are fo dimension |
|
| 87 |
# nrow=sample size and ncol=number of items. |
|
| 88 |
# If lavobject@Data@ngroups=1 then yhat is a matrix. |
|
| 89 | ! |
yhat <- lavPredict(object = lavobject, type = "yhat") |
| 90 | ||
| 91 |
# compute bivariate probabilities |
|
| 92 | ! |
ngroups <- lavobject@Data@ngroups |
| 93 | ! |
univariateProb <- vector("list", length = ngroups)
|
| 94 | ! |
pairwiseProb <- vector("list", length = ngroups)
|
| 95 |
# save the indices of the Theta matrices for the groups stored in GLIST |
|
| 96 | ! |
idx.ThetaMat <- which(names(lavobject@Model@GLIST) == "theta") |
| 97 | ||
| 98 | ! |
for (g in seq_len(ngroups)) { # g<-1
|
| 99 | ||
| 100 | ! |
if (ngroups > 1L) {
|
| 101 | ! |
yhat_group <- yhat[[g]] |
| 102 |
} else {
|
|
| 103 | ! |
yhat_group <- yhat |
| 104 |
} |
|
| 105 | ||
| 106 | ! |
nsize <- lavobject@Data@nobs[[g]] |
| 107 | ! |
nvar <- lavobject@Model@nvar[[g]] |
| 108 | ! |
Data <- lavobject@Data@X[[g]] |
| 109 | ! |
TH <- lavobject@Fit@TH[[g]] |
| 110 | ! |
th.idx <- lavobject@Model@th.idx[[g]] |
| 111 | ! |
Theta <- lavobject@Model@GLIST[idx.ThetaMat[g]]$theta |
| 112 | ! |
error.stddev <- diag(Theta)^0.5 |
| 113 | ||
| 114 |
# for the computation of the univariate probabilities |
|
| 115 | ! |
nlev <- lavobject@Data@ov$nlev |
| 116 | ! |
idx.uniy <- rep(1:nvar, times = nlev) |
| 117 | ||
| 118 |
# indices vectors for the computation of bivariate probabilities |
|
| 119 | ! |
idx.pairs.yiyj <- combn(1:nvar, 2) |
| 120 | ! |
no_biv_resp_cat_yiyj <- sapply(1:ncol(idx.pairs.yiyj), function(x) {
|
| 121 | ! |
prod(nlev[idx.pairs.yiyj[, x]]) |
| 122 |
}) |
|
| 123 | ! |
idx.y1 <- unlist( |
| 124 | ! |
mapply(rep, idx.pairs.yiyj[1, ], each = no_biv_resp_cat_yiyj) |
| 125 |
) |
|
| 126 | ! |
idx.y2 <- unlist( |
| 127 | ! |
mapply(rep, idx.pairs.yiyj[2, ], each = no_biv_resp_cat_yiyj) |
| 128 |
) |
|
| 129 | ||
| 130 | ||
| 131 | ! |
univariateProb[[g]] <- matrix(0, nrow = nsize, ncol = sum(nlev)) |
| 132 | ! |
pairwiseProb[[g]] <- matrix(0, |
| 133 | ! |
nrow = nsize, |
| 134 | ! |
ncol = length(lavobject@Cache[[g]]$bifreq) |
| 135 |
) |
|
| 136 | ||
| 137 | ! |
idx.MissVar.casewise <- apply(Data, 1, function(x) {
|
| 138 | ! |
which(is.na(x)) |
| 139 |
}) |
|
| 140 | ||
| 141 | ! |
for (i in 1:nsize) {
|
| 142 | ! |
idx.MissVar <- idx.MissVar.casewise[[i]] |
| 143 | ! |
noMissVar <- length(idx.MissVar) |
| 144 | ||
| 145 | ! |
if (noMissVar > 0L) {
|
| 146 |
# compute the univariate probabilities |
|
| 147 | ! |
TH.list <- split(TH, th.idx) |
| 148 | ! |
tmp.TH <- TH.list[idx.MissVar] |
| 149 | ! |
tmp.lowerTH <- unlist(lapply(tmp.TH, function(x) {
|
| 150 | ! |
c(-Inf, x) |
| 151 |
})) |
|
| 152 | ! |
tmp.upperTH <- unlist(lapply(tmp.TH, function(x) {
|
| 153 | ! |
c(x, Inf) |
| 154 |
})) |
|
| 155 | ||
| 156 | ! |
idx.items <- rep(c(1:noMissVar), times = nlev[idx.MissVar]) |
| 157 | ! |
tmp.mean <- yhat_group[i, idx.MissVar] |
| 158 | ! |
tmp.mean.extended <- tmp.mean[idx.items] |
| 159 | ! |
tmp.stddev <- error.stddev[idx.MissVar] |
| 160 | ! |
tmp.stddev.extended <- tmp.stddev[idx.items] |
| 161 | ||
| 162 | ! |
tmp.uniProb <- pnorm((tmp.upperTH - tmp.mean.extended) / |
| 163 | ! |
tmp.stddev.extended) - |
| 164 | ! |
pnorm((tmp.lowerTH - tmp.mean.extended) / |
| 165 | ! |
tmp.stddev.extended) |
| 166 | ! |
idx.columnsUni <- which(idx.uniy %in% idx.MissVar) |
| 167 | ! |
univariateProb[[g]][i, idx.columnsUni] <- tmp.uniProb |
| 168 | ||
| 169 |
# compute the bivariate probabilities |
|
| 170 | ! |
if (noMissVar > 1L) {
|
| 171 | ! |
idx.pairsMiss <- combn(idx.MissVar, 2) |
| 172 | ! |
no.pairs <- ncol(idx.pairsMiss) |
| 173 | ! |
idx.pairsV2 <- combn(noMissVar, 2) |
| 174 | ! |
idx.columns <- unlist(lapply(1:no.pairs, function(x) {
|
| 175 | ! |
which((idx.y1 == idx.pairsMiss[1, x]) & |
| 176 | ! |
(idx.y2 == idx.pairsMiss[2, x])) |
| 177 |
})) |
|
| 178 | ||
| 179 | ! |
if (all(Theta[t(idx.pairsMiss)] == 0)) { # items independence given eta
|
| 180 | ! |
tmp.uniProb.list <- split(tmp.uniProb, idx.items) |
| 181 | ! |
pairwiseProb[[g]][i, idx.columns] <- |
| 182 | ! |
unlist(lapply(1:no.pairs, function(x) {
|
| 183 | ! |
c(outer( |
| 184 | ! |
tmp.uniProb.list[[idx.pairsV2[1, x]]], |
| 185 | ! |
tmp.uniProb.list[[idx.pairsV2[2, x]]] |
| 186 |
)) |
|
| 187 |
})) |
|
| 188 |
} else { # when correlation between measurement errors
|
|
| 189 | ||
| 190 | ! |
tmp.th.idx <- th.idx[th.idx %in% idx.MissVar] |
| 191 |
# recode so that it is always 1,1,..,1, 2,...,2, etc. |
|
| 192 | ! |
tmp.th.idx.recoded <- rep(c(1:noMissVar), times = table(tmp.th.idx)) |
| 193 | ! |
tmp.TH <- TH[th.idx %in% idx.MissVar] |
| 194 | ||
| 195 | ! |
tmp.ind.vec <- lav_pml_longvec_ind( |
| 196 | ! |
no.x = noMissVar, |
| 197 | ! |
all.thres = tmp.TH, |
| 198 | ! |
index.var.of.thres = tmp.th.idx.recoded |
| 199 |
) |
|
| 200 | ||
| 201 | ! |
tmp.th.rho.vec <- lav_pml_th_rho_generalised( |
| 202 | ! |
no.x = noMissVar, |
| 203 | ! |
TH = tmp.TH, |
| 204 | ! |
th.idx = tmp.th.idx.recoded, |
| 205 | ! |
cov.xixj = Theta[t(idx.pairsMiss)], |
| 206 | ! |
mean.x = yhat_group[i, idx.MissVar], |
| 207 | ! |
stddev.x = error.stddev[idx.MissVar] |
| 208 |
) |
|
| 209 | ||
| 210 | ! |
tmp.bivProb <- lav_pml_expprob_vec( |
| 211 | ! |
ind.vec = tmp.ind.vec, |
| 212 | ! |
th.rho.vec = tmp.th.rho.vec |
| 213 |
) |
|
| 214 | ||
| 215 | ! |
pairwiseProb[[g]][i, idx.columns] <- tmp.bivProb |
| 216 |
} # end of else of if( all( Theta[t(idx.pairsMiss)]==0 ) ) |
|
| 217 |
# which checks item local independence |
|
| 218 |
} # end of if( noMissVar>1L ) |
|
| 219 | ||
| 220 |
# cat(i, "\n") |
|
| 221 |
} # end of if(noMissVar>0L) |
|
| 222 |
} # end of for(i in 1:nsize) |
|
| 223 |
} # end of for(g in seq_len(lavobject@Data@ngroups)) |
|
| 224 | ||
| 225 | ! |
list( |
| 226 | ! |
univariateProbGivObs = univariateProb, |
| 227 | ! |
pairwiseProbGivObs = pairwiseProb |
| 228 |
) |
|
| 229 |
} # end of the function lav_pml_object_uni_pairwise_prob |
|
| 230 | ||
| 231 |
################################################################## |
|
| 232 | ||
| 233 | ||
| 234 | ||
| 235 |
# lav_pml_th_rho_generalised function is defined as follows |
|
| 236 |
lav_pml_th_rho_generalised <- function(no.x, TH, th.idx, |
|
| 237 |
cov.xixj, mean.x, stddev.x) {
|
|
| 238 | ! |
all.std.thres <- (TH - mean.x[th.idx]) / stddev.x[th.idx] |
| 239 | ! |
id.pairs <- utils::combn(no.x, 2) |
| 240 | ! |
cor.xixj <- cov.xixj / (stddev.x[id.pairs[1, ]] * stddev.x[id.pairs[2, ]]) |
| 241 | ||
| 242 | ! |
lav_pml_longvec_th_rho( |
| 243 | ! |
no.x = no.x, |
| 244 | ! |
all.thres = all.std.thres, |
| 245 | ! |
index.var.of.thres = th.idx, |
| 246 | ! |
rho.xixj = cor.xixj |
| 247 |
) |
|
| 248 |
} |
|
| 249 | ||
| 250 |
# lav_pml_th_rho_generalised is a generalisation of the function |
|
| 251 |
# lavaan:::lav_pml_longvec_th_rho . The latter assumes that all y* follow standard |
|
| 252 |
# normal so the thresholds are automatically the standardised ones. |
|
| 253 |
# lav_pml_th_rho_generalised does not assume that, each of y*'s can follow |
|
| 254 |
# a normal distribution with mean mu and standard deviation sigma. |
|
| 255 |
# lav_pml_th_rho_generalised has the following input arguments: |
|
| 256 |
# no.x (same as in lavaan:::lav_pml_longvec_th_rho), |
|
| 257 |
# TH (similar to the TH in lavaan:::lav_pml_longvec_th_rho but here they are the unstandardised thresholds, i.e. of the normal distribution with mean mu and standard deviation sigma) |
|
| 258 |
# th.idx (same as index.var.of.thres in lavaan:::lav_pml_longvec_th_rho) |
|
| 259 |
# cov.xixj which are the polychoric covariances of the pairs of underlying variables provided in a similar fashion as rho.xixj in lavaan:::lav_pml_longvec_th_rho) |
|
| 260 |
# mean.x is a vector including the means of y*'s provided in the order mean.x1, mean.x2, ...., mean.xp |
|
| 261 |
# stddev.x is a vector including the standard deviations of y*'s provided in the order stddev.x1, stddev.x2, ...., stddev.xp |
|
| 262 | ||
| 263 |
# The output of the new function is similar to that of lavaan:::lav_pml_longvec_th_rho############################################# |
|
| 264 | ||
| 265 | ||
| 266 | ||
| 267 |
# lavobject is the output of lavaan function where either the unconstrained |
|
| 268 |
# or a hypothesized model has been fitted |
|
| 269 |
lav_pml_object_uni_pairwise_unconstr<- function(lavobject) {
|
|
| 270 | ! |
ngroups <- lavobject@Data@ngroups |
| 271 | ! |
TH <- lavobject@implied$th # these are the standardized thresholds |
| 272 |
# mean and variance of y* have been taken into account |
|
| 273 | ! |
TH.IDX <- lavobject@SampleStats@th.idx |
| 274 | ! |
Sigma.hat <- lavobject@implied$cov |
| 275 | ||
| 276 | ! |
univariateProb <- vector("list", length = ngroups)
|
| 277 | ! |
pairwiseProb <- vector("list", length = ngroups)
|
| 278 | ||
| 279 | ! |
for (g in 1:ngroups) {
|
| 280 | ! |
Sigma.hat.g <- Sigma.hat[[g]] |
| 281 |
# is Sigma.hat always a correlation matrix? |
|
| 282 | ! |
Cor.hat.g <- cov2cor(Sigma.hat.g) |
| 283 | ! |
cors <- Cor.hat.g[lower.tri(Cor.hat.g)] |
| 284 | ! |
if (any(abs(cors) > 1)) {
|
| 285 | ! |
lav_msg_warn(gettext( |
| 286 | ! |
"some model-implied correlations are larger than 1.0")) |
| 287 |
} |
|
| 288 | ! |
nvar <- nrow(Sigma.hat.g) |
| 289 | ! |
MEAN <- rep(0, nvar) |
| 290 | ! |
TH.g <- TH[[g]] |
| 291 | ! |
th.idx.g <- TH.IDX[[g]] |
| 292 | ||
| 293 | ! |
nlev <- lavobject@Data@ov$nlev |
| 294 | ||
| 295 |
# create index vector to keep track which variable each column of |
|
| 296 |
# univariateProb matrix refers to |
|
| 297 | ! |
idx.uniy <- rep(1:nvar, times = nlev) |
| 298 | ||
| 299 |
# create index vector to keep track which variables each column of |
|
| 300 |
# pairwiseProb matrix refers to |
|
| 301 | ! |
idx.pairs.yiyj <- combn(1:nvar, 2) |
| 302 | ! |
no_biv_resp_cat_yiyj <- sapply(1:ncol(idx.pairs.yiyj), function(x) {
|
| 303 | ! |
prod(nlev[idx.pairs.yiyj[, x]]) |
| 304 |
}) |
|
| 305 | ! |
idx.y1 <- unlist( |
| 306 | ! |
mapply(rep, idx.pairs.yiyj[1, ], each = no_biv_resp_cat_yiyj) |
| 307 |
) |
|
| 308 | ! |
idx.y2 <- unlist( |
| 309 | ! |
mapply(rep, idx.pairs.yiyj[2, ], each = no_biv_resp_cat_yiyj) |
| 310 |
) |
|
| 311 | ||
| 312 | ! |
Data <- lavobject@Data@X[[g]] |
| 313 | ! |
nsize <- nrow(Data) |
| 314 | ||
| 315 |
# create the lists of matrices |
|
| 316 | ! |
univariateProb[[g]] <- matrix(0, nrow = nsize, ncol = sum(nlev)) |
| 317 | ! |
pairwiseProb[[g]] <- matrix(0, |
| 318 | ! |
nrow = nsize, |
| 319 | ! |
ncol = length(lavobject@Cache[[g]]$bifreq) |
| 320 |
) |
|
| 321 | ||
| 322 | ! |
idx.MissVar.casewise <- apply(Data, 1, function(x) {
|
| 323 | ! |
which(is.na(x)) |
| 324 |
}) |
|
| 325 | ||
| 326 | ! |
for (i in 1:nsize) {
|
| 327 | ! |
idx.MissVar <- idx.MissVar.casewise[[i]] |
| 328 | ! |
noMissVar <- length(idx.MissVar) |
| 329 | ||
| 330 | ! |
if (noMissVar > 0L) {
|
| 331 |
# compute the denominator of the conditional probability |
|
| 332 | ! |
TH.VAR <- lapply(1:nvar, function(x) c(-Inf, TH.g[th.idx.g == x], +Inf)) |
| 333 | ! |
lower <- sapply(1:nvar, function(x) TH.VAR[[x]][Data[i, x]]) |
| 334 | ! |
upper <- sapply(1:nvar, function(x) TH.VAR[[x]][Data[i, x] + 1L]) |
| 335 | ! |
lower.denom <- lower[-idx.MissVar] |
| 336 | ! |
upper.denom <- upper[-idx.MissVar] |
| 337 | ! |
MEAN.i <- MEAN[-idx.MissVar] |
| 338 | ! |
Corhat.i <- Cor.hat.g[-idx.MissVar, -idx.MissVar, drop = FALSE] |
| 339 | ! |
denom <- sadmvn(lower.denom, upper.denom, mean = MEAN.i, varcov = Corhat.i)[1] |
| 340 |
} # end of if( noMissVar>0L ) |
|
| 341 | ||
| 342 | ! |
if (noMissVar == 1L) { # only univariate probabilities for one item
|
| 343 |
# compute the numerator |
|
| 344 | ! |
TH.MissVar <- c(-Inf, TH.g[th.idx.g == idx.MissVar], +Inf) |
| 345 |
# for all response categories of the missing item |
|
| 346 | ! |
no.cat <- nlev[idx.MissVar] |
| 347 | ! |
numer <- sapply(1:no.cat, function(x) {
|
| 348 | ! |
lower[idx.MissVar] <- TH.MissVar[x] |
| 349 | ! |
upper[idx.MissVar] <- TH.MissVar[x + 1L] |
| 350 | ! |
sadmvn(lower, upper, mean = MEAN, varcov = Cor.hat.g)[1] |
| 351 |
}) |
|
| 352 | ! |
idx.columnsUni <- which(idx.uniy %in% idx.MissVar) |
| 353 | ! |
univariateProb[[g]][i, idx.columnsUni] <- numer / denom |
| 354 |
} # end of if( noMissVar==1L ) |
|
| 355 | ||
| 356 | ! |
if (noMissVar > 1L) {
|
| 357 |
# compute the bivariate probabilities and based on them |
|
| 358 |
# calculate the univariate ones |
|
| 359 | ||
| 360 |
# form all possible pairs of items with missing values |
|
| 361 | ! |
idx.pairsMiss <- combn(idx.MissVar, 2) |
| 362 | ! |
no.pairs <- ncol(idx.pairsMiss) |
| 363 | ! |
for (j in 1:no.pairs) {
|
| 364 | ! |
idx.Missy1y2 <- idx.pairsMiss[, j] |
| 365 | ! |
idx.Missy1 <- idx.Missy1y2[1] |
| 366 | ! |
idx.Missy2 <- idx.Missy1y2[2] |
| 367 | ! |
idx.MissRestItems <- idx.MissVar[!(idx.MissVar %in% idx.Missy1y2)] |
| 368 | ! |
TH.Missy1 <- c(-Inf, TH.g[th.idx.g == idx.Missy1], +Inf) |
| 369 | ! |
TH.Missy2 <- c(-Inf, TH.g[th.idx.g == idx.Missy2], +Inf) |
| 370 | ! |
no.cat.Missy1 <- nlev[idx.Missy1] |
| 371 | ! |
no.cat.Missy2 <- nlev[idx.Missy2] |
| 372 | ! |
no.bivRespCat <- no.cat.Missy1 * no.cat.Missy2 |
| 373 | ! |
mat_bivRespCat <- matrix(1:no.bivRespCat, |
| 374 | ! |
nrow = no.cat.Missy1, |
| 375 | ! |
ncol = no.cat.Missy2 |
| 376 |
) |
|
| 377 | ||
| 378 | ! |
numer <- sapply(1:no.bivRespCat, function(x) {
|
| 379 | ! |
idx_y1_cat <- which(mat_bivRespCat == x, arr.ind = TRUE)[1] |
| 380 | ! |
idx_y2_cat <- which(mat_bivRespCat == x, arr.ind = TRUE)[2] |
| 381 | ! |
lower[idx.Missy1y2] <- |
| 382 | ! |
c(TH.Missy1[idx_y1_cat], TH.Missy2[idx_y2_cat]) |
| 383 | ! |
upper[idx.Missy1y2] <- |
| 384 | ! |
c(TH.Missy1[idx_y1_cat + 1L], TH.Missy2[idx_y2_cat + 1L]) |
| 385 | ! |
lower.tmp <- lower |
| 386 | ! |
upper.tmp <- upper |
| 387 | ! |
MEAN.tmp <- MEAN |
| 388 | ! |
Cor.hat.g.tmp <- Cor.hat.g |
| 389 | ! |
if (length(idx.MissRestItems) > 0) {
|
| 390 | ! |
lower.tmp <- lower[-idx.MissRestItems] |
| 391 | ! |
upper.tmp <- upper[-idx.MissRestItems] |
| 392 | ! |
MEAN.tmp <- MEAN[-idx.MissRestItems] |
| 393 | ! |
Cor.hat.g.tmp <- Cor.hat.g[-idx.MissRestItems, -idx.MissRestItems] |
| 394 |
} |
|
| 395 | ! |
sadmvn(lower.tmp, upper.tmp, |
| 396 | ! |
mean = MEAN.tmp, varcov = Cor.hat.g.tmp |
| 397 | ! |
)[1] |
| 398 |
}) |
|
| 399 | ||
| 400 | ! |
idx.columns <- which((idx.y1 == idx.Missy1) & |
| 401 | ! |
(idx.y2 == idx.Missy2)) |
| 402 | ! |
tmp_biv <- numer / denom |
| 403 | ! |
pairwiseProb[[g]][i, idx.columns] <- tmp_biv |
| 404 | ||
| 405 |
# compute the univariateProb based on the above bivariate |
|
| 406 |
# probabilities |
|
| 407 | ! |
if (j == 1L) {
|
| 408 | ! |
univariateProb[[g]][i, which(idx.uniy %in% idx.Missy1)] <- |
| 409 | ! |
apply(mat_bivRespCat, 1, function(x) {
|
| 410 | ! |
sum(tmp_biv[x]) |
| 411 |
}) |
|
| 412 | ||
| 413 | ! |
univariateProb[[g]][i, which(idx.uniy %in% idx.Missy2)] <- |
| 414 | ! |
apply(mat_bivRespCat, 2, function(x) {
|
| 415 | ! |
sum(tmp_biv[x]) |
| 416 |
}) |
|
| 417 |
} |
|
| 418 | ||
| 419 | ! |
if (j > 1L & j < noMissVar) {
|
| 420 | ! |
univariateProb[[g]][i, which(idx.uniy %in% idx.Missy2)] <- |
| 421 | ! |
apply(mat_bivRespCat, 2, function(x) {
|
| 422 | ! |
sum(tmp_biv[x]) |
| 423 |
}) |
|
| 424 |
} |
|
| 425 |
} # end of for(j in 1:no.pairs ) #no.pairs is that of missing items |
|
| 426 |
} # end of if( noMissVar>1L ) |
|
| 427 |
} # end of for(i in 1:nsize) |
|
| 428 |
} # end of for(g in 1:ngroups) |
|
| 429 | ||
| 430 | ! |
list( |
| 431 | ! |
univariateProbGivObs = univariateProb, |
| 432 | ! |
pairwiseProbGivObs = pairwiseProb |
| 433 |
) |
|
| 434 |
} # end of function |
| 1 |
lav_model_sigma <- function(lavmodel = NULL, GLIST = NULL, extra = FALSE, |
|
| 2 |
delta = TRUE) {
|
|
| 3 |
# state or final? |
|
| 4 | 118x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 5 | ||
| 6 |
# check.sigma.pd -- new in 0.6-21 |
|
| 7 | 15014x |
check.sigma.pd <- get0("opt.check.sigma.pd", lavaan_cache_env,
|
| 8 | 15014x |
ifnotfound = "chol") |
| 9 | ||
| 10 | 15014x |
nmat <- lavmodel@nmat |
| 11 | 15014x |
nblocks <- lavmodel@nblocks |
| 12 | 15014x |
representation <- lavmodel@representation |
| 13 | ||
| 14 |
# return a list |
|
| 15 | 15014x |
Sigma.hat <- vector("list", length = nblocks)
|
| 16 | ||
| 17 | 15014x |
for (g in 1:nblocks) {
|
| 18 |
# which mm belong to group g? |
|
| 19 | 18526x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 20 | 18526x |
MLIST <- GLIST[mm.in.group] |
| 21 | ||
| 22 | 18526x |
if (representation == "LISREL") {
|
| 23 | 18526x |
Sigma.hat[[g]] <- lav_lisrel_sigma( |
| 24 | 18526x |
MLIST = MLIST, |
| 25 | 18526x |
delta = delta |
| 26 |
) |
|
| 27 | ! |
} else if (representation == "RAM") {
|
| 28 | ! |
Sigma.hat[[g]] <- lav_ram_sigmahat(MLIST = MLIST, delta = delta) |
| 29 |
} else {
|
|
| 30 | ! |
lav_msg_stop(gettext( |
| 31 | ! |
"only LISREL and RAM representation has been implemented for now")) |
| 32 |
} |
|
| 33 | ! |
if (lav_debug()) print(Sigma.hat[[g]]) |
| 34 | ||
| 35 | 18526x |
if (extra) {
|
| 36 |
# check if matrix is positive definite |
|
| 37 | 9241x |
if (check.sigma.pd == "chol") {
|
| 38 |
# fast path: try Cholesky directly |
|
| 39 | 9241x |
cS <- tryCatch(chol(Sigma.hat[[g]]), error = function(e) NULL) |
| 40 | 9241x |
is_pd <- !is.null(cS) |
| 41 |
} else {
|
|
| 42 |
# slow path: eigenvalue-based PD check |
|
| 43 | ! |
ev <- eigen(Sigma.hat[[g]], symmetric = TRUE, only.values = TRUE)$values |
| 44 | ! |
is_pd <- !(any(ev < sqrt(.Machine$double.eps)) || sum(ev) == 0) |
| 45 |
} |
|
| 46 | 9241x |
if (!is_pd) {
|
| 47 | 12x |
Sigma.hat.inv <- MASS::ginv(Sigma.hat[[g]]) |
| 48 | 12x |
Sigma.hat.log.det <- log(.Machine$double.eps) |
| 49 | 12x |
attr(Sigma.hat[[g]], "po") <- FALSE |
| 50 | 12x |
attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv |
| 51 | 12x |
attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det |
| 52 |
} else {
|
|
| 53 | 9229x |
if (check.sigma.pd != "chol") {
|
| 54 | ! |
cS <- chol(Sigma.hat[[g]]) |
| 55 |
} |
|
| 56 | 9229x |
Sigma.hat.inv <- chol2inv(cS) |
| 57 | 9229x |
d <- diag(cS) |
| 58 | 9229x |
Sigma.hat.log.det <- 2 * sum(log(d)) |
| 59 | 9229x |
attr(Sigma.hat[[g]], "po") <- TRUE |
| 60 | 9229x |
attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv |
| 61 | 9229x |
attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det |
| 62 |
} |
|
| 63 |
} |
|
| 64 |
} # nblocks |
|
| 65 | 15014x |
Sigma.hat |
| 66 |
} |
|
| 67 | ||
| 68 |
## only if conditional.x = TRUE |
|
| 69 |
## compute the (larger) unconditional 'joint' covariance matrix (y,x) |
|
| 70 |
## |
|
| 71 |
## Sigma (Joint ) = [ (S11, S12), |
|
| 72 |
## (S21, S22) ] where |
|
| 73 |
## S11 = Sigma.res + PI %*% cov.x %*% t(PI) |
|
| 74 |
## S12 = PI %*% cov.x |
|
| 75 |
## S21 = cov.x %*% t(PI) |
|
| 76 |
## S22 = cov.x |
|
| 77 |
lav_model_cond2joint_sigma <- function(lavmodel = NULL, GLIST = NULL, |
|
| 78 |
extra = FALSE, delta = TRUE) {
|
|
| 79 | ! |
stopifnot(lavmodel@conditional.x) |
| 80 | ||
| 81 |
# state or final? |
|
| 82 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 83 | ||
| 84 |
# check.sigma.pd -- new in 0.6-21 |
|
| 85 | ! |
check.sigma.pd <- get0("opt.check.sigma.pd", lavaan_cache_env,
|
| 86 | ! |
ifnotfound = "chol") |
| 87 | ||
| 88 | ! |
nmat <- lavmodel@nmat |
| 89 | ! |
nblocks <- lavmodel@nblocks |
| 90 | ! |
representation <- lavmodel@representation |
| 91 | ||
| 92 |
# return a list |
|
| 93 | ! |
Sigma.hat <- vector("list", length = nblocks)
|
| 94 | ||
| 95 | ! |
for (g in 1:nblocks) {
|
| 96 |
# which mm belong to group g? |
|
| 97 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 98 | ! |
MLIST <- GLIST[mm.in.group] |
| 99 | ||
| 100 | ! |
if (representation == "LISREL") {
|
| 101 | ! |
res.Sigma <- lav_lisrel_sigma(MLIST = MLIST, delta = delta) |
| 102 |
# res.int <- lav_lisrel_mu(MLIST = MLIST) |
|
| 103 | ! |
res.slopes <- lav_lisrel_pi(MLIST = MLIST) |
| 104 | ! |
S.xx <- MLIST$cov.x |
| 105 | ||
| 106 | ! |
S.yy <- res.Sigma + res.slopes %*% S.xx %*% t(res.slopes) |
| 107 | ! |
S.yx <- res.slopes %*% S.xx |
| 108 | ! |
S.xy <- S.xx %*% t(res.slopes) |
| 109 | ||
| 110 | ! |
Sigma.hat[[g]] <- rbind(cbind(S.yy, S.yx), cbind(S.xy, S.xx)) |
| 111 |
} else {
|
|
| 112 | ! |
lav_msg_stop(gettext( |
| 113 | ! |
"only representation LISREL has been implemented for now")) |
| 114 |
} |
|
| 115 | ! |
if (lav_debug()) print(Sigma.hat[[g]]) |
| 116 | ||
| 117 | ! |
if (extra) {
|
| 118 |
# check if matrix is positive definite |
|
| 119 | ! |
if (check.sigma.pd == "chol") {
|
| 120 |
# fast path: try Cholesky directly |
|
| 121 | ! |
cS <- tryCatch(chol(Sigma.hat[[g]]), error = function(e) NULL) |
| 122 | ! |
is_pd <- !is.null(cS) |
| 123 |
} else {
|
|
| 124 |
# slow path: eigenvalue-based PD check |
|
| 125 | ! |
ev <- eigen(Sigma.hat[[g]], symmetric = TRUE, only.values = TRUE)$values |
| 126 | ! |
is_pd <- !(any(ev < sqrt(.Machine$double.eps)) || sum(ev) == 0) |
| 127 |
} |
|
| 128 | ! |
if (!is_pd) {
|
| 129 | ! |
Sigma.hat.inv <- MASS::ginv(Sigma.hat[[g]]) |
| 130 | ! |
Sigma.hat.log.det <- log(.Machine$double.eps) |
| 131 | ! |
attr(Sigma.hat[[g]], "po") <- FALSE |
| 132 | ! |
attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv |
| 133 | ! |
attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det |
| 134 |
} else {
|
|
| 135 | ! |
if (check.sigma.pd != "chol") {
|
| 136 | ! |
cS <- chol(Sigma.hat[[g]]) |
| 137 |
} |
|
| 138 | ! |
Sigma.hat.inv <- chol2inv(cS) |
| 139 | ! |
d <- diag(cS) |
| 140 | ! |
Sigma.hat.log.det <- 2 * sum(log(d)) |
| 141 | ! |
attr(Sigma.hat[[g]], "po") <- TRUE |
| 142 | ! |
attr(Sigma.hat[[g]], "inv") <- Sigma.hat.inv |
| 143 | ! |
attr(Sigma.hat[[g]], "log.det") <- Sigma.hat.log.det |
| 144 |
} |
|
| 145 |
} |
|
| 146 |
} # nblocks |
|
| 147 | ||
| 148 | ! |
Sigma.hat |
| 149 |
} |
|
| 150 | ||
| 151 |
lav_model_mu <- function(lavmodel = NULL, GLIST = NULL) {
|
|
| 152 |
# state or final? |
|
| 153 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 154 | ||
| 155 | 11577x |
nmat <- lavmodel@nmat |
| 156 | 11577x |
nblocks <- lavmodel@nblocks |
| 157 | 11577x |
representation <- lavmodel@representation |
| 158 | 11577x |
meanstructure <- lavmodel@meanstructure |
| 159 | ||
| 160 |
# return a list |
|
| 161 | 11577x |
Mu.hat <- vector("list", length = nblocks)
|
| 162 | ||
| 163 | 11577x |
for (g in 1:nblocks) {
|
| 164 |
# which mm belong to group g? |
|
| 165 | 15072x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 166 | 15072x |
MLIST <- GLIST[mm.in.group] |
| 167 | ||
| 168 | 15072x |
if (!meanstructure) {
|
| 169 | ! |
Mu.hat[[g]] <- numeric(lavmodel@nvar[g]) |
| 170 | 15072x |
} else if (representation == "LISREL") {
|
| 171 | 15072x |
Mu.hat[[g]] <- lav_lisrel_mu(MLIST = MLIST) |
| 172 | ! |
} else if (representation == "RAM") {
|
| 173 | ! |
Mu.hat[[g]] <- lav_ram_muhat(MLIST = MLIST) |
| 174 |
} else {
|
|
| 175 | ! |
lav_msg_stop(gettext( |
| 176 | ! |
"only RAM and LISREL representation has been implemented for now")) |
| 177 |
} |
|
| 178 | ||
| 179 |
# new in 0.6-20: if a variable is ordinal, set its mean to zero |
|
| 180 |
# (even if NU is not all zero, as in a multiple group analysis with |
|
| 181 |
# group.equal = "thresholds") |
|
| 182 |
# |
|
| 183 |
# the logic is: Mu.hat is about 'y', not 'y-star' |
|
| 184 |
# the non-free intercepts (in TAU) are used when computing the |
|
| 185 |
# model-implied thresholds, but the do not say anything about the |
|
| 186 |
# 'observed' mean of 'y' |
|
| 187 | 15072x |
if (lavmodel@categorical) {
|
| 188 | 5819x |
ord.idx <- unique(lavmodel@th.idx[[g]][lavmodel@th.idx[[g]] > 0L]) |
| 189 | 5819x |
Mu.hat[[g]][ord.idx] <- 0 |
| 190 |
} |
|
| 191 |
} # nblocks |
|
| 192 | ||
| 193 | 11577x |
Mu.hat |
| 194 |
} |
|
| 195 | ||
| 196 |
## only if conditional.x = TRUE |
|
| 197 |
## compute the (larger) unconditional 'joint' mean vector (y,x) |
|
| 198 |
## |
|
| 199 |
## Mu (Joint ) = [ Mu.y, Mu.x ] where |
|
| 200 |
## Mu.y = res.int + PI %*% M.x |
|
| 201 |
## Mu.x = M.x |
|
| 202 |
lav_model_cond2joint_mu <- function(lavmodel = NULL, GLIST = NULL) {
|
|
| 203 |
# state or final? |
|
| 204 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 205 | ||
| 206 |
# check.sigma.pd -- new in 0.6-21 |
|
| 207 | ! |
check.sigma.pd <- get0("opt.check.sigma.pd", lavaan_cache_env,
|
| 208 | ! |
ifnotfound = "chol") |
| 209 | ||
| 210 | ! |
nmat <- lavmodel@nmat |
| 211 | ! |
nblocks <- lavmodel@nblocks |
| 212 | ! |
representation <- lavmodel@representation |
| 213 | ! |
meanstructure <- lavmodel@meanstructure |
| 214 | ||
| 215 |
# return a list |
|
| 216 | ! |
Mu.hat <- vector("list", length = nblocks)
|
| 217 | ||
| 218 | ! |
for (g in 1:nblocks) {
|
| 219 |
# which mm belong to group g? |
|
| 220 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 221 | ||
| 222 | ! |
if (!meanstructure) {
|
| 223 | ! |
Mu.hat[[g]] <- numeric(lavmodel@nvar[g]) |
| 224 | ! |
} else if (representation == "LISREL") {
|
| 225 | ! |
MLIST <- GLIST[mm.in.group] |
| 226 | ! |
res.int <- lav_lisrel_mu(MLIST = MLIST) |
| 227 | ! |
res.slopes <- lav_lisrel_pi(MLIST = MLIST) |
| 228 | ! |
M.x <- MLIST$mean.x |
| 229 | ||
| 230 | ! |
Mu.y <- res.int + res.slopes %*% M.x |
| 231 | ! |
Mu.x <- M.x |
| 232 | ! |
Mu.hat[[g]] <- c(Mu.y, Mu.x) |
| 233 |
} else {
|
|
| 234 | ! |
lav_msg_stop(gettext( |
| 235 | ! |
"only representation LISREL has been implemented for now")) |
| 236 |
} |
|
| 237 |
} # nblocks |
|
| 238 | ||
| 239 | ! |
Mu.hat |
| 240 |
} |
|
| 241 | ||
| 242 |
# TH.star = DELTA.star * (th.star - pi0.star) |
|
| 243 |
# see Muthen 1984 eq 11 |
|
| 244 |
lav_model_th <- function(lavmodel = NULL, GLIST = NULL, delta = TRUE) {
|
|
| 245 |
# state or final? |
|
| 246 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 247 | ||
| 248 | 5819x |
nblocks <- lavmodel@nblocks |
| 249 | 5819x |
nmat <- lavmodel@nmat |
| 250 | 5819x |
representation <- lavmodel@representation |
| 251 | 5819x |
th.idx <- lavmodel@th.idx |
| 252 | ||
| 253 |
# return a list |
|
| 254 | 5819x |
TH <- vector("list", length = nblocks)
|
| 255 | ||
| 256 |
# compute TH for each group |
|
| 257 | 5819x |
for (g in 1:nblocks) {
|
| 258 | 5819x |
if (length(th.idx[[g]]) == 0) {
|
| 259 | ! |
TH[[g]] <- numeric(0L) |
| 260 | ! |
next |
| 261 |
} |
|
| 262 | ||
| 263 |
# which mm belong to group g? |
|
| 264 | 5819x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 265 | ||
| 266 | 5819x |
if (representation == "LISREL") {
|
| 267 | 5819x |
TH[[g]] <- lav_lisrel_th( |
| 268 | 5819x |
MLIST = GLIST[mm.in.group], |
| 269 | 5819x |
th.idx = th.idx[[g]], delta = delta |
| 270 |
) |
|
| 271 |
} else {
|
|
| 272 | ! |
lav_msg_stop(gettext( |
| 273 | ! |
"only representation LISREL has been implemented for now")) |
| 274 |
} |
|
| 275 |
} |
|
| 276 | ||
| 277 | 5819x |
TH |
| 278 |
} |
|
| 279 | ||
| 280 |
# PI = slope structure |
|
| 281 |
# see Muthen 1984 eq 12 |
|
| 282 |
lav_model_pi <- function(lavmodel = NULL, GLIST = NULL, delta = TRUE) {
|
|
| 283 |
# state or final? |
|
| 284 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 285 | ||
| 286 | 5819x |
nblocks <- lavmodel@nblocks |
| 287 | 5819x |
nmat <- lavmodel@nmat |
| 288 | 5819x |
representation <- lavmodel@representation |
| 289 | 5819x |
conditional.x <- lavmodel@conditional.x |
| 290 | ||
| 291 |
# return a list |
|
| 292 | 5819x |
PI <- vector("list", length = nblocks)
|
| 293 | ||
| 294 |
# compute TH for each group |
|
| 295 | 5819x |
for (g in 1:nblocks) {
|
| 296 |
# which mm belong to group g? |
|
| 297 | 5819x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 298 | 5819x |
MLIST <- GLIST[mm.in.group] |
| 299 | ||
| 300 | 5819x |
if (!conditional.x) {
|
| 301 | ! |
PI.g <- numeric(lavmodel@nvar[g]) |
| 302 | 5819x |
} else if (representation == "LISREL") {
|
| 303 | 5819x |
PI.g <- lav_lisrel_pi(MLIST = MLIST, delta = delta) |
| 304 |
} else {
|
|
| 305 | ! |
lav_msg_stop(gettext( |
| 306 | ! |
"only representation LISREL has been implemented for now")) |
| 307 |
} |
|
| 308 | ||
| 309 | 5819x |
PI[[g]] <- PI.g |
| 310 |
} |
|
| 311 | ||
| 312 | 5819x |
PI |
| 313 |
} |
|
| 314 | ||
| 315 | ||
| 316 |
# GW = group weight |
|
| 317 |
lav_model_gw <- function(lavmodel = NULL, GLIST = NULL) {
|
|
| 318 |
# state or final? |
|
| 319 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 320 | ||
| 321 | ! |
nblocks <- lavmodel@nblocks |
| 322 | ! |
nmat <- lavmodel@nmat |
| 323 | ! |
representation <- lavmodel@representation |
| 324 | ! |
group.w.free <- lavmodel@group.w.free |
| 325 | ||
| 326 |
# return a list |
|
| 327 | ! |
GW <- vector("list", length = nblocks)
|
| 328 | ||
| 329 |
# compute GW for each group |
|
| 330 | ! |
for (g in 1:nblocks) {
|
| 331 |
# which mm belong to group g? |
|
| 332 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 333 | ! |
MLIST <- GLIST[mm.in.group] |
| 334 | ||
| 335 | ! |
if (!group.w.free) {
|
| 336 | ! |
GW.g <- 0.0 # FIXME |
| 337 | ! |
} else if (representation == "LISREL") {
|
| 338 | ! |
GW.g <- as.numeric(MLIST$gw[1, 1]) |
| 339 |
} else {
|
|
| 340 | ! |
lav_msg_stop(gettext( |
| 341 | ! |
"only representation LISREL has been implemented for now")) |
| 342 |
} |
|
| 343 | ||
| 344 | ! |
GW[[g]] <- GW.g |
| 345 |
} |
|
| 346 | ||
| 347 |
# transform to proportions |
|
| 348 |
# gw <- unlist(GW) |
|
| 349 |
# gw <- exp(gw) / sum(exp(gw)) |
|
| 350 |
# for(g in 1:nblocks) {
|
|
| 351 |
# GW[[g]] <- gw[g] |
|
| 352 |
# } |
|
| 353 | ||
| 354 | ! |
GW |
| 355 |
} |
|
| 356 | ||
| 357 |
# *unconditional* variance/covariance matrix of Y |
|
| 358 |
# - same as Sigma.hat if all Y are continuous) |
|
| 359 |
# - if also Gamma, cov.x is used (only if categorical) |
|
| 360 |
lav_model_vy <- function(lavmodel = NULL, GLIST = NULL, diagonal.only = FALSE) {
|
|
| 361 |
# state or final? |
|
| 362 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 363 | ||
| 364 | 1881x |
nblocks <- lavmodel@nblocks |
| 365 | 1881x |
nmat <- lavmodel@nmat |
| 366 | 1881x |
representation <- lavmodel@representation |
| 367 | ||
| 368 |
# return a list |
|
| 369 | 1881x |
VY <- vector("list", length = nblocks)
|
| 370 | ||
| 371 |
# compute TH for each group |
|
| 372 | 1881x |
for (g in 1:nblocks) {
|
| 373 |
# which mm belong to group g? |
|
| 374 | 2201x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 375 | 2201x |
MLIST <- GLIST[mm.in.group] |
| 376 | ||
| 377 | 2201x |
if (representation == "LISREL") {
|
| 378 | 2201x |
VY.g <- lav_lisrel_vy(MLIST = MLIST) |
| 379 | ! |
} else if (representation == "RAM") {
|
| 380 |
# does not work for categorical setting yet |
|
| 381 | ! |
stopifnot(!lavmodel@categorical) |
| 382 |
# does not work if conditional.x = TRUE |
|
| 383 | ! |
stopifnot(!lavmodel@conditional.x) |
| 384 | ! |
VY.g <- lav_ram_sigmahat(MLIST = MLIST) |
| 385 |
} else {
|
|
| 386 | ! |
lav_msg_stop(gettext( |
| 387 | ! |
"only RAM and LISREL representation has been implemented for now")) |
| 388 |
} |
|
| 389 | ||
| 390 | 2201x |
if (diagonal.only) {
|
| 391 | 2201x |
VY[[g]] <- diag(VY.g) |
| 392 |
} else {
|
|
| 393 | ! |
VY[[g]] <- VY.g |
| 394 |
} |
|
| 395 |
} |
|
| 396 | ||
| 397 | 1881x |
VY |
| 398 |
} |
|
| 399 | ||
| 400 |
# V(ETA): latent variances variances/covariances |
|
| 401 |
lav_model_veta <- function(lavmodel = NULL, GLIST = NULL, |
|
| 402 |
remove.dummy.lv = FALSE) {
|
|
| 403 |
# state or final? |
|
| 404 | 91x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 405 | ||
| 406 | 2010x |
nblocks <- lavmodel@nblocks |
| 407 | 2010x |
nmat <- lavmodel@nmat |
| 408 | 2010x |
representation <- lavmodel@representation |
| 409 | ||
| 410 |
# return a list |
|
| 411 | 2010x |
VETA <- vector("list", length = nblocks)
|
| 412 | ||
| 413 |
# compute VETA for each group |
|
| 414 | 2010x |
for (g in 1:nblocks) {
|
| 415 |
# which mm belong to group g? |
|
| 416 | 2378x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 417 | 2378x |
MLIST <- GLIST[mm.in.group] |
| 418 | ||
| 419 | 2378x |
if (representation == "LISREL") {
|
| 420 | 2378x |
VETA.g <- lav_lisrel_veta(MLIST = MLIST) |
| 421 | ||
| 422 | 2378x |
if (remove.dummy.lv) {
|
| 423 |
# remove all dummy latent variables |
|
| 424 | 83x |
lv.idx <- c( |
| 425 | 83x |
lavmodel@ov.y.dummy.lv.idx[[g]], |
| 426 | 83x |
lavmodel@ov.x.dummy.lv.idx[[g]] |
| 427 |
) |
|
| 428 | 83x |
if (!is.null(lv.idx)) {
|
| 429 | 24x |
VETA.g <- VETA.g[-lv.idx, -lv.idx, drop = FALSE] |
| 430 |
} |
|
| 431 |
} |
|
| 432 | ! |
} else if (representation == "RAM") {
|
| 433 | ! |
VETA.g <- lav_ram_veta(MLIST = MLIST) |
| 434 |
} else {
|
|
| 435 | ! |
lav_msg_stop(gettext( |
| 436 | ! |
"only LISREL and RAM representation has been implemented for now")) |
| 437 |
} |
|
| 438 | ||
| 439 | 2378x |
VETA[[g]] <- VETA.g |
| 440 |
} |
|
| 441 | ||
| 442 | 2010x |
VETA |
| 443 |
} |
|
| 444 | ||
| 445 |
# V(ETA|x_i): latent variances variances/covariances, conditional on x_ |
|
| 446 |
# - this is always (I-B)^-1 PSI (I-B)^-T, after REMOVING lv dummies |
|
| 447 |
lav_model_vetax <- function(lavmodel = NULL, GLIST = NULL) {
|
|
| 448 |
# state or final? |
|
| 449 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 450 | ||
| 451 | ! |
nblocks <- lavmodel@nblocks |
| 452 | ! |
nmat <- lavmodel@nmat |
| 453 | ! |
representation <- lavmodel@representation |
| 454 | ||
| 455 |
# return a list |
|
| 456 | ! |
ETA <- vector("list", length = nblocks)
|
| 457 | ||
| 458 |
# compute ETA for each group |
|
| 459 | ! |
for (g in 1:nblocks) {
|
| 460 |
# which mm belong to group g? |
|
| 461 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 462 | ! |
MLIST <- GLIST[mm.in.group] |
| 463 | ||
| 464 | ! |
if (representation == "LISREL") {
|
| 465 | ! |
lv.idx <- c( |
| 466 | ! |
lavmodel@ov.y.dummy.lv.idx[[g]], |
| 467 | ! |
lavmodel@ov.x.dummy.lv.idx[[g]] |
| 468 |
) |
|
| 469 | ! |
ETA.g <- lav_lisrel_vetax( |
| 470 | ! |
MLIST = MLIST, |
| 471 | ! |
lv.dummy.idx = lv.idx |
| 472 |
) |
|
| 473 |
} else {
|
|
| 474 | ! |
lav_msg_stop(gettext( |
| 475 | ! |
"only representation LISREL has been implemented for now")) |
| 476 |
} |
|
| 477 | ||
| 478 | ! |
ETA[[g]] <- ETA.g |
| 479 |
} |
|
| 480 | ||
| 481 | ! |
ETA |
| 482 |
} |
|
| 483 | ||
| 484 |
# COV: observed+latent variances variances/covariances |
|
| 485 |
lav_model_cov_both <- function(lavmodel = NULL, GLIST = NULL, |
|
| 486 |
remove.dummy.lv = FALSE, delta = TRUE) {
|
|
| 487 |
# state or final? |
|
| 488 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 489 | ||
| 490 | ! |
nblocks <- lavmodel@nblocks |
| 491 | ! |
nmat <- lavmodel@nmat |
| 492 | ! |
representation <- lavmodel@representation |
| 493 | ||
| 494 |
# return a list |
|
| 495 | ! |
COV <- vector("list", length = nblocks)
|
| 496 | ||
| 497 |
# compute COV for each group |
|
| 498 | ! |
for (g in 1:nblocks) {
|
| 499 |
# which mm belong to group g? |
|
| 500 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 501 | ! |
MLIST <- GLIST[mm.in.group] |
| 502 | ||
| 503 | ! |
if (representation == "LISREL") {
|
| 504 | ! |
COV.g <- lav_lisrel_cov_both(MLIST = MLIST, delta = delta) |
| 505 | ||
| 506 | ! |
if (remove.dummy.lv) {
|
| 507 |
# remove all dummy latent variables |
|
| 508 | ! |
lv.idx <- c( |
| 509 | ! |
lavmodel@ov.y.dummy.lv.idx[[g]], |
| 510 | ! |
lavmodel@ov.x.dummy.lv.idx[[g]] |
| 511 |
) |
|
| 512 | ! |
if (!is.null(lv.idx)) {
|
| 513 |
# offset for ov |
|
| 514 | ! |
lambda.names <- |
| 515 | ! |
lavmodel@dimNames[[which(names(GLIST) == "lambda")[g]]][[1L]] |
| 516 | ! |
lv.idx <- lv.idx + length(lambda.names) |
| 517 | ! |
COV.g <- COV.g[-lv.idx, -lv.idx, drop = FALSE] |
| 518 |
} |
|
| 519 |
} |
|
| 520 |
} else {
|
|
| 521 | ! |
lav_msg_stop(gettext( |
| 522 | ! |
"only representation LISREL has been implemented for now")) |
| 523 |
} |
|
| 524 | ||
| 525 | ! |
COV[[g]] <- COV.g |
| 526 |
} |
|
| 527 | ||
| 528 | ! |
COV |
| 529 |
} |
|
| 530 | ||
| 531 | ||
| 532 |
# E(ETA): expectation (means) of latent variables (return vector) |
|
| 533 |
lav_model_eeta <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, |
|
| 534 |
remove.dummy.lv = FALSE) {
|
|
| 535 |
# state or final? |
|
| 536 | 44x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 537 | ||
| 538 | 44x |
nblocks <- lavmodel@nblocks |
| 539 | 44x |
nmat <- lavmodel@nmat |
| 540 | 44x |
representation <- lavmodel@representation |
| 541 | ||
| 542 |
# return a list |
|
| 543 | 44x |
EETA <- vector("list", length = nblocks)
|
| 544 | ||
| 545 |
# compute E(ETA) for each group |
|
| 546 | 44x |
for (g in 1:nblocks) {
|
| 547 |
# which mm belong to group g? |
|
| 548 | 72x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 549 | 72x |
MLIST <- GLIST[mm.in.group] |
| 550 | ||
| 551 | 72x |
if (representation == "LISREL") {
|
| 552 | 72x |
EETA.g <- lav_lisrel_eeta(MLIST, |
| 553 | 72x |
mean.x = lavsamplestats@mean.x[[g]], |
| 554 | 72x |
sample.mean = lavsamplestats@mean[[g]], |
| 555 | 72x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 556 | 72x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 557 | 72x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 558 | 72x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]] |
| 559 |
) |
|
| 560 | 72x |
if (remove.dummy.lv) {
|
| 561 |
# remove dummy |
|
| 562 | 24x |
lv.dummy.idx <- c( |
| 563 | 24x |
lavmodel@ov.y.dummy.lv.idx[[g]], |
| 564 | 24x |
lavmodel@ov.x.dummy.lv.idx[[g]] |
| 565 |
) |
|
| 566 | 24x |
if (length(lv.dummy.idx) > 0L) {
|
| 567 | 10x |
EETA.g <- EETA.g[-lv.dummy.idx] |
| 568 |
} |
|
| 569 |
} |
|
| 570 |
} else {
|
|
| 571 | ! |
lav_msg_stop(gettext( |
| 572 | ! |
"only representation LISREL has been implemented for now")) |
| 573 |
} |
|
| 574 | ||
| 575 | 72x |
EETA[[g]] <- EETA.g |
| 576 |
} |
|
| 577 | ||
| 578 | 44x |
EETA |
| 579 |
} |
|
| 580 | ||
| 581 |
# E(ETA|x_i): conditional expectation (means) of latent variables |
|
| 582 |
# for a given value of x_i (instead of E(x_i)) |
|
| 583 |
lav_model_eetax <- function(lavmodel = NULL, GLIST = NULL, |
|
| 584 |
lavsamplestats = NULL, eXo = NULL, |
|
| 585 |
nobs = NULL, remove.dummy.lv = FALSE) {
|
|
| 586 |
# state or final? |
|
| 587 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 588 | ||
| 589 | ! |
nblocks <- lavmodel@nblocks |
| 590 | ! |
nmat <- lavmodel@nmat |
| 591 | ! |
representation <- lavmodel@representation |
| 592 | ||
| 593 |
# return a list |
|
| 594 | ! |
EETAx <- vector("list", length = nblocks)
|
| 595 | ||
| 596 |
# compute E(ETA) for each group |
|
| 597 | ! |
for (g in 1:nblocks) {
|
| 598 |
# which mm belong to group g? |
|
| 599 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 600 | ! |
MLIST <- GLIST[mm.in.group] |
| 601 | ||
| 602 | ! |
EXO <- eXo[[g]] |
| 603 | ! |
if (is.null(EXO)) {
|
| 604 |
# create empty matrix |
|
| 605 | ! |
EXO <- matrix(0, nobs[[g]], 0L) |
| 606 |
} |
|
| 607 | ||
| 608 | ! |
if (representation == "LISREL") {
|
| 609 | ! |
EETAx.g <- lav_lisrel_eetax(MLIST, |
| 610 | ! |
eXo = EXO, N = nobs[[g]], |
| 611 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 612 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 613 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 614 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 615 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]] |
| 616 |
) |
|
| 617 | ||
| 618 | ! |
if (remove.dummy.lv) {
|
| 619 |
# remove dummy |
|
| 620 | ! |
lv.dummy.idx <- c( |
| 621 | ! |
lavmodel@ov.y.dummy.lv.idx[[g]], |
| 622 | ! |
lavmodel@ov.x.dummy.lv.idx[[g]] |
| 623 |
) |
|
| 624 | ! |
if (length(lv.dummy.idx) > 0L) {
|
| 625 | ! |
EETAx.g <- EETAx.g[, -lv.dummy.idx, drop = FALSE] |
| 626 |
} |
|
| 627 |
} |
|
| 628 |
} else {
|
|
| 629 | ! |
lav_msg_stop(gettext( |
| 630 | ! |
"only representation LISREL has been implemented for now")) |
| 631 |
} |
|
| 632 | ||
| 633 | ! |
EETAx[[g]] <- EETAx.g |
| 634 |
} |
|
| 635 | ||
| 636 | ! |
EETAx |
| 637 |
} |
|
| 638 | ||
| 639 |
# return 'regular' LAMBDA |
|
| 640 |
lav_model_lambda <- function(lavmodel = NULL, GLIST = NULL, |
|
| 641 |
handle.dummy.lv = TRUE, |
|
| 642 |
remove.dummy.lv = FALSE) {
|
|
| 643 |
# state or final? |
|
| 644 | 24x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 645 | ||
| 646 | 24x |
nblocks <- lavmodel@nblocks |
| 647 | 24x |
nmat <- lavmodel@nmat |
| 648 | 24x |
representation <- lavmodel@representation |
| 649 | ||
| 650 |
# return a list |
|
| 651 | 24x |
LAMBDA <- vector("list", length = nblocks)
|
| 652 | ||
| 653 |
# compute LAMBDA for each group |
|
| 654 | 24x |
for (g in 1:nblocks) {
|
| 655 |
# which mm belong to group g? |
|
| 656 | 48x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 657 | 48x |
MLIST <- GLIST[mm.in.group] |
| 658 | ||
| 659 | 48x |
if (representation == "LISREL") {
|
| 660 | 48x |
if (handle.dummy.lv) {
|
| 661 | 48x |
ov.y.dummy.ov.idx <- lavmodel@ov.y.dummy.ov.idx[[g]] |
| 662 | 48x |
ov.x.dummy.ov.idx <- lavmodel@ov.x.dummy.ov.idx[[g]] |
| 663 | 48x |
ov.y.dummy.lv.idx <- lavmodel@ov.y.dummy.lv.idx[[g]] |
| 664 | 48x |
ov.x.dummy.lv.idx <- lavmodel@ov.x.dummy.lv.idx[[g]] |
| 665 |
} else {
|
|
| 666 | ! |
ov.y.dummy.ov.idx <- NULL |
| 667 | ! |
ov.x.dummy.ov.idx <- NULL |
| 668 | ! |
ov.y.dummy.lv.idx <- NULL |
| 669 | ! |
ov.x.dummy.lv.idx <- NULL |
| 670 |
} |
|
| 671 | 48x |
LAMBDA.g <- lav_lisrel_lambda( |
| 672 | 48x |
MLIST = MLIST, |
| 673 | 48x |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 674 | 48x |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 675 | 48x |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 676 | 48x |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx, |
| 677 | 48x |
remove.dummy.lv = remove.dummy.lv |
| 678 |
) |
|
| 679 |
} else {
|
|
| 680 | ! |
lav_msg_stop(gettext( |
| 681 | ! |
"only representation LISREL has been implemented for now")) |
| 682 |
} |
|
| 683 | ||
| 684 | 48x |
LAMBDA[[g]] <- LAMBDA.g |
| 685 |
} |
|
| 686 | ||
| 687 | 24x |
LAMBDA |
| 688 |
} |
|
| 689 | ||
| 690 |
# THETA: observed (residual) variances |
|
| 691 |
lav_model_theta <- function(lavmodel = NULL, GLIST = NULL, fix = TRUE) {
|
|
| 692 |
# state or final? |
|
| 693 | 85x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 694 | ||
| 695 | 85x |
nblocks <- lavmodel@nblocks |
| 696 | 85x |
nmat <- lavmodel@nmat |
| 697 | 85x |
representation <- lavmodel@representation |
| 698 | ||
| 699 |
# return a list |
|
| 700 | 85x |
THETA <- vector("list", length = nblocks)
|
| 701 | ||
| 702 |
# compute THETA for each group |
|
| 703 | 85x |
for (g in 1:nblocks) {
|
| 704 |
# which mm belong to group g? |
|
| 705 | 101x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 706 | 101x |
MLIST <- GLIST[mm.in.group] |
| 707 | ||
| 708 | 101x |
if (representation == "LISREL") {
|
| 709 | 101x |
if (fix) {
|
| 710 | 101x |
THETA.g <- lav_lisrel_theta( |
| 711 | 101x |
MLIST = MLIST, |
| 712 | 101x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 713 | 101x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 714 | 101x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 715 | 101x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]] |
| 716 |
) |
|
| 717 |
} else {
|
|
| 718 | ! |
THETA.g <- lav_lisrel_theta(MLIST = MLIST) |
| 719 |
} |
|
| 720 | ! |
} else if (representation == "RAM") {
|
| 721 | ! |
ov.idx <- as.integer(MLIST$ov.idx[1, ]) |
| 722 | ! |
THETA.g <- MLIST$S[ov.idx, ov.idx, drop = FALSE] |
| 723 |
} else {
|
|
| 724 | ! |
lav_msg_stop(gettext( |
| 725 | ! |
"only LISREL and RAM representation has been implemented for now")) |
| 726 |
} |
|
| 727 | ||
| 728 | 101x |
THETA[[g]] <- THETA.g |
| 729 |
} |
|
| 730 | ||
| 731 | 85x |
THETA |
| 732 |
} |
|
| 733 | ||
| 734 |
# NU: observed intercepts |
|
| 735 |
lav_model_nu <- function(lavmodel = NULL, GLIST = NULL, |
|
| 736 |
lavsamplestats = NULL) {
|
|
| 737 |
# state or final? |
|
| 738 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 739 | ||
| 740 | ! |
nblocks <- lavmodel@nblocks |
| 741 | ! |
nmat <- lavmodel@nmat |
| 742 | ! |
representation <- lavmodel@representation |
| 743 | ||
| 744 |
# return a list |
|
| 745 | ! |
NU <- vector("list", length = nblocks)
|
| 746 | ||
| 747 |
# compute NU for each group |
|
| 748 | ! |
for (g in 1:nblocks) {
|
| 749 |
# which mm belong to group g? |
|
| 750 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 751 | ! |
MLIST <- GLIST[mm.in.group] |
| 752 | ||
| 753 | ! |
if (representation == "LISREL") {
|
| 754 | ! |
NU.g <- lav_lisrel_nu( |
| 755 | ! |
MLIST = MLIST, |
| 756 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 757 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 758 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 759 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 760 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]] |
| 761 |
) |
|
| 762 |
} else {
|
|
| 763 | ! |
lav_msg_stop(gettext( |
| 764 | ! |
"only representation LISREL has been implemented for now")) |
| 765 |
} |
|
| 766 | ||
| 767 | ! |
NU[[g]] <- as.matrix(NU.g) |
| 768 |
} |
|
| 769 | ||
| 770 | ! |
NU |
| 771 |
} |
|
| 772 | ||
| 773 |
# E(Y): expectation (mean) of observed variables |
|
| 774 |
# returns vector 1 x nvar |
|
| 775 |
lav_model_ey <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, |
|
| 776 |
delta = TRUE) {
|
|
| 777 |
# state or final? |
|
| 778 | 24x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 779 | ||
| 780 | 24x |
nblocks <- lavmodel@nblocks |
| 781 | 24x |
nmat <- lavmodel@nmat |
| 782 | 24x |
representation <- lavmodel@representation |
| 783 | ||
| 784 |
# return a list |
|
| 785 | 24x |
EY <- vector("list", length = nblocks)
|
| 786 | ||
| 787 |
# compute E(Y) for each group |
|
| 788 | 24x |
for (g in 1:nblocks) {
|
| 789 |
# which mm belong to group g? |
|
| 790 | 48x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 791 | 48x |
MLIST <- GLIST[mm.in.group] |
| 792 | ||
| 793 | 48x |
if (representation == "LISREL") {
|
| 794 | 48x |
EY.g <- lav_lisrel_ey( |
| 795 | 48x |
MLIST = MLIST, |
| 796 | 48x |
mean.x = lavsamplestats@mean.x[[g]], |
| 797 | 48x |
sample.mean = lavsamplestats@mean[[g]], |
| 798 | 48x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 799 | 48x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 800 | 48x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 801 | 48x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 802 | 48x |
delta = delta |
| 803 |
) |
|
| 804 |
} else {
|
|
| 805 | ! |
lav_msg_stop(gettext( |
| 806 | ! |
"only representation LISREL has been implemented for now")) |
| 807 |
} |
|
| 808 | ||
| 809 | 48x |
EY[[g]] <- EY.g |
| 810 |
} |
|
| 811 | ||
| 812 | 24x |
EY |
| 813 |
} |
|
| 814 | ||
| 815 |
# E(Y|x_i): conditional expectation (mean) of observed variables |
|
| 816 |
# returns matrix N x nvar |
|
| 817 |
lav_model_eyx <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, |
|
| 818 |
eXo = NULL, delta = TRUE) {
|
|
| 819 |
# state or final? |
|
| 820 | ! |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 821 | ||
| 822 | ! |
nblocks <- lavmodel@nblocks |
| 823 | ! |
nmat <- lavmodel@nmat |
| 824 | ! |
representation <- lavmodel@representation |
| 825 | ||
| 826 |
# return a list |
|
| 827 | ! |
EYx <- vector("list", length = nblocks)
|
| 828 | ||
| 829 |
# compute E(Y) for each group |
|
| 830 | ! |
for (g in 1:nblocks) {
|
| 831 |
# which mm belong to group g? |
|
| 832 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 833 | ! |
MLIST <- GLIST[mm.in.group] |
| 834 | ||
| 835 | ! |
if (representation == "LISREL") {
|
| 836 | ! |
EYx.g <- lav_lisrel_eyx( |
| 837 | ! |
MLIST = MLIST, |
| 838 | ! |
eXo = eXo[[g]], |
| 839 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 840 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 841 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 842 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 843 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 844 | ! |
delta = delta |
| 845 |
) |
|
| 846 |
} else {
|
|
| 847 | ! |
lav_msg_stop(gettext( |
| 848 | ! |
"only representation LISREL has been implemented for now")) |
| 849 |
} |
|
| 850 | ||
| 851 | ! |
EYx[[g]] <- EYx.g |
| 852 |
} |
|
| 853 | ||
| 854 | ! |
EYx |
| 855 |
} |
|
| 856 | ||
| 857 | ||
| 858 |
# E(Y | ETA, x_i): conditional expectation (means) of observed variables |
|
| 859 |
# for a given value of x_i AND eta_i |
|
| 860 |
lav_model_yhat <- function(lavmodel = NULL, GLIST = NULL, lavsamplestats = NULL, |
|
| 861 |
eXo = NULL, nobs = NULL, ETA = NULL, |
|
| 862 |
duplicate = FALSE, delta = TRUE) {
|
|
| 863 |
# state or final? |
|
| 864 | 3x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 865 | ||
| 866 |
# ngroups, not nblocks! |
|
| 867 | 3x |
ngroups <- lavsamplestats@ngroups |
| 868 | ||
| 869 |
# return a list |
|
| 870 | 3x |
YHAT <- vector("list", length = ngroups)
|
| 871 | ||
| 872 |
# compute YHAT for each group |
|
| 873 | 3x |
for (g in seq_len(ngroups)) {
|
| 874 |
# which mm belong to group g? |
|
| 875 |
# FIXME: what if more than g blocks??? |
|
| 876 | 4x |
mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0L, lavmodel@nmat))[g] |
| 877 | 4x |
MLIST <- GLIST[mm.in.group] |
| 878 | ||
| 879 | 4x |
if (is.null(eXo[[g]]) && duplicate) {
|
| 880 | ! |
Nobs <- nobs[[g]] |
| 881 |
} else {
|
|
| 882 | 4x |
Nobs <- 1L |
| 883 |
} |
|
| 884 | ||
| 885 | 4x |
if (lavmodel@representation == "LISREL") {
|
| 886 | 4x |
if (lavmodel@conditional.x) {
|
| 887 | ! |
YHAT[[g]] <- lav_lisrel_eyetax( |
| 888 | ! |
MLIST = MLIST, |
| 889 | ! |
eXo = eXo[[g]], ETA = ETA[[g]], N = Nobs, |
| 890 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 891 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 892 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 893 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 894 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 895 | ! |
delta = delta |
| 896 |
) |
|
| 897 |
} else {
|
|
| 898 |
# unconditional case |
|
| 899 | 4x |
YHAT[[g]] <- lav_lisrel_eyetax3( |
| 900 | 4x |
MLIST = MLIST, |
| 901 | 4x |
ETA = ETA[[g]], |
| 902 | 4x |
sample.mean = lavsamplestats@mean[[g]], |
| 903 | 4x |
mean.x = lavsamplestats@mean.x[[g]], |
| 904 | 4x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 905 | 4x |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[g]], |
| 906 | 4x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]], |
| 907 | 4x |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[g]], |
| 908 | 4x |
delta = delta |
| 909 |
) |
|
| 910 |
# impute back ov.y values that are NOT indicators |
|
| 911 |
} |
|
| 912 |
} else {
|
|
| 913 | ! |
lav_msg_stop(gettextf("representation %s not supported yet.",
|
| 914 | ! |
lavmodel@representation)) |
| 915 |
} |
|
| 916 |
} |
|
| 917 | ||
| 918 | 3x |
YHAT |
| 919 |
} |
| 1 |
# main function used by various bootstrap related functions |
|
| 2 |
# this function draws the bootstrap samples, and estimates the |
|
| 3 |
# free parameters for each bootstrap sample |
|
| 4 |
# |
|
| 5 |
# return COEF matrix of size R x npar (R = number of bootstrap samples) |
|
| 6 |
# |
|
| 7 |
# Ed. 9 mar 2012 |
|
| 8 |
# |
|
| 9 |
# Notes: - faulty runs are simply ignored (with a warning) |
|
| 10 |
# - default R=1000 |
|
| 11 |
# |
|
| 12 |
# Updates: - now we have a separate @Data slot, we only need to transform once |
|
| 13 |
# for the bollen.stine bootstrap (13 dec 2011) |
|
| 14 |
# - bug fix: we need to 'update' the fixed.x variances/covariances |
|
| 15 |
# for each bootstrap draw!! |
|
| 16 |
# |
|
| 17 |
# Question: if fixed.x=TRUE, should we not keep X fixed, and bootstrap Y |
|
| 18 |
# only, conditional on X?? How to implement the conditional part? |
|
| 19 | ||
| 20 |
# YR 27 Aug 2022: - add keep.idx argument |
|
| 21 |
# - always return 'full' set of bootstrap results, including |
|
| 22 |
# failed runs (as NAs) |
|
| 23 |
# - idx nonadmissible/error solutions as an attribute |
|
| 24 |
# - thanks to keep.idx, it is easy to replicate/investigate |
|
| 25 |
# these cases if needed |
|
| 26 | ||
| 27 |
# YR 10 Nov 2024: - detect sam object |
|
| 28 | ||
| 29 |
lavBootstrap <- function(object, |
|
| 30 |
R = 1000L, |
|
| 31 |
type = "ordinary", |
|
| 32 |
verbose = FALSE, |
|
| 33 |
FUN = "coef", |
|
| 34 |
# return.boot = FALSE, # no use, as boot stores |
|
| 35 |
# # sample indices differently |
|
| 36 |
keep.idx = FALSE, |
|
| 37 |
parallel = c("no", "multicore", "snow"),
|
|
| 38 |
ncpus = max(1L, parallel::detectCores() - 2L), |
|
| 39 |
cl = NULL, |
|
| 40 |
iseed = NULL, |
|
| 41 |
h0.rmsea = NULL, |
|
| 42 |
...) {
|
|
| 43 | ||
| 44 |
# check object |
|
| 45 | ! |
object <- lav_object_check_version(object) |
| 46 | ||
| 47 |
# checks |
|
| 48 | ! |
type. <- tolower(type) # overwritten if nonparametric |
| 49 | ! |
stopifnot( |
| 50 | ! |
inherits(object, "lavaan"), |
| 51 | ! |
type. %in% c( |
| 52 | ! |
"nonparametric", "ordinary", |
| 53 | ! |
"bollen.stine", "parametric", "yuan" |
| 54 |
) |
|
| 55 |
) |
|
| 56 | ! |
if (!missing(verbose)) {
|
| 57 | ! |
current.verbose <- lav_verbose() |
| 58 | ! |
if (lav_verbose(verbose)) |
| 59 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 60 |
} |
|
| 61 | ! |
if (type. == "nonparametric") {
|
| 62 | ! |
type. <- "ordinary" |
| 63 |
} |
|
| 64 | ! |
if (missing(parallel)) {
|
| 65 | ! |
parallel <- "no" |
| 66 |
} |
|
| 67 | ! |
parallel <- match.arg(parallel) |
| 68 | ||
| 69 |
# check if options$se is not bootstrap, otherwise, we get an infinite loop |
|
| 70 | ! |
if (object@Options$se == "bootstrap") {
|
| 71 | ! |
object@Options$se <- "standard" |
| 72 |
} |
|
| 73 | ||
| 74 |
# check if options$test is not bollen.stine |
|
| 75 | ! |
if ("bollen.stine" %in% object@Options$test) {
|
| 76 | ! |
object@Options$test <- "standard" |
| 77 |
} |
|
| 78 | ||
| 79 |
# check for conditional.x = TRUE |
|
| 80 | ! |
if (object@Model@conditional.x) {
|
| 81 | ! |
lav_msg_stop(gettext( |
| 82 | ! |
"this function is not (yet) available if conditional.x = TRUE")) |
| 83 |
} |
|
| 84 | ||
| 85 | ! |
lavoptions. <- list( |
| 86 | ! |
parallel = parallel, ncpus = ncpus, cl = cl, |
| 87 | ! |
iseed = iseed |
| 88 |
) |
|
| 89 | ||
| 90 | ! |
out <- lav_bootstrap_internal( |
| 91 | ! |
object = object, |
| 92 | ! |
lavdata. = NULL, |
| 93 | ! |
lavmodel. = NULL, |
| 94 | ! |
lavsamplestats. = NULL, |
| 95 | ! |
lavoptions. = lavoptions., |
| 96 | ! |
lavpartable. = NULL, |
| 97 | ! |
R = R, |
| 98 | ! |
show.progress = verbose, |
| 99 | ! |
type = type., |
| 100 | ! |
FUN = FUN, |
| 101 | ! |
keep.idx = keep.idx, |
| 102 | ! |
h0.rmsea = h0.rmsea, |
| 103 |
... |
|
| 104 |
) |
|
| 105 | ||
| 106 |
# new in 0.6-12: always warn for failed and nonadmissible runs |
|
| 107 | ! |
nfailed <- length(attr(out, "error.idx")) # zero if NULL |
| 108 | ! |
if (nfailed > 0L) {
|
| 109 | ! |
lav_msg_warn(gettextf( |
| 110 | ! |
"%s bootstrap runs failed or did not converge.", nfailed)) |
| 111 |
} |
|
| 112 | ||
| 113 | ! |
notok <- length(attr(out, "nonadmissible")) # zero if NULL |
| 114 | ! |
if (notok > 0L) {
|
| 115 | ! |
lav_msg_warn(gettextf( |
| 116 | ! |
"%s bootstrap runs resulted in nonadmissible solutions.", notok)) |
| 117 |
} |
|
| 118 | ||
| 119 | ! |
out |
| 120 |
} |
|
| 121 |
lavBootstrap <- lavBootstrap # synonym #nolint |
|
| 122 | ||
| 123 |
# we need an internal version to be called from VCOV and lav_model_test |
|
| 124 |
# when there is no lavaan object yet! |
|
| 125 |
lav_bootstrap_internal <- function(object = NULL, |
|
| 126 |
lavdata. = NULL, |
|
| 127 |
lavmodel. = NULL, |
|
| 128 |
lavsamplestats. = NULL, |
|
| 129 |
lavoptions. = NULL, |
|
| 130 |
lavpartable. = NULL, |
|
| 131 |
R = 1000L, |
|
| 132 |
show.progress = FALSE, |
|
| 133 |
type = "ordinary", |
|
| 134 |
FUN = "coef", |
|
| 135 |
check.post = TRUE, |
|
| 136 |
keep.idx = FALSE, |
|
| 137 |
# return.boot = FALSE, |
|
| 138 |
h0.rmsea = NULL, |
|
| 139 |
...) {
|
|
| 140 |
# warning: avoid use of 'options', 'sample' (both are used as functions |
|
| 141 |
# below... |
|
| 142 |
# options -> opt |
|
| 143 |
# sample -> samp |
|
| 144 | ||
| 145 | 1x |
mc <- match.call() |
| 146 | ||
| 147 |
# object slots |
|
| 148 | 1x |
FUN.orig <- FUN |
| 149 | 1x |
has.sam.object.flag <- FALSE |
| 150 | 1x |
if (!is.null(object)) {
|
| 151 | ! |
stopifnot(inherits(object, "lavaan")) |
| 152 |
# check for sam object |
|
| 153 | ! |
if (!is.null(object@internal$sam.method)) {
|
| 154 | ! |
has.sam.object.flag <- TRUE |
| 155 |
} |
|
| 156 | ! |
lavdata <- object@Data |
| 157 | ! |
lavmodel <- object@Model |
| 158 | ! |
lavsamplestats <- object@SampleStats |
| 159 | ! |
lavoptions <- object@Options |
| 160 | ! |
if (!is.null(lavoptions.)) {
|
| 161 | ! |
lavoptions$parallel <- lavoptions.$parallel |
| 162 | ! |
lavoptions$ncpus <- lavoptions.$ncpus |
| 163 | ! |
lavoptions$cl <- lavoptions.$cl |
| 164 | ! |
lavoptions$iseed <- lavoptions.$iseed |
| 165 |
} |
|
| 166 | ! |
lavpartable <- object@ParTable |
| 167 | ! |
FUN <- match.fun(FUN) |
| 168 | ! |
t0 <- FUN(object, ...) |
| 169 | ! |
t.star <- matrix(as.numeric(NA), R, length(t0)) |
| 170 | ! |
colnames(t.star) <- names(t0) |
| 171 |
} else {
|
|
| 172 |
# internal version! |
|
| 173 | 1x |
lavdata <- lavdata. |
| 174 | 1x |
lavmodel <- lavmodel. |
| 175 | 1x |
lavsamplestats <- lavsamplestats. |
| 176 | 1x |
lavoptions <- lavoptions. |
| 177 | 1x |
lavpartable <- lavpartable. |
| 178 | 1x |
if (FUN == "coef") {
|
| 179 | 1x |
t.star <- matrix(as.numeric(NA), R, lavmodel@nx.free) |
| 180 | ! |
lavoptions$test <- "none" |
| 181 | ! |
} else if (FUN == "test") {
|
| 182 | ! |
t.star <- matrix(as.numeric(NA), R, 1L) |
| 183 | ! |
lavoptions$test <- "standard" |
| 184 | ! |
} else if (FUN == "coeftest") {
|
| 185 | ! |
t.star <- matrix(as.numeric(NA), R, lavmodel@nx.free + 1L) |
| 186 | ! |
lavoptions$test <- "standard" |
| 187 |
} |
|
| 188 |
} |
|
| 189 | ||
| 190 |
# always shut off some options: |
|
| 191 | ! |
current.verbose <- lav_verbose() |
| 192 | ! |
if (missing(show.progress)) {
|
| 193 | ! |
show.progress <- current.verbose |
| 194 |
} |
|
| 195 | ! |
if (lav_verbose(FALSE)) on.exit(lav_verbose(current.verbose)) |
| 196 | ! |
lavoptions$check.start <- FALSE |
| 197 | ! |
lavoptions$check.post <- FALSE |
| 198 | ! |
lavoptions$optim.attempts <- 1L # can save a lot of time |
| 199 | ||
| 200 |
# if internal or FUN == "coef", we can shut off even more |
|
| 201 | ! |
if (is.null(object) || (is.character(FUN.orig) && FUN.orig == "coef")) {
|
| 202 | ! |
lavoptions$baseline <- FALSE |
| 203 | ! |
lavoptions$h1 <- FALSE |
| 204 | ! |
lavoptions$loglik <- FALSE |
| 205 | ! |
lavoptions$implied <- FALSE |
| 206 | ! |
lavoptions$store.vcov <- FALSE |
| 207 | ! |
lavoptions$se <- "none" |
| 208 | ! |
if (FUN.orig == "coef") {
|
| 209 | ! |
lavoptions$test <- "none" |
| 210 |
} |
|
| 211 |
} |
|
| 212 | ||
| 213 |
# bollen.stine, yuan, or parametric: we need the Sigma.hat values |
|
| 214 | ! |
if (type == "bollen.stine" || type == "parametric" || type == "yuan") {
|
| 215 | ! |
Sigma.hat <- lav_model_sigma(lavmodel = lavmodel) |
| 216 | ! |
Mu.hat <- lav_model_mu(lavmodel = lavmodel) |
| 217 |
} |
|
| 218 | ||
| 219 |
# can we use the original data, or do we need to transform it first? |
|
| 220 | ! |
if (type == "bollen.stine" || type == "yuan") {
|
| 221 |
# check if data is continuous |
|
| 222 | ! |
if (lavmodel@categorical) {
|
| 223 | ! |
lav_msg_stop(gettext( |
| 224 | ! |
"bollen.stine/yuan bootstrap not available for categorical/ordinal data" |
| 225 |
)) |
|
| 226 |
} |
|
| 227 |
# check if data is complete |
|
| 228 | ! |
if (lavoptions$missing != "listwise") {
|
| 229 | ! |
lav_msg_stop(gettext( |
| 230 | ! |
"bollen.stine/yuan bootstrap not available for missing data")) |
| 231 |
} |
|
| 232 | ! |
dataX <- vector("list", length = lavdata@ngroups)
|
| 233 |
} else {
|
|
| 234 | ! |
dataX <- lavdata@X |
| 235 |
} |
|
| 236 | ||
| 237 |
# if bollen.stine, transform data here |
|
| 238 | ! |
if (type == "bollen.stine") {
|
| 239 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 240 | ! |
sigma.sqrt <- lav_matrix_symmetric_sqrt(Sigma.hat[[g]]) |
| 241 | ! |
S.inv.sqrt <- lav_matrix_symmetric_sqrt(lavsamplestats@icov[[g]]) |
| 242 | ||
| 243 |
# center (needed???) |
|
| 244 | ! |
X <- scale(lavdata@X[[g]], center = TRUE, scale = FALSE) |
| 245 | ||
| 246 |
# transform |
|
| 247 | ! |
X <- X %*% S.inv.sqrt %*% sigma.sqrt |
| 248 | ||
| 249 |
# add model-based mean |
|
| 250 | ! |
if (lavmodel@meanstructure) {
|
| 251 | ! |
X <- scale(X, center = (-1 * Mu.hat[[g]]), scale = FALSE) |
| 252 |
} |
|
| 253 | ||
| 254 |
# transformed data |
|
| 255 | ! |
dataX[[g]] <- X |
| 256 |
} |
|
| 257 | ||
| 258 |
# if yuan, transform data here |
|
| 259 | ! |
} else if (type == "yuan") {
|
| 260 |
# page numbers refer to Yuan et al, 2007 |
|
| 261 |
# Define a function to find appropriate value of a |
|
| 262 |
# (p. 272); code supplied 16 jun 2016 by Cheng & Wu |
|
| 263 | ! |
search.a <- function(F0, d, p) {
|
| 264 | ! |
if (F0 == 0) {
|
| 265 | ! |
a0 <- 0 |
| 266 | ! |
return(a0) |
| 267 |
} |
|
| 268 | ! |
max.a <- 1 / (1 - min(d)) - 1e-3 |
| 269 |
# starting value; Yuan p. 272 |
|
| 270 | ! |
a0 <- min(sqrt(2 * F0 / sum((d - 1)^2)), max.a) |
| 271 | ||
| 272 |
# See Yuan p. 280 |
|
| 273 | ! |
for (i in 1:50) {
|
| 274 | ! |
dia <- a0 * d + (1 - a0) |
| 275 | ! |
g1 <- -sum(log(dia)) + sum(dia) - p |
| 276 | ! |
dif <- g1 - F0 |
| 277 | ! |
if (abs(dif) < 1e-6) {
|
| 278 | ! |
return(a0) |
| 279 |
} |
|
| 280 | ! |
g2 <- a0 * sum((d - 1)^2 / dia) |
| 281 | ! |
a0 <- min(max(a0 - dif / g2, 0), max.a) |
| 282 |
} |
|
| 283 |
# if search fails to converge in 50 iterations |
|
| 284 | ! |
lav_msg_warn(gettext("yuan bootstrap search for `a` did not converge.
|
| 285 | ! |
h0.rmsea may be too large.")) |
| 286 | ! |
a0 |
| 287 |
} |
|
| 288 | ||
| 289 |
# Now use g.a within each group |
|
| 290 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 291 | ! |
S <- lavsamplestats@cov[[g]] |
| 292 |
# test is in Fit slot |
|
| 293 | ! |
ghat <- object@test[[1]]$stat.group[[g]] |
| 294 | ! |
df <- object@test[[1]]$df |
| 295 | ! |
Sigmahat <- Sigma.hat[[g]] |
| 296 | ! |
nmv <- nrow(Sigmahat) |
| 297 | ! |
n <- nrow(lavdata@X[[g]]) |
| 298 | ||
| 299 |
# Calculate tauhat_1, middle p. 267. |
|
| 300 |
# Yuan et al note that tauhat_1 could be negative; |
|
| 301 |
# if so, we need to let S.a = Sigmahat. (see middle p 275) |
|
| 302 | ! |
ifelse(length(h0.rmsea) == 0, |
| 303 | ! |
tau.hat <- (ghat - df) / (n - 1), # middle p 267 |
| 304 | ! |
tau.hat <- df * (h0.rmsea * h0.rmsea) |
| 305 | ! |
) # middle p 273 |
| 306 | ||
| 307 | ! |
if (tau.hat >= 0) {
|
| 308 |
# from Cheng and Wu |
|
| 309 | ! |
EL <- t(chol(Sigmahat)) |
| 310 | ! |
ESE <- forwardsolve(EL, t(forwardsolve(EL, S))) |
| 311 | ! |
d <- eigen(ESE, symmetric = TRUE, only.values = TRUE)$values |
| 312 | ! |
if ("a" %in% names(list(...))) {
|
| 313 | ! |
a <- list(...)$a |
| 314 |
} else {
|
|
| 315 |
# Find a to minimize g.a |
|
| 316 | ! |
a <- search.a(tau.hat, d, nmv) |
| 317 |
} |
|
| 318 |
# Calculate S_a (p. 267) |
|
| 319 | ! |
S.a <- a * S + (1 - a) * Sigmahat |
| 320 |
} else {
|
|
| 321 | ! |
S.a <- Sigmahat |
| 322 |
} |
|
| 323 | ||
| 324 |
# Transform the data (p. 263) |
|
| 325 | ! |
S.a.sqrt <- lav_matrix_symmetric_sqrt(S.a) |
| 326 | ! |
S.inv.sqrt <- lav_matrix_symmetric_sqrt(lavsamplestats@icov[[g]]) |
| 327 | ||
| 328 | ! |
X <- lavdata@X[[g]] |
| 329 | ! |
X <- X %*% S.inv.sqrt %*% S.a.sqrt |
| 330 | ||
| 331 |
# transformed data |
|
| 332 | ! |
dataX[[g]] <- X |
| 333 |
} |
|
| 334 |
} |
|
| 335 | ||
| 336 |
# run bootstraps |
|
| 337 | ! |
fn <- function(b) {
|
| 338 |
# create bootstrap sample, and generate new 'data' object |
|
| 339 | ! |
if (type == "bollen.stine" || type == "ordinary" || type == "yuan") {
|
| 340 |
# take a bootstrap sample for each group |
|
| 341 | ! |
BOOT.idx <- vector("list", length = lavdata@ngroups)
|
| 342 |
# Note: we generate the bootstrap indices separately for each |
|
| 343 |
# group, in order to ensure the group sizes do not change! |
|
| 344 | ! |
for (g in 1:lavdata@ngroups) {
|
| 345 | ! |
stopifnot(nrow(lavdata@X[[g]]) > 1L) |
| 346 | ! |
boot.idx <- sample.int(nrow(lavdata@X[[g]]), replace = TRUE) |
| 347 | ! |
BOOT.idx[[g]] <- boot.idx |
| 348 | ! |
dataX[[g]] <- dataX[[g]][boot.idx, , drop = FALSE] |
| 349 |
} |
|
| 350 | ! |
newData <- lav_data_update( |
| 351 | ! |
lavdata = lavdata, newX = dataX, |
| 352 | ! |
BOOT.idx = BOOT.idx, |
| 353 | ! |
lavoptions = lavoptions |
| 354 |
) |
|
| 355 | ! |
} else { # parametric! (using sign-invariant method for reproducibility)
|
| 356 | ! |
for (g in 1:lavdata@ngroups) {
|
| 357 | ! |
dataX[[g]] <- lav_mvrnorm( |
| 358 | ! |
n = lavdata@nobs[[g]], |
| 359 | ! |
Sigma = Sigma.hat[[g]], |
| 360 | ! |
mu = Mu.hat[[g]] |
| 361 |
) |
|
| 362 |
} |
|
| 363 | ! |
newData <- lav_data_update( |
| 364 | ! |
lavdata = lavdata, newX = dataX, |
| 365 | ! |
lavoptions = lavoptions |
| 366 |
) |
|
| 367 |
} |
|
| 368 | ||
| 369 |
# show progress? |
|
| 370 | ! |
if (show.progress) {
|
| 371 | ! |
cat(" ... bootstrap draw number:", sprintf("%4d", b))
|
| 372 |
} |
|
| 373 | ! |
bootSampleStats <- try(lav_samplestats_from_data( |
| 374 | ! |
lavdata = newData, |
| 375 | ! |
lavoptions = lavoptions |
| 376 | ! |
), silent = TRUE) |
| 377 | ! |
if (inherits(bootSampleStats, "try-error")) {
|
| 378 | ! |
if (show.progress) {
|
| 379 | ! |
cat(" FAILED: creating sample statistics\n")
|
| 380 | ! |
cat(bootSampleStats[1]) |
| 381 |
} |
|
| 382 | ! |
out <- as.numeric(NA) |
| 383 | ! |
attr(out, "nonadmissible.flag") <- TRUE |
| 384 | ! |
if (keep.idx) {
|
| 385 | ! |
attr(out, "BOOT.idx") <- BOOT.idx |
| 386 |
} |
|
| 387 | ! |
return(out) |
| 388 |
} |
|
| 389 | ! |
if (has.sam.object.flag) {
|
| 390 |
# also need h1 |
|
| 391 | ! |
booth1 <- lav_h1_implied_logl(lavdata = newData, |
| 392 | ! |
lavsamplestats = bootSampleStats, lavpartable = lavpartable, |
| 393 | ! |
lavoptions = lavoptions) |
| 394 |
} |
|
| 395 | ||
| 396 |
# do we need to update Model slot? only if we have fixed exogenous |
|
| 397 |
# covariates, as their variances/covariances are stored in GLIST |
|
| 398 | ! |
if (lavmodel@fixed.x && length(lav_partable_vnames(lavpartable, "ov.x")) > 0L) {
|
| 399 | ! |
model.boot <- NULL |
| 400 |
} else {
|
|
| 401 | ! |
model.boot <- lavmodel |
| 402 |
} |
|
| 403 | ||
| 404 |
# fit model on bootstrap sample |
|
| 405 | ! |
if (has.sam.object.flag) {
|
| 406 | ! |
new_object <- object |
| 407 | ! |
new_object@Data <- newData |
| 408 | ! |
new_object@SampleStats <- bootSampleStats |
| 409 | ! |
new_object@h1 <- booth1 |
| 410 |
# what about lavoptions? |
|
| 411 | ! |
fit.boot <- suppressWarnings(try(sam(new_object, se = "none"), |
| 412 | ! |
silent = FALSE)) # show what is wrong |
| 413 |
} else {
|
|
| 414 | ! |
fit.boot <- suppressWarnings(try(lavaan( |
| 415 | ! |
slotOptions = lavoptions, |
| 416 | ! |
slotParTable = lavpartable, |
| 417 | ! |
slotModel = model.boot, |
| 418 | ! |
slotSampleStats = bootSampleStats, |
| 419 | ! |
slotData = newData |
| 420 | ! |
), silent = FALSE)) |
| 421 |
} |
|
| 422 | ! |
if (inherits(fit.boot, "try-error")) {
|
| 423 | ! |
if (show.progress) {
|
| 424 | ! |
cat(" FAILED: with ERROR message\n")
|
| 425 |
} |
|
| 426 | ! |
out <- as.numeric(NA) |
| 427 | ! |
attr(out, "nonadmissible.flag") <- TRUE |
| 428 | ! |
if (keep.idx) {
|
| 429 | ! |
attr(out, "BOOT.idx") <- BOOT.idx |
| 430 |
} |
|
| 431 | ! |
return(out) |
| 432 |
} |
|
| 433 | ! |
if (!fit.boot@optim$converged) {
|
| 434 | ! |
if (show.progress) {
|
| 435 | ! |
cat(" FAILED: no convergence\n")
|
| 436 |
} |
|
| 437 | ! |
out <- as.numeric(NA) |
| 438 | ! |
attr(out, "nonadmissible.flag") <- TRUE |
| 439 | ! |
if (keep.idx) {
|
| 440 | ! |
attr(out, "BOOT.idx") <- BOOT.idx |
| 441 |
} |
|
| 442 | ! |
return(out) |
| 443 |
} |
|
| 444 | ||
| 445 |
# extract information we need |
|
| 446 | ! |
if (is.null(object)) { # internal use only!
|
| 447 | ! |
if (FUN == "coef") {
|
| 448 | ! |
out <- fit.boot@optim$x |
| 449 | ! |
} else if (FUN == "test") {
|
| 450 | ! |
out <- fit.boot@test[[1L]]$stat |
| 451 | ! |
} else if (FUN == "coeftest") {
|
| 452 | ! |
out <- c(fit.boot@optim$x, fit.boot@test[[1L]]$stat) |
| 453 |
} |
|
| 454 | ! |
} else { # general use
|
| 455 | ! |
out <- try(as.numeric(FUN(fit.boot, ...)), silent = TRUE) |
| 456 |
} |
|
| 457 | ! |
if (inherits(out, "try-error")) {
|
| 458 | ! |
if (show.progress) {
|
| 459 | ! |
cat(" FAILED: applying FUN to fit.boot\n")
|
| 460 |
} |
|
| 461 | ! |
out <- as.numeric(NA) |
| 462 | ! |
attr(out, "nonadmissible.flag") <- TRUE |
| 463 | ! |
if (keep.idx) {
|
| 464 | ! |
attr(out, "BOOT.idx") <- BOOT.idx |
| 465 |
} |
|
| 466 | ! |
return(out) |
| 467 |
} |
|
| 468 | ||
| 469 |
# check if the solution is admissible |
|
| 470 | ! |
admissible.flag <- suppressWarnings(lavInspect(fit.boot, "post.check")) |
| 471 | ! |
attr(out, "nonadmissible.flag") <- !admissible.flag |
| 472 | ||
| 473 | ! |
if (show.progress) {
|
| 474 | ! |
cat( |
| 475 | ! |
" OK -- niter = ", |
| 476 | ! |
sprintf("%3d", fit.boot@optim$iterations), " fx = ",
|
| 477 | ! |
sprintf("%11.9f", fit.boot@optim$fx),
|
| 478 | ! |
if (admissible.flag) " " else "n", "\n" |
| 479 |
) |
|
| 480 |
} |
|
| 481 | ||
| 482 | ! |
if (keep.idx) {
|
| 483 |
# add BOOT.idx (for all groups) |
|
| 484 | ! |
attr(out, "BOOT.idx") <- BOOT.idx |
| 485 |
} |
|
| 486 | ||
| 487 | ! |
out |
| 488 | ! |
} # end-of-fn |
| 489 | ||
| 490 |
# get parallelization options |
|
| 491 | ! |
parallel <- lavoptions$parallel[1] |
| 492 | ! |
ncpus <- lavoptions$ncpus |
| 493 | ! |
cl <- lavoptions[["cl"]] # often NULL |
| 494 | ! |
iseed <- lavoptions[["iseed"]] # often NULL |
| 495 | ||
| 496 |
# the next 8 lines are borrowed from the boot package |
|
| 497 | ! |
have_mc <- have_snow <- FALSE |
| 498 | ! |
if (parallel != "no" && ncpus > 1L) {
|
| 499 | ! |
if (parallel == "multicore") {
|
| 500 | ! |
have_mc <- .Platform$OS.type != "windows" |
| 501 | ! |
} else if (parallel == "snow") have_snow <- TRUE |
| 502 | ! |
if (!have_mc && !have_snow) ncpus <- 1L |
| 503 | ! |
loadNamespace("parallel") # before recording seed!
|
| 504 |
} |
|
| 505 | ||
| 506 |
# iseed: |
|
| 507 |
# this follows a proposal of Shu Fai Cheung (see github issue #240) |
|
| 508 |
# - iseed is used for both serial and parallel |
|
| 509 |
# - if iseed is not set, iseed is generated + .Random.seed created/updated |
|
| 510 |
# -> tmp.seed <- NA |
|
| 511 |
# - if iseed is set: don't touch .Random.seed (if it exists) |
|
| 512 |
# -> tmp.seed <- .Random.seed (if it exists) |
|
| 513 |
# -> tmp.seed <- NULL (if it does not exist) |
|
| 514 | ! |
if (is.null(iseed)) {
|
| 515 | ! |
if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 516 | ! |
runif(1) |
| 517 |
} |
|
| 518 |
# identical(temp.seed, NA): Will not change .Random.seed in GlobalEnv |
|
| 519 | ! |
temp.seed <- NA |
| 520 | ! |
iseed <- runif(1, 0, 999999999) |
| 521 |
} else {
|
|
| 522 | ! |
if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 523 | ! |
temp.seed <- |
| 524 | ! |
get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
|
| 525 |
} else {
|
|
| 526 |
# is.null(temp.seed): Will remove .Random.seed in GlobalEnv |
|
| 527 |
# if serial. |
|
| 528 |
# If parallel, .Random.seed will not be touched. |
|
| 529 | ! |
temp.seed <- NULL |
| 530 |
} |
|
| 531 |
} |
|
| 532 | ! |
if (!(ncpus > 1L && (have_mc || have_snow))) { # Only for serial
|
| 533 | ! |
set.seed(iseed) |
| 534 |
} |
|
| 535 | ||
| 536 | ||
| 537 |
# this is adapted from the boot function in package boot |
|
| 538 | ! |
RR <- R |
| 539 | ! |
if (show.progress) {
|
| 540 | ! |
cat("\n")
|
| 541 |
} |
|
| 542 | ! |
res <- if (ncpus > 1L && (have_mc || have_snow)) {
|
| 543 | ! |
if (have_mc) {
|
| 544 | ! |
RNGkind_old <- RNGkind() # store current kind |
| 545 | ! |
RNGkind("L'Ecuyer-CMRG") # to allow for reproducible results
|
| 546 | ! |
set.seed(iseed) |
| 547 | ! |
parallel::mclapply(seq_len(RR), fn, mc.cores = ncpus) |
| 548 | ! |
} else if (have_snow) {
|
| 549 | ! |
list(...) # evaluate any promises |
| 550 | ! |
if (is.null(cl)) {
|
| 551 | ! |
cl <- parallel::makePSOCKcluster(rep("localhost", ncpus))
|
| 552 |
# # No need for |
|
| 553 |
# if(RNGkind()[1L] == "L'Ecuyer-CMRG") |
|
| 554 |
# clusterSetRNGStream() always calls `RNGkind("L'Ecuyer-CMRG")`
|
|
| 555 | ! |
parallel::clusterSetRNGStream(cl, iseed = iseed) |
| 556 | ! |
res <- parallel::parLapply(cl, seq_len(RR), fn) |
| 557 | ! |
parallel::stopCluster(cl) |
| 558 | ! |
res |
| 559 |
} else {
|
|
| 560 | ! |
parallel::parLapply(cl, seq_len(RR), fn) |
| 561 |
} |
|
| 562 |
} |
|
| 563 |
} else {
|
|
| 564 | ! |
lapply(seq_len(RR), fn) |
| 565 |
} |
|
| 566 | ||
| 567 |
# restore old RNGkind() |
|
| 568 | ! |
if (ncpus > 1L && have_mc) {
|
| 569 | ! |
RNGkind(RNGkind_old[1], RNGkind_old[2], RNGkind_old[3]) |
| 570 |
} |
|
| 571 | ||
| 572 |
# fill in container |
|
| 573 | ! |
t.star[] <- do.call("rbind", res)
|
| 574 | ||
| 575 |
# handle errors |
|
| 576 | ! |
error.idx <- which(sapply(res, function(x) is.na(x[1L]))) |
| 577 | ! |
attr(t.star, "error.idx") <- error.idx # could be integer(0L) |
| 578 | ||
| 579 |
# handle nonadmissible solutions |
|
| 580 | ! |
if (check.post) {
|
| 581 | ! |
notok <- which(sapply(res, attr, "nonadmissible.flag")) |
| 582 | ! |
if (length(error.idx) > 0L) {
|
| 583 | ! |
notok <- notok[-which(notok %in% error.idx)] |
| 584 |
} |
|
| 585 | ! |
attr(t.star, "nonadmissible") <- notok |
| 586 |
} |
|
| 587 | ||
| 588 |
# store iseed |
|
| 589 | ! |
attr(t.star, "seed") <- iseed |
| 590 | ||
| 591 |
# handle temp.seed |
|
| 592 | ! |
if (!is.null(temp.seed) && !identical(temp.seed, NA)) {
|
| 593 | ! |
assign(".Random.seed", temp.seed, envir = .GlobalEnv)
|
| 594 | ! |
} else if (is.null(temp.seed) && !(ncpus > 1L && (have_mc || have_snow))) {
|
| 595 |
# serial |
|
| 596 | ! |
rm(.Random.seed, pos = 1) |
| 597 | ! |
} else if (is.null(temp.seed) && (ncpus > 1L && have_mc)) {
|
| 598 |
# parallel/multicore only |
|
| 599 | ! |
rm(.Random.seed, pos = 1) # because set used set.seed() |
| 600 |
} |
|
| 601 | ||
| 602 |
# store BOOT.idx per group |
|
| 603 | ! |
if (keep.idx) {
|
| 604 | ! |
BOOT.idx <- vector("list", length = lavsamplestats@ngroups)
|
| 605 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 606 |
# note that failed runs (NULL) are removed (for now) |
|
| 607 | ! |
BOOT.idx[[g]] <- do.call( |
| 608 | ! |
"rbind", |
| 609 | ! |
lapply(res, function(x) attr(x, "BOOT.idx")[[g]]) |
| 610 |
) |
|
| 611 |
} |
|
| 612 | ! |
attr(t.star, "boot.idx") <- BOOT.idx |
| 613 |
} |
|
| 614 | ||
| 615 |
# # No use, as boot package stores the sample indices differently |
|
| 616 |
# # See boot:::boot.array() versus lav_bootstrap_indices() |
|
| 617 |
# if(return.boot) {
|
|
| 618 |
# # mimic output boot function |
|
| 619 |
# |
|
| 620 |
# if(is.null(object)) {
|
|
| 621 |
# stop("lavaan ERROR: return.boot = TRUE requires a full lavaan object")
|
|
| 622 |
# } |
|
| 623 |
# |
|
| 624 |
# # we start with ordinary only for now |
|
| 625 |
# stopifnot(type == "ordinary") |
|
| 626 |
# |
|
| 627 |
# if(! type %in% c("ordinary", "parametric")) {
|
|
| 628 |
# stop("lavaan ERROR: only ordinary and parametric bootstrap are supported if return.boot = TRUE")
|
|
| 629 |
# } else {
|
|
| 630 |
# sim <- type |
|
| 631 |
# } |
|
| 632 |
# |
|
| 633 |
# statistic. <- function(data, idx) {
|
|
| 634 |
# data.boot <- data[idx,] |
|
| 635 |
# fit.boot <- update(object, data = data.boot) |
|
| 636 |
# out <- try(FUN(fit.boot, ...), silent = TRUE) |
|
| 637 |
# if(inherits(out, "try-error")) {
|
|
| 638 |
# out <- rep(as.numeric(NA), length(t0)) |
|
| 639 |
# } |
|
| 640 |
# out |
|
| 641 |
# } |
|
| 642 |
# attr(t.star, "seed") <- NULL |
|
| 643 |
# attr(t.star, "nonadmissible") <- NULL |
|
| 644 |
# out <- list(t0 = t0, t = t.star, R = RR, |
|
| 645 |
# data = lavInspect(object, "data"), |
|
| 646 |
# seed = iseed, statistic = statistic., |
|
| 647 |
# sim = sim, call = mc) |
|
| 648 |
# |
|
| 649 |
# #if(sim == "parametric") {
|
|
| 650 |
# # ran.gen. <- function() {} # TODO
|
|
| 651 |
# # out <- c(out, list(ran.gen = ran.gen, mle = mle)) |
|
| 652 |
# #} else if(sim == "ordinary") {
|
|
| 653 |
# stype <- "i" |
|
| 654 |
# strata <- rep(1, nobs(object)) |
|
| 655 |
# weights <- 1/tabulate(strata)[strata] |
|
| 656 |
# out <- c(out, list(stype = stype, strata = strata, |
|
| 657 |
# weights = weights)) |
|
| 658 |
# #} |
|
| 659 |
# |
|
| 660 |
# class(out) <- "boot" |
|
| 661 |
# return(out) |
|
| 662 |
# } |
|
| 663 |
# |
|
| 664 | ! |
t.star |
| 665 |
} |
|
| 666 | ||
| 667 |
# create matrix with indices to reconstruct the bootstrap samples |
|
| 668 |
# per group |
|
| 669 |
# (originally needed for BCa confidence intervals) |
|
| 670 |
# |
|
| 671 |
# rows are the (R) bootstrap runs |
|
| 672 |
# columns are the (N) observations |
|
| 673 |
# |
|
| 674 |
# simple version: no strata, no weights |
|
| 675 |
# |
|
| 676 |
lav_bootstrap_indices <- function(R = 0L, |
|
| 677 |
nobs = list(0L), # per group |
|
| 678 |
parallel = "no", |
|
| 679 |
ncpus = 1L, |
|
| 680 |
cl = NULL, |
|
| 681 |
iseed = NULL, |
|
| 682 |
merge.groups = FALSE, |
|
| 683 |
return.freq = FALSE) {
|
|
| 684 |
# iseed must be set! |
|
| 685 | ! |
stopifnot(!is.null(iseed)) |
| 686 | ||
| 687 | ! |
if (return.freq && !merge.groups) {
|
| 688 | ! |
lav_msg_stop(gettext("return.freq only available if merge.groups = TRUE"))
|
| 689 |
} |
|
| 690 | ||
| 691 | ! |
if (is.integer(nobs)) {
|
| 692 | ! |
nobs <- list(nobs) |
| 693 |
} |
|
| 694 | ||
| 695 |
# number of groups |
|
| 696 | ! |
ngroups <- length(nobs) |
| 697 | ||
| 698 |
# mimic 'random' sampling from lav_bootstrap_internal: |
|
| 699 | ||
| 700 |
# the next 7 lines are borrowed from the boot package |
|
| 701 | ! |
have_mc <- have_snow <- FALSE |
| 702 | ! |
parallel <- parallel[1] |
| 703 | ! |
if (parallel != "no" && ncpus > 1L) {
|
| 704 | ! |
if (parallel == "multicore") {
|
| 705 | ! |
have_mc <- .Platform$OS.type != "windows" |
| 706 | ! |
} else if (parallel == "snow") have_snow <- TRUE |
| 707 | ! |
if (!have_mc && !have_snow) ncpus <- 1L |
| 708 | ! |
loadNamespace("parallel") # before recording seed!
|
| 709 |
} |
|
| 710 | ! |
temp.seed <- NULL |
| 711 | ! |
if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 712 | ! |
temp.seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
|
| 713 |
} |
|
| 714 | ! |
if (!(ncpus > 1L && (have_mc || have_snow))) { # Only for serial
|
| 715 | ! |
set.seed(iseed) |
| 716 |
} |
|
| 717 | ||
| 718 |
# fn() returns indices per group |
|
| 719 | ! |
fn <- function(b) {
|
| 720 | ! |
BOOT.idx <- vector("list", length = ngroups)
|
| 721 | ! |
OFFSet <- cumsum(c(0, unlist(nobs))) |
| 722 | ! |
for (g in 1:ngroups) {
|
| 723 | ! |
stopifnot(nobs[[g]] > 1L) |
| 724 | ! |
boot.idx <- sample.int(nobs[[g]], replace = TRUE) |
| 725 | ! |
if (merge.groups) {
|
| 726 | ! |
BOOT.idx[[g]] <- boot.idx + OFFSet[g] |
| 727 |
} else {
|
|
| 728 | ! |
BOOT.idx[[g]] <- boot.idx |
| 729 |
} |
|
| 730 |
} |
|
| 731 | ! |
BOOT.idx |
| 732 |
} |
|
| 733 | ||
| 734 | ! |
RR <- R |
| 735 | ! |
res <- if (ncpus > 1L && (have_mc || have_snow)) {
|
| 736 | ! |
if (have_mc) {
|
| 737 | ! |
RNGkind_old <- RNGkind() # store current kind |
| 738 | ! |
RNGkind("L'Ecuyer-CMRG") # to allow for reproducible results
|
| 739 | ! |
set.seed(iseed) |
| 740 | ! |
parallel::mclapply(seq_len(RR), fn, mc.cores = ncpus) |
| 741 | ! |
} else if (have_snow) {
|
| 742 |
# list(...) # evaluate any promises |
|
| 743 | ! |
if (is.null(cl)) {
|
| 744 | ! |
cl <- parallel::makePSOCKcluster(rep("localhost", ncpus))
|
| 745 | ! |
parallel::clusterSetRNGStream(cl, iseed = iseed) |
| 746 | ! |
res <- parallel::parLapply(cl, seq_len(RR), fn) |
| 747 | ! |
parallel::stopCluster(cl) |
| 748 | ! |
res |
| 749 |
} else {
|
|
| 750 | ! |
parallel::parLapply(cl, seq_len(RR), fn) |
| 751 |
} |
|
| 752 |
} |
|
| 753 |
} else {
|
|
| 754 | ! |
lapply(seq_len(RR), fn) |
| 755 |
} |
|
| 756 | ||
| 757 |
# restore old RNGkind() |
|
| 758 | ! |
if (ncpus > 1L && have_mc) {
|
| 759 | ! |
RNGkind(RNGkind_old[1], RNGkind_old[2], RNGkind_old[3]) |
| 760 |
} |
|
| 761 | ||
| 762 |
# handle temp.seed |
|
| 763 | ! |
if (!is.null(temp.seed) && !identical(temp.seed, NA)) {
|
| 764 | ! |
assign(".Random.seed", temp.seed, envir = .GlobalEnv)
|
| 765 | ! |
} else if (is.null(temp.seed) && !(ncpus > 1L && (have_mc || have_snow))) {
|
| 766 |
# serial |
|
| 767 | ! |
rm(.Random.seed, pos = 1) |
| 768 | ! |
} else if (is.null(temp.seed) && (ncpus > 1L && have_mc)) {
|
| 769 |
# parallel/multicore only |
|
| 770 | ! |
rm(.Random.seed, pos = 1) # because set used set.seed() |
| 771 |
} |
|
| 772 | ||
| 773 | ||
| 774 |
# assemble IDX |
|
| 775 | ! |
BOOT.idx <- vector("list", length = ngroups)
|
| 776 | ! |
for (g in 1:ngroups) {
|
| 777 |
# FIXME: handle failed runs |
|
| 778 | ! |
BOOT.idx[[g]] <- do.call("rbind", lapply(res, "[[", g))
|
| 779 |
} |
|
| 780 | ||
| 781 |
# merge groups |
|
| 782 | ! |
if (merge.groups) {
|
| 783 | ! |
out <- do.call("cbind", BOOT.idx)
|
| 784 |
} else {
|
|
| 785 | ! |
out <- BOOT.idx |
| 786 |
} |
|
| 787 | ||
| 788 |
# NOTE: the order of the indices is different from the boot package! |
|
| 789 |
# we fill in the matrix 'row-wise' (1 row = sample(N, replace = TRUE)), |
|
| 790 |
# while boot fills in the matrix 'column-wise' |
|
| 791 |
# this also explains why we get different results with return.boot = TRUE |
|
| 792 |
# despite using the same iseed |
|
| 793 | ||
| 794 |
# return frequencies instead? |
|
| 795 | ! |
if (return.freq && merge.groups) {
|
| 796 | ! |
out <- t(apply(out, 1L, tabulate, ncol(out))) |
| 797 |
} |
|
| 798 | ||
| 799 | ! |
out |
| 800 |
} |
|
| 801 |
| 1 |
# This code is written by YR (using lavaan components), but based on |
|
| 2 |
# research code written by Mariska Barendse (Groningen/Amsterdam, NL) |
|
| 3 |
# |
|
| 4 |
# September 2013 |
|
| 5 |
# |
|
| 6 |
# Three fit indices for the PML estimator (if all categorical, no exo) |
|
| 7 |
# - Cp(max) |
|
| 8 |
# - CF |
|
| 9 |
# - CM |
|
| 10 | ||
| 11 |
# FIXME: how to handle multiple groups?? |
|
| 12 | ||
| 13 |
# Mariska Barendse Cp statistic |
|
| 14 |
# lav_tables_fit_Cp <- function(object, alpha = 0.05) {
|
|
| 15 |
# |
|
| 16 |
# out <- lavTablesFit(object, statistic = "G2", p.value = TRUE) |
|
| 17 |
# |
|
| 18 |
# # Bonferonni adjusted p-value |
|
| 19 |
# ntests <- length(out$lhs) |
|
| 20 |
# out$alpha.adj <- alpha / ntests |
|
| 21 |
# #out$pval <- pchisq(out$G2, df=out$df, lower.tail = FALSE) |
|
| 22 |
# |
|
| 23 |
# # remove G2.h0.pval |
|
| 24 |
# #out$G2.h0.pval <- NULL |
|
| 25 |
# |
|
| 26 |
# out |
|
| 27 |
# } |
|
| 28 | ||
| 29 |
lavTablesFitCp <- function(object, alpha = 0.05) {
|
|
| 30 | ! |
lavdata <- object@Data |
| 31 | ||
| 32 | ! |
if (!any(lavdata@ov$type == "ordered")) {
|
| 33 | ! |
return(list( |
| 34 | ! |
G2 = as.numeric(NA), df = as.numeric(NA), |
| 35 | ! |
p.value = as.numeric(NA), p.value.Bonferroni = as.numeric(NA) |
| 36 |
)) |
|
| 37 |
} |
|
| 38 | ||
| 39 | ! |
TF <- lavTables(object, |
| 40 | ! |
dimension = 2L, type = "table", |
| 41 | ! |
statistic = "G2", p.value = TRUE |
| 42 |
) |
|
| 43 | ||
| 44 |
# Bonferonni adjusted p-value |
|
| 45 | ! |
ntests <- length(TF$lhs) |
| 46 | ! |
TF$alpha.adj <- alpha / ntests |
| 47 | ||
| 48 | ! |
out <- subset(TF, TF$G2.pval < TF$alpha.adj) |
| 49 | ||
| 50 |
# find largest G2 |
|
| 51 | ! |
max.idx <- which(TF$G2 == max(TF$G2)) |
| 52 | ||
| 53 | ! |
extra <- list( |
| 54 | ! |
G2 = unname(TF$G2[max.idx]), df = unname(TF$df[max.idx]), |
| 55 | ! |
lhs = TF$lhs[max.idx], |
| 56 | ! |
rhs = TF$rhs[max.idx], |
| 57 | ! |
group = TF$group[max.idx], |
| 58 | ! |
p.value = unname(TF$G2.pval[max.idx]), |
| 59 | ! |
ntests = ntests, |
| 60 | ! |
p.value.Bonferroni = unname(TF$G2.pval[max.idx] * length(TF$lhs)) |
| 61 |
) |
|
| 62 | ||
| 63 | ! |
attr(out, "CpMax") <- extra |
| 64 | ||
| 65 | ! |
class(out) <- c("lavaan.tables.fit.Cp", "lavaan.data.frame", "data.frame")
|
| 66 | ||
| 67 | ! |
out |
| 68 |
} |
|
| 69 | ||
| 70 |
lav_tables_fit_cp_print <- function(x, ...) {
|
|
| 71 | ! |
cat("CP-values that are significant at a Bonferroni adjusted level of significance\n")
|
| 72 | ! |
tmp <- x |
| 73 | ! |
class(tmp) <- c("lavaan.data.frame", "data.frame")
|
| 74 | ! |
print(tmp) |
| 75 |
} |
|
| 76 | ||
| 77 |
# Mariska Barendse CF statistic |
|
| 78 |
lavTablesFitCf <- function(object) {
|
|
| 79 |
# check object class |
|
| 80 | ! |
if (!inherits(object, "lavaan")) {
|
| 81 | ! |
lav_msg_stop(gettext("object must be an object of class lavaan"))
|
| 82 |
} |
|
| 83 | ! |
lavdata <- object@Data |
| 84 | ! |
lavpta <- object@pta |
| 85 | ! |
lavmodel <- object@Model |
| 86 | ! |
lavcache <- object@Cache |
| 87 | ! |
implied <- object@implied |
| 88 | ||
| 89 | ! |
CF.group <- rep(as.numeric(NA), lavdata@ngroups) |
| 90 | ! |
DF.group <- rep(as.numeric(NA), lavdata@ngroups) |
| 91 | ||
| 92 |
# check if all ordered |
|
| 93 | ! |
if (!any(lavdata@ov$type == "ordered")) {
|
| 94 | ! |
CF <- as.numeric(NA) |
| 95 | ! |
attr(CF, "CF.group") <- CF.group |
| 96 | ! |
attr(CF, "DF.group") <- DF.group |
| 97 | ! |
return(CF) |
| 98 |
} |
|
| 99 | ||
| 100 |
# ord var in this group |
|
| 101 | ! |
ov.ord <- unique(unlist(lavpta$vnames$ov.ord)) |
| 102 | ! |
ov.idx <- which(ov.ord %in% lavdata@ov$name) |
| 103 | ! |
ov.nlev <- lavdata@ov$nlev[ov.idx] |
| 104 | ||
| 105 | ! |
Sigma.hat <- if (lavmodel@conditional.x) implied$res.cov else implied$cov |
| 106 | ! |
TH <- if (lavmodel@conditional.x) implied$res.th else implied$th |
| 107 | ! |
DF <- prod(ov.nlev) - object@optim$npar - 1L |
| 108 | ||
| 109 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 110 | ! |
F.group <- lav_model_objective_fml( |
| 111 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 112 | ! |
TH = TH[[g]], |
| 113 | ! |
th.idx = lavmodel@th.idx[[g]], |
| 114 | ! |
num.idx = lavmodel@num.idx[[g]], |
| 115 | ! |
X = lavdata@X[[g]], |
| 116 | ! |
lavcache = lavcache[[g]] |
| 117 |
) |
|
| 118 | ! |
CF.group[g] <- 2 * lavdata@nobs[[g]] * F.group |
| 119 |
} |
|
| 120 | ||
| 121 |
# check for negative values |
|
| 122 | ! |
CF.group[CF.group < 0] <- 0.0 |
| 123 | ||
| 124 |
# global test statistic |
|
| 125 | ! |
CF <- sum(CF.group) |
| 126 | ||
| 127 | ! |
attr(CF, "CF.group") <- CF.group |
| 128 | ! |
attr(CF, "DF") <- DF |
| 129 | ! |
attr(CF, "rpat.observed") <- sapply(lavdata@Rp, "[[", "npatterns") |
| 130 | ! |
attr(CF, "rpat.total") <- sapply(lavdata@Rp, "[[", "total.patterns") |
| 131 | ! |
attr(CF, "rpat.empty") <- sapply(lavdata@Rp, "[[", "empty.patterns") |
| 132 | ||
| 133 | ! |
class(CF) <- c("lavaan.tables.fit.Cf", "numeric")
|
| 134 | ||
| 135 | ! |
CF |
| 136 |
} |
|
| 137 | ||
| 138 |
lav_tables_fit_cf_print <- function(x, ...) {
|
|
| 139 | ! |
cat("Total response patterns: ", attr(x, "rpat.total"), "\n")
|
| 140 | ! |
cat("Observed response patterns: ", attr(x, "rpat.observed"), "\n")
|
| 141 | ! |
cat("Empty response patterns: ", attr(x, "rpat.empty"), "\n")
|
| 142 | ! |
cat("Cf results may be biased because of large numbers of empty cells in the multivariate contingency table\n")
|
| 143 | ! |
cat("Cf-value, overall:\n")
|
| 144 | ! |
CF <- unclass(x) |
| 145 | ! |
attributes(CF) <- NULL |
| 146 | ! |
print(CF) |
| 147 | ! |
CF.group <- attr(x, "CF.group") |
| 148 | ! |
if (length(CF.group) > 1L) {
|
| 149 | ! |
cat("Cf-value, per group:\n")
|
| 150 | ! |
print(CF.group) |
| 151 |
} |
|
| 152 | ! |
cat("Degrees of freedom\n")
|
| 153 | ! |
print(attr(x, "DF")) |
| 154 |
} |
|
| 155 | ||
| 156 |
lavTablesFitCm <- function(object) {
|
|
| 157 | ! |
lavdata <- object@Data |
| 158 | ! |
lavoptions <- object@Options |
| 159 | ||
| 160 | ! |
CF.h0 <- lavTablesFitCf(object) |
| 161 | ||
| 162 |
# fit unrestricted model |
|
| 163 | ! |
h1 <- lav_object_cor(lavdata, |
| 164 | ! |
estimator = lavoptions$estimator, |
| 165 | ! |
se = "none", test = "none", output = "lavaan" |
| 166 |
) |
|
| 167 | ! |
CF.h1 <- lavTablesFitCf(h1) |
| 168 | ||
| 169 | ! |
CF.h0.group <- attr(CF.h0, "CF.group") |
| 170 | ! |
CF.h1.group <- attr(CF.h1, "CF.group") |
| 171 | ! |
DF.h0 <- attr(CF.h0, "DF") |
| 172 | ! |
DF.h1 <- attr(CF.h1, "DF") |
| 173 | ||
| 174 | ! |
attributes(CF.h0) <- NULL |
| 175 | ! |
attributes(CF.h1) <- NULL |
| 176 | ||
| 177 | ! |
CM <- CF.h0 - CF.h1 |
| 178 | ! |
attr(CM, "CM.group") <- CF.h0.group - CF.h1.group |
| 179 | ! |
attr(CM, "DF") <- DF.h0 - DF.h1 |
| 180 | ||
| 181 | ! |
class(CM) <- c("lavaan.tables.fit.Cm", "numeric")
|
| 182 | ||
| 183 | ! |
CM |
| 184 |
} |
|
| 185 | ||
| 186 | ||
| 187 |
lav_tables_fit_cm_print <- function(x, ...) {
|
|
| 188 |
# cat("The percentage of empty cells\n") #weet niet goed want FML werkt niet
|
|
| 189 |
# cat("CM results may be a little biased because of large numbers of empty cells in the multivariate contingency table\n")
|
|
| 190 | ! |
cat("Cm-value, overall:\n")
|
| 191 | ! |
CM <- unclass(x) |
| 192 | ! |
attributes(CM) <- NULL |
| 193 | ! |
print(CM) |
| 194 | ! |
CM.group <- attr(x, "CM.group") |
| 195 | ! |
if (length(CM.group) > 1L) {
|
| 196 | ! |
cat("Cm-value, per group:\n")
|
| 197 | ! |
print(CM.group) |
| 198 |
} |
|
| 199 | ! |
cat("Degrees of freedom:\n")
|
| 200 | ! |
print(attr(x, "DF")) |
| 201 |
} |
| 1 |
# lav_start.R: provide starting values for model parameters |
|
| 2 |
# |
|
| 3 |
# YR 30/11/2010: initial version |
|
| 4 |
# YR 08/06/2011: add fabin3 start values for factor loadings |
|
| 5 |
# YR 14 Jan 2014: moved to lav_start.R |
|
| 6 | ||
| 7 |
# fill in the 'ustart' column in a User data.frame with reasonable |
|
| 8 |
# starting values, using the sample data |
|
| 9 | ||
| 10 |
lav_start <- function(start.method = "default", |
|
| 11 |
lavpartable = NULL, |
|
| 12 |
lavsamplestats = NULL, |
|
| 13 |
lavh1 = NULL, # fixme: only use lavh1? |
|
| 14 |
model.type = "sem", |
|
| 15 |
reflect = FALSE, # rotation only |
|
| 16 |
samplestats.flag = TRUE, |
|
| 17 |
order.lv.by = "none" # rotation only |
|
| 18 |
) {
|
|
| 19 |
# check arguments |
|
| 20 | 169x |
stopifnot(is.list(lavpartable)) |
| 21 | ||
| 22 |
# categorical? |
|
| 23 | 169x |
categorical <- any(lavpartable$op == "|") |
| 24 | ||
| 25 |
# correlation structure? |
|
| 26 | 169x |
correlation <- any(lavpartable$op == "~*~") |
| 27 | ||
| 28 |
# composites? |
|
| 29 | 169x |
composites <- any(lavpartable$op == "<~") |
| 30 | ||
| 31 |
# conditional.x? |
|
| 32 | 169x |
conditional.x <- any(lavpartable$exo == 1L & |
| 33 | 169x |
lavpartable$op %in% c("~", "<~"))
|
| 34 |
# ord.names <- unique(lavpartable$lhs[ lavpartable$op == "|" ]) |
|
| 35 | ||
| 36 |
# nlevels? |
|
| 37 | 169x |
nlevels <- lav_partable_nlevels(lavpartable) |
| 38 | ||
| 39 |
# reflect/order.lv.by |
|
| 40 | 169x |
if (is.null(reflect)) {
|
| 41 | ! |
reflect <- FALSE |
| 42 |
} |
|
| 43 | 169x |
if (is.null(order.lv.by)) {
|
| 44 | ! |
order.lv.by <- "index" |
| 45 |
} |
|
| 46 | ||
| 47 |
# check start.method |
|
| 48 |
#if (mimic == "lavaan") {
|
|
| 49 | 169x |
start.initial <- "lavaan" |
| 50 |
#} else if (mimic == "Mplus") {
|
|
| 51 |
# start.initial <- "mplus" |
|
| 52 |
#} else {
|
|
| 53 |
# # FIXME: use LISREL/EQS/AMOS/.... schemes |
|
| 54 |
# start.initial <- "lavaan" |
|
| 55 |
#} |
|
| 56 | ||
| 57 |
# start.method |
|
| 58 | 169x |
start.user <- NULL |
| 59 | 169x |
if (is.character(start.method)) {
|
| 60 | 169x |
start.method.lc <- tolower(start.method) |
| 61 | 169x |
if (start.method.lc != "simple" && !samplestats.flag) {
|
| 62 | ! |
start.method.lc <- start.method <- "simple" |
| 63 |
} |
|
| 64 | 169x |
if (start.method.lc == "default") {
|
| 65 |
# nothing to do |
|
| 66 | 63x |
} else if (start.method == "simple") {
|
| 67 | 63x |
start <- numeric(length(lavpartable$ustart)) |
| 68 |
# if(categorical || correlation) {
|
|
| 69 | 63x |
start[which(lavpartable$op == "=~")] <- 0.7 |
| 70 | 63x |
start[which(lavpartable$op == "<~")] <- 1 |
| 71 |
# } else {
|
|
| 72 |
# start[ which(lavpartable$op == "=~") ] <- 1.0 |
|
| 73 |
# } |
|
| 74 | 63x |
start[which(lavpartable$op == "~*~")] <- 1.0 |
| 75 | 63x |
ov.names.ord <- lav_partable_vnames(lavpartable, "ov.ord") |
| 76 | 63x |
var.idx <- which(lavpartable$op == "~~" & |
| 77 | 63x |
lavpartable$lhs == lavpartable$rhs & |
| 78 | 63x |
!(lavpartable$lhs %in% ov.names.ord)) |
| 79 | 63x |
start[var.idx] <- 1.0 |
| 80 | 63x |
user.idx <- which(!is.na(lavpartable$ustart)) |
| 81 | 63x |
start[user.idx] <- lavpartable$ustart[user.idx] |
| 82 | 63x |
return(start) # assuming fixed.x = FALSE! |
| 83 | ! |
} else if (start.method == "est") {
|
| 84 | ! |
return(lavpartable$est) |
| 85 | ! |
} else if (start.method.lc %in% c("simple", "lavaan")) {
|
| 86 | ! |
start.initial <- start.method.lc |
| 87 |
} else {
|
|
| 88 | ! |
lav_msg_stop(gettext("unknown value for start argument"))
|
| 89 |
} |
|
| 90 | ! |
} else if (is.list(start.method)) {
|
| 91 | ! |
start.user <- start.method |
| 92 | ! |
} else if (is.numeric(start.method)) {
|
| 93 | ! |
nx.free <- sum(lavpartable$free > 0L) |
| 94 | ! |
if (length(start.method) != nx.free) {
|
| 95 | ! |
lav_msg_stop(gettextf( |
| 96 | ! |
"start argument contains %1$s elements; but parameter table |
| 97 | ! |
expects %2$s free parameters.", length(start.method), nx.free)) |
| 98 |
} |
|
| 99 | ! |
lavpartable$ustart[lavpartable$free > 0L] <- start.method |
| 100 | ! |
} else if (inherits(start.method, "lavaan")) {
|
| 101 | ! |
start.user <- parTable(start.method) |
| 102 |
} |
|
| 103 | ||
| 104 |
# check model list elements, if provided |
|
| 105 | 106x |
if (!is.null(start.user)) {
|
| 106 | ! |
if (is.null(start.user$lhs) || |
| 107 | ! |
is.null(start.user$op) || |
| 108 | ! |
is.null(start.user$rhs)) {
|
| 109 | ! |
lav_msg_stop(gettext( |
| 110 | ! |
"problem with start argument: model list does not contain |
| 111 | ! |
all elements: lhs/op/rhs")) |
| 112 |
} |
|
| 113 | ! |
if (!is.null(start.user$est)) {
|
| 114 |
# excellent, we got an est column; nothing to do |
|
| 115 | ! |
} else if (!is.null(start.user$start)) {
|
| 116 |
# no est column, but we use the start column |
|
| 117 | ! |
start.user$est <- start.user$start |
| 118 | ! |
} else if (!is.null(start.user$ustart)) {
|
| 119 |
# no ideal, but better than nothing |
|
| 120 | ! |
start.user$est <- start.user$ustart |
| 121 |
} else {
|
|
| 122 | ! |
lav_msg_stop(gettext( |
| 123 | ! |
"problem with start argument: could not find est/start column |
| 124 | ! |
in model list")) |
| 125 |
} |
|
| 126 |
} |
|
| 127 | ||
| 128 | ||
| 129 |
# global settings |
|
| 130 |
# 0. everyting is zero |
|
| 131 | 106x |
start <- numeric(length(lavpartable$ustart)) |
| 132 | ||
| 133 |
# 1. =~ factor loadings: |
|
| 134 | 106x |
if (categorical || correlation) {
|
| 135 |
# if std.lv=TRUE, 0.8 is too large |
|
| 136 | 4x |
start[which(lavpartable$op == "=~")] <- 0.7 |
| 137 |
} else {
|
|
| 138 | 102x |
start[which(lavpartable$op == "=~")] <- 1.0 |
| 139 |
} |
|
| 140 | ||
| 141 |
# 2. (residual) lv variances for latent variables |
|
| 142 | 106x |
lv.names <- lav_partable_vnames(lavpartable, "lv") # all groups |
| 143 | 106x |
lv.var.idx <- which(lavpartable$op == "~~" & |
| 144 | 106x |
lavpartable$lhs %in% lv.names & |
| 145 | 106x |
lavpartable$lhs == lavpartable$rhs) |
| 146 | 106x |
start[lv.var.idx] <- 0.05 |
| 147 |
# start[lv.var.idx] <- 0.5 # new in 0.6-2? (for optim.parscale = "stand") |
|
| 148 | ||
| 149 |
# 3. latent response scales (if any) |
|
| 150 | 106x |
delta.idx <- which(lavpartable$op == "~*~") |
| 151 | 106x |
start[delta.idx] <- 1.0 |
| 152 | ||
| 153 | ||
| 154 |
# group-specific settings |
|
| 155 | 106x |
ngroups <- lav_partable_ngroups(lavpartable) |
| 156 | ||
| 157 |
# for now, if no group column, add one (again), until we rewrite |
|
| 158 |
# this function to handle block/group hybrid settings |
|
| 159 | 106x |
if (is.null(lavpartable$group) && ngroups == 1L) {
|
| 160 | ! |
lavpartable$group <- rep(1L, length(lavpartable$lhs)) |
| 161 | ! |
lavpartable$group[lavpartable$block == 0L] <- 0L |
| 162 |
} |
|
| 163 | ||
| 164 |
# group values |
|
| 165 | 106x |
group.values <- lav_partable_group_values(lavpartable) |
| 166 | ||
| 167 | 106x |
for (g in 1:ngroups) {
|
| 168 | ||
| 169 |
# info from user model for this group |
|
| 170 | 114x |
if (conditional.x) {
|
| 171 | 4x |
ov.names <- lav_partable_vnames(lavpartable, "ov.nox", group = group.values[g]) |
| 172 |
} else {
|
|
| 173 | 110x |
ov.names <- lav_partable_vnames(lavpartable, "ov", group = group.values[g]) |
| 174 |
} |
|
| 175 | 114x |
if (categorical) {
|
| 176 | 4x |
ov.names.num <- lav_partable_vnames(lavpartable, "ov.num", group = group.values[g]) |
| 177 | 4x |
ov.names.ord <- lav_partable_vnames(lavpartable, "ov.ord", group = group.values[g]) |
| 178 |
} else {
|
|
| 179 | 110x |
ov.names.num <- ov.names |
| 180 |
} |
|
| 181 | 114x |
lv.names <- lav_partable_vnames(lavpartable, "lv", group = group.values[g]) |
| 182 | 114x |
lv.names.efa <- lav_partable_vnames(lavpartable, "lv.efa", group = group.values[g]) |
| 183 | 114x |
ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", group = group.values[g]) |
| 184 | 114x |
ov.ind.c <- lav_partable_vnames(lavpartable, "ov.cind", group = group.values[g]) |
| 185 | 114x |
lv.names.c <- lav_partable_vnames(lavpartable, "lv.composite", group = group.values[g]) |
| 186 | ||
| 187 |
# just for the nlevels >1 case |
|
| 188 | 114x |
ov.names <- unique(unlist(ov.names)) |
| 189 | 114x |
ov.names.num <- unique(unlist(ov.names.num)) |
| 190 | 114x |
lv.names <- unique(unlist(lv.names)) |
| 191 | 114x |
lv.names.efa <- unique(unlist(lv.names.efa)) |
| 192 | 114x |
ov.names.x <- unique(unlist(ov.names.x)) |
| 193 | 114x |
ov.ind.c <- unique(unlist(ov.ind.c)) |
| 194 | 114x |
lv.names.c <- unique(unlist(lv.names.c)) |
| 195 | 114x |
lv.names.noc <- lv.names[!lv.names %in% lv.names.c] |
| 196 | ||
| 197 |
# residual ov variances (including exo/ind, to be overriden) |
|
| 198 | 114x |
ov.var.idx <- which(lavpartable$group == group.values[g] & |
| 199 | 114x |
lavpartable$op == "~~" & |
| 200 | 114x |
lavpartable$lhs %in% ov.names.num & |
| 201 | 114x |
lavpartable$lhs == lavpartable$rhs) |
| 202 | 114x |
sample.var.idx <- match(lavpartable$lhs[ov.var.idx], ov.names) |
| 203 | 114x |
if (model.type == "unrestricted") {
|
| 204 |
# this does not work if conditional.x = TRUE... |
|
| 205 | ! |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 206 | ! |
h1.cov <- lavh1$implied$cov[[g]] |
| 207 | ! |
} else if (!is.null(lavsamplestats@missing.h1[[g]])) {
|
| 208 | ! |
h1.cov <- lavsamplestats@missing.h1[[g]]$sigma |
| 209 |
} else {
|
|
| 210 | ! |
h1.cov <- lavsamplestats@cov[[g]] |
| 211 |
} |
|
| 212 | ! |
start[ov.var.idx] <- diag(h1.cov)[sample.var.idx] |
| 213 |
} else {
|
|
| 214 |
#if (start.initial == "mplus") {
|
|
| 215 |
# if (conditional.x && nlevels == 1L) {
|
|
| 216 |
# start[ov.var.idx] <- |
|
| 217 |
# (1.0 - 0.50) * lavsamplestats@res.var[[1L]][sample.var.idx] |
|
| 218 |
# } else {
|
|
| 219 |
# start[ov.var.idx] <- |
|
| 220 |
# (1.0 - 0.50) * lavsamplestats@var[[1L]][sample.var.idx] |
|
| 221 |
# } |
|
| 222 |
#} else {
|
|
| 223 | 114x |
if (conditional.x && nlevels == 1L) {
|
| 224 | 4x |
start[ov.var.idx] <- |
| 225 | 4x |
(1.0 - 0.50) * diag(lavsamplestats@res.cov[[g]])[sample.var.idx] |
| 226 |
} else {
|
|
| 227 | 110x |
start[ov.var.idx] <- |
| 228 | 110x |
(1.0 - 0.50) * diag(lavsamplestats@cov[[g]])[sample.var.idx] |
| 229 |
} |
|
| 230 |
#} |
|
| 231 |
# composite indicators: fill in total variances |
|
| 232 | 114x |
if (composites) {
|
| 233 | ! |
start[ov.var.idx] <- diag(lavsamplestats@cov[[g]])[sample.var.idx] |
| 234 |
} |
|
| 235 |
} |
|
| 236 | ||
| 237 |
# 1-fac measurement models: loadings, psi, theta |
|
| 238 | 114x |
if (start.initial %in% c("lavaan") &&
|
| 239 | 114x |
model.type %in% c("sem", "cfa")) {
|
| 240 |
# fabin3 estimator (2sls) of Hagglund (1982) per factor |
|
| 241 | 114x |
for (f in lv.names.noc) {
|
| 242 |
# not for efa factors |
|
| 243 | 119x |
if (f %in% lv.names.efa) {
|
| 244 | 10x |
next |
| 245 |
} |
|
| 246 | 109x |
lambda.idx <- which(lavpartable$lhs == f & |
| 247 | 109x |
lavpartable$op == "=~" & |
| 248 | 109x |
lavpartable$group == group.values[g]) |
| 249 |
# standardized? |
|
| 250 | 109x |
std.lv <- FALSE |
| 251 | 109x |
var.f.idx <- which(lavpartable$lhs == f & |
| 252 | 109x |
lavpartable$op == "~~" & |
| 253 | 109x |
lavpartable$group == group.values[g] & |
| 254 | 109x |
lavpartable$rhs == f) |
| 255 | 109x |
if (length(var.f.idx) > 0L && |
| 256 | 109x |
all(lavpartable$free[var.f.idx] == 0) && |
| 257 | 109x |
all(lavpartable$ustart[var.f.idx] == 1)) {
|
| 258 | 4x |
std.lv <- TRUE |
| 259 |
} |
|
| 260 | ||
| 261 |
# no second order |
|
| 262 | 26x |
if (any(lavpartable$rhs[lambda.idx] %in% lv.names)) next |
| 263 | ||
| 264 |
# get observed indicators for this latent variable |
|
| 265 | 83x |
ov.idx <- match(lavpartable$rhs[lambda.idx], ov.names) |
| 266 | 83x |
if (length(ov.idx) > 0L && !any(is.na(ov.idx))) {
|
| 267 | 83x |
if (lavsamplestats@missing.flag && nlevels == 1L) {
|
| 268 | ! |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 269 | ! |
h1.cov <- lavh1$implied$cov[[g]] |
| 270 |
} else {
|
|
| 271 | ! |
h1.cov <- lavsamplestats@missing.h1[[g]]$sigma |
| 272 |
} |
|
| 273 | ! |
COV <- h1.cov[ov.idx, ov.idx, drop = FALSE] |
| 274 |
} else {
|
|
| 275 | 83x |
if (conditional.x && nlevels == 1L) {
|
| 276 | 10x |
COV <- lavsamplestats@res.cov[[g]][ov.idx, |
| 277 | 10x |
ov.idx, |
| 278 | 10x |
drop = FALSE |
| 279 |
] |
|
| 280 |
} else {
|
|
| 281 | 73x |
COV <- lavsamplestats@cov[[g]][ov.idx, |
| 282 | 73x |
ov.idx, |
| 283 | 73x |
drop = FALSE |
| 284 |
] |
|
| 285 |
} |
|
| 286 |
} |
|
| 287 | ||
| 288 |
# fabin for 1-factor |
|
| 289 | 83x |
fabin <- lav_cfa_1fac_fabin(COV, |
| 290 | 83x |
std.lv = std.lv, |
| 291 | 83x |
lambda.only = TRUE, |
| 292 | 83x |
method = "fabin3" |
| 293 |
) |
|
| 294 | ||
| 295 |
# factor loadings |
|
| 296 | 83x |
tmp <- fabin$lambda |
| 297 | 83x |
tmp[!is.finite(tmp)] <- 1.0 # just in case (eg 0/0) |
| 298 | ||
| 299 |
# check for negative triad if nvar=3L (new in 0.6-8) |
|
| 300 | 83x |
if (!is.null(fabin$neg.triad) && fabin$neg.triad) {
|
| 301 | ! |
if (std.lv) {
|
| 302 | ! |
tmp <- rep(0.7, length(tmp)) |
| 303 |
} else {
|
|
| 304 | ! |
tmp <- rep(1.0, length(tmp)) |
| 305 |
} |
|
| 306 |
} |
|
| 307 | ||
| 308 |
# check for negative marker |
|
| 309 | 83x |
if (!std.lv && !is.na(lavpartable$ustart[lambda.idx[1]]) && |
| 310 | 83x |
lavpartable$ustart[lambda.idx[1]] < 0) {
|
| 311 | ! |
tmp <- -1 * tmp |
| 312 |
} |
|
| 313 | ||
| 314 | 83x |
start[lambda.idx] <- tmp |
| 315 | ||
| 316 |
# factor variance |
|
| 317 |
# if(!std.lv) {
|
|
| 318 |
# start[var.f.idx] <- fabin$psi |
|
| 319 |
# # if residual var, make smaller |
|
| 320 |
# y.idx <- which(lavpartable$lhs == f & |
|
| 321 |
# lavpartable$group == group.values[g] & |
|
| 322 |
# lavpartable$op == "~") |
|
| 323 |
# if(length(y.idx) > 0L) {
|
|
| 324 |
# # how much explained variance do we expect? |
|
| 325 |
# # we take 0.50 |
|
| 326 |
# start[var.f.idx] <- 0.5 * start[var.f.idx] |
|
| 327 |
# } |
|
| 328 |
# # no negative variances (we get these if we have an |
|
| 329 |
# # inconsistent triad (eg, covariance signs are +,+,-) |
|
| 330 |
# if(start[var.f.idx] < 0) {
|
|
| 331 |
# start[var.f.idx] <- 0.05 |
|
| 332 |
# } |
|
| 333 |
# } |
|
| 334 | ||
| 335 |
# NOTE: fabin (sometimes) gives residual variances |
|
| 336 |
# that are larger than the original variances... |
|
| 337 | ||
| 338 |
# residual variances -- order? |
|
| 339 |
# res.idx <- which(lavpartable$lhs %in% ov.names[ov.idx] & |
|
| 340 |
# lavpartable$op == "~~" & |
|
| 341 |
# lavpartable$group == group.values[g] & |
|
| 342 |
# lavpartable$rhs == lavpartable$lhs) |
|
| 343 |
# start[res.idx] <- fabin$theta |
|
| 344 | ||
| 345 |
# negative variances? |
|
| 346 |
# neg.idx <- which(start[res.idx] < 0) |
|
| 347 |
# if(length(neg.idx) > 0L) {
|
|
| 348 |
# start[res.idx][neg.idx] <- 0.05 |
|
| 349 |
# } |
|
| 350 |
} |
|
| 351 |
} # fabin3 |
|
| 352 | ||
| 353 |
# efa? |
|
| 354 | 114x |
nefa <- lav_partable_nefa(lavpartable) |
| 355 | 114x |
if (nefa > 0L) {
|
| 356 | 4x |
efa.values <- lav_partable_efa_values(lavpartable) |
| 357 | ||
| 358 | 4x |
for (set in seq_len(nefa)) {
|
| 359 |
# determine ov idx for this set |
|
| 360 | 4x |
ov.efa <- |
| 361 | 4x |
unique(lavpartable$rhs[lavpartable$op == "=~" & |
| 362 | 4x |
lavpartable$block == g & |
| 363 | 4x |
lavpartable$efa == efa.values[set]]) |
| 364 | 4x |
lv.efa <- |
| 365 | 4x |
unique(lavpartable$lhs[lavpartable$op == "=~" & |
| 366 | 4x |
lavpartable$block == g & |
| 367 | 4x |
lavpartable$efa == efa.values[set]]) |
| 368 | 4x |
lambda.idx <- which(lavpartable$lhs %in% lv.efa & |
| 369 | 4x |
lavpartable$op == "=~" & |
| 370 | 4x |
lavpartable$group == group.values[g]) |
| 371 | ||
| 372 | 4x |
theta.idx <- which(lavpartable$lhs %in% ov.efa & |
| 373 | 4x |
lavpartable$op == "~~" & |
| 374 | 4x |
lavpartable$lhs == lavpartable$rhs & |
| 375 | 4x |
lavpartable$group == group.values[g]) |
| 376 | ||
| 377 |
# get observed indicators for these EFA lv variables |
|
| 378 | 4x |
ov.idx <- match( |
| 379 | 4x |
unique(lavpartable$rhs[lambda.idx]), |
| 380 | 4x |
ov.names |
| 381 |
) |
|
| 382 | ||
| 383 | 4x |
if (length(ov.idx) > 0L && !any(is.na(ov.idx))) {
|
| 384 | 4x |
if (lavsamplestats@missing.flag && nlevels == 1L) {
|
| 385 | ! |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 386 | ! |
h1.cov <- lavh1$implied$cov[[g]] |
| 387 |
} else {
|
|
| 388 | ! |
h1.cov <- lavsamplestats@missing.h1[[g]]$sigma |
| 389 |
} |
|
| 390 | ! |
COV <- h1.cov[ov.idx, ov.idx, drop = FALSE] |
| 391 |
} else {
|
|
| 392 | 4x |
if (conditional.x) {
|
| 393 | ! |
COV <- lavsamplestats@res.cov[[g]][ov.idx, |
| 394 | ! |
ov.idx, |
| 395 | ! |
drop = FALSE |
| 396 |
] |
|
| 397 |
} else {
|
|
| 398 | 4x |
COV <- lavsamplestats@cov[[g]][ov.idx, |
| 399 | 4x |
ov.idx, |
| 400 | 4x |
drop = FALSE |
| 401 |
] |
|
| 402 |
} |
|
| 403 |
} |
|
| 404 | ||
| 405 |
# EFA solution with zero upper-right corner |
|
| 406 | 4x |
EFA <- lav_efa_extraction( |
| 407 | 4x |
S = COV, |
| 408 | 4x |
nfactors = length(lv.efa), |
| 409 | 4x |
method = "ML", |
| 410 | 4x |
order.lv.by = order.lv.by, |
| 411 |
# order.lv.by = "none", |
|
| 412 |
# reflect = reflect, |
|
| 413 | 4x |
reflect = FALSE, |
| 414 | 4x |
corner = TRUE |
| 415 |
) |
|
| 416 | ||
| 417 |
# factor loadings |
|
| 418 | 4x |
tmp <- as.numeric(EFA$LAMBDA) |
| 419 | 4x |
tmp[!is.finite(tmp)] <- 1.0 # just in case (eg 0/0) |
| 420 | 4x |
start[lambda.idx] <- tmp |
| 421 | ||
| 422 |
# residual variances |
|
| 423 | 4x |
tmp <- diag(EFA$THETA) |
| 424 | 4x |
tmp[!is.finite(tmp)] <- 1.0 # just in case |
| 425 | 4x |
start[theta.idx] <- tmp |
| 426 |
} |
|
| 427 |
} # set |
|
| 428 |
} # efa |
|
| 429 |
} # factor loadings |
|
| 430 | ||
| 431 | 114x |
if (model.type == "unrestricted") {
|
| 432 |
# fill in 'covariances' from lavsamplestats |
|
| 433 | ! |
cov.idx <- which(lavpartable$group == group.values[g] & |
| 434 | ! |
lavpartable$op == "~~" & |
| 435 | ! |
lavpartable$lhs != lavpartable$rhs) |
| 436 | ! |
lhs.idx <- match(lavpartable$lhs[cov.idx], ov.names) |
| 437 | ! |
rhs.idx <- match(lavpartable$rhs[cov.idx], ov.names) |
| 438 | ! |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 439 | ! |
h1.cov <- lavh1$implied$cov[[g]] |
| 440 | ! |
} else if (!is.null(lavsamplestats@missing.h1[[g]])) {
|
| 441 | ! |
h1.cov <- lavsamplestats@missing.h1[[g]]$sigma |
| 442 |
} else {
|
|
| 443 | ! |
h1.cov <- lavsamplestats@cov[[g]] |
| 444 |
} |
|
| 445 | ! |
start[cov.idx] <- h1.cov[cbind(lhs.idx, rhs.idx)] |
| 446 |
} |
|
| 447 | ||
| 448 |
# composites |
|
| 449 | 114x |
if (composites) {
|
| 450 | ! |
std.lv <- FALSE |
| 451 | ! |
var.f.idx <- which(lavpartable$lhs %in% lv.names.c & |
| 452 | ! |
lavpartable$op == "~~" & |
| 453 | ! |
lavpartable$group == group.values[g] & |
| 454 | ! |
lavpartable$rhs %in% lv.names.c) |
| 455 | ! |
if (length(var.f.idx) > 0L && |
| 456 | ! |
all(lavpartable$free[var.f.idx] == 0) && |
| 457 | ! |
!all(is.na(lavpartable$ustart[var.f.idx])) && |
| 458 | ! |
all(lavpartable$ustart[var.f.idx] == 1)) {
|
| 459 | ! |
std.lv <- TRUE |
| 460 |
} |
|
| 461 | ||
| 462 |
# weights |
|
| 463 | ! |
cidx <- which(lavpartable$group == group.values[g] & |
| 464 | ! |
lavpartable$op == "<~") |
| 465 | ! |
if (std.lv) {
|
| 466 | ! |
start[cidx] <- 0.10 |
| 467 |
} else {
|
|
| 468 | ! |
start[cidx] <- 1 |
| 469 |
} |
|
| 470 | ||
| 471 |
# fill in 'covariances' from lavsamplestats |
|
| 472 | ! |
cov.idx <- which(lavpartable$group == group.values[g] & |
| 473 | ! |
lavpartable$op == "~~" & |
| 474 | ! |
lavpartable$rhs %in% ov.ind.c & |
| 475 | ! |
lavpartable$lhs != lavpartable$rhs) |
| 476 | ! |
lhs.idx <- match(lavpartable$lhs[cov.idx], ov.names) |
| 477 | ! |
rhs.idx <- match(lavpartable$rhs[cov.idx], ov.names) |
| 478 | ! |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 479 | ! |
h1.cov <- lavh1$implied$cov[[g]] |
| 480 | ! |
} else if (!is.null(lavsamplestats@missing.h1[[g]])) {
|
| 481 | ! |
h1.cov <- lavsamplestats@missing.h1[[g]]$sigma |
| 482 |
} else {
|
|
| 483 | ! |
h1.cov <- lavsamplestats@cov[[g]] |
| 484 |
} |
|
| 485 | ! |
start[cov.idx] <- h1.cov[cbind(lhs.idx, rhs.idx)] |
| 486 |
} |
|
| 487 | ||
| 488 |
# variances of ordinal variables - set to 1.0 |
|
| 489 | 114x |
if (categorical) {
|
| 490 | 4x |
ov.var.ord.idx <- which(lavpartable$group == group.values[g] & |
| 491 | 4x |
lavpartable$op == "~~" & |
| 492 | 4x |
lavpartable$lhs %in% ov.names.ord & |
| 493 | 4x |
lavpartable$lhs == lavpartable$rhs) |
| 494 | 4x |
start[ov.var.ord.idx] <- 1.0 |
| 495 |
} |
|
| 496 | ||
| 497 |
# 3g) intercepts/means |
|
| 498 | 114x |
ov.int.idx <- which(lavpartable$group == group.values[g] & |
| 499 | 114x |
lavpartable$op == "~1" & |
| 500 | 114x |
lavpartable$lhs %in% ov.names) |
| 501 | 114x |
sample.int.idx <- match(lavpartable$lhs[ov.int.idx], ov.names) |
| 502 | 114x |
if (lavsamplestats@missing.flag && nlevels == 1L) {
|
| 503 | 32x |
if (!is.null(lavh1$implied$mean[[g]])) {
|
| 504 | 32x |
h1.mean <- lavh1$implied$mean[[g]] |
| 505 | ! |
} else if (!is.null(lavsamplestats@missing.h1[[g]])) {
|
| 506 | ! |
h1.mean <- lavsamplestats@missing.h1[[g]]$mu |
| 507 |
} else {
|
|
| 508 | ! |
h1.mean <- lavsamplestats@mean[[g]] |
| 509 |
} |
|
| 510 | 32x |
start[ov.int.idx] <- h1.mean[sample.int.idx] |
| 511 |
} else {
|
|
| 512 | 82x |
if (conditional.x && nlevels == 1L) {
|
| 513 | 4x |
start[ov.int.idx] <- lavsamplestats@res.int[[g]][sample.int.idx] |
| 514 |
} else {
|
|
| 515 | 78x |
start[ov.int.idx] <- lavsamplestats@mean[[g]][sample.int.idx] |
| 516 |
} |
|
| 517 |
} |
|
| 518 | ||
| 519 |
# TODo: if marker.int.zero = TRUE, set lv means to marker means, |
|
| 520 |
# and the non-marker means to |
|
| 521 |
# lavsamplestats@mean[[g]] - LAMBDA %*% ALPHA |
|
| 522 |
# where ALPHA = means of the markers |
|
| 523 | ||
| 524 |
# 4g) thresholds |
|
| 525 | 114x |
th.idx <- which(lavpartable$group == group.values[g] & |
| 526 | 114x |
lavpartable$op == "|") |
| 527 | 114x |
if (length(th.idx) > 0L) {
|
| 528 | 4x |
th.names.lavpartable <- paste(lavpartable$lhs[th.idx], "|", |
| 529 | 4x |
lavpartable$rhs[th.idx], |
| 530 | 4x |
sep = "" |
| 531 |
) |
|
| 532 | 4x |
th.names.sample <- |
| 533 | 4x |
lavsamplestats@th.names[[g]][lavsamplestats@th.idx[[g]] > 0L] |
| 534 |
# th.names.sample should identical to |
|
| 535 |
# lav_partable_vnames(lavpartable, "th", group = group.values[g]) |
|
| 536 | 4x |
if (conditional.x && nlevels == 1L) {
|
| 537 | 4x |
th.values <- |
| 538 | 4x |
lavsamplestats@res.th[[g]][lavsamplestats@th.idx[[g]] > 0L] |
| 539 |
} else {
|
|
| 540 | ! |
th.values <- |
| 541 | ! |
lavsamplestats@th[[g]][lavsamplestats@th.idx[[g]] > 0L] |
| 542 |
} |
|
| 543 | 4x |
start[th.idx] <- th.values[match( |
| 544 | 4x |
th.names.lavpartable, |
| 545 | 4x |
th.names.sample |
| 546 |
)] |
|
| 547 |
} |
|
| 548 | ||
| 549 |
# 5g) exogenous `fixed.x' covariates |
|
| 550 | 114x |
if (length(ov.names.x) > 0) {
|
| 551 | 42x |
exo.idx <- which(lavpartable$group == group.values[g] & |
| 552 | 42x |
lavpartable$op == "~~" & |
| 553 | 42x |
lavpartable$lhs %in% ov.names.x & |
| 554 | 42x |
lavpartable$rhs %in% ov.names.x) |
| 555 | 42x |
if (!conditional.x) {
|
| 556 | 38x |
row.idx <- match(lavpartable$lhs[exo.idx], ov.names) |
| 557 | 38x |
col.idx <- match(lavpartable$rhs[exo.idx], ov.names) |
| 558 | 38x |
if (lavsamplestats@missing.flag && nlevels == 1L) {
|
| 559 | 24x |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 560 | 24x |
h1.cov <- lavh1$implied$cov[[g]] |
| 561 | ! |
} else if (!is.null(lavsamplestats@missing.h1[[g]])) {
|
| 562 | ! |
h1.cov <- lavsamplestats@missing.h1[[g]]$sigma |
| 563 |
} else {
|
|
| 564 | ! |
h1.cov <- lavsamplestats@cov[[g]] |
| 565 |
} |
|
| 566 | 24x |
start[exo.idx] <- h1.cov[cbind(row.idx, col.idx)] |
| 567 |
# using slightly smaller starting values for free |
|
| 568 |
# variance/covariances (fixed.x = FALSE); |
|
| 569 |
# this somehow avoids false convergence in saturated models |
|
| 570 | 24x |
nobs <- lavsamplestats@nobs[[g]] |
| 571 | 24x |
this.idx <- which(seq_len(length(lavpartable$free)) %in% exo.idx & |
| 572 | 24x |
lavpartable$free > 0L) |
| 573 | 24x |
start[this.idx] <- start[this.idx] * (nobs - 1) / nobs |
| 574 |
} else {
|
|
| 575 | 14x |
start[exo.idx] <- lavsamplestats@cov[[g]][cbind(row.idx, col.idx)] |
| 576 |
} |
|
| 577 |
} else {
|
|
| 578 |
# cov.x |
|
| 579 | 4x |
row.idx <- match(lavpartable$lhs[exo.idx], ov.names.x) |
| 580 | 4x |
col.idx <- match(lavpartable$rhs[exo.idx], ov.names.x) |
| 581 | 4x |
start[exo.idx] <- lavsamplestats@cov.x[[g]][cbind( |
| 582 | 4x |
row.idx, |
| 583 | 4x |
col.idx |
| 584 |
)] |
|
| 585 |
# mean.x |
|
| 586 | 4x |
exo.int.idx <- which(lavpartable$group == group.values[g] & |
| 587 | 4x |
lavpartable$op == "~1" & |
| 588 | 4x |
lavpartable$lhs %in% ov.names.x) |
| 589 | 4x |
int.idx <- match(lavpartable$lhs[exo.int.idx], ov.names.x) |
| 590 | 4x |
start[exo.int.idx] <- lavsamplestats@mean.x[[g]][int.idx] |
| 591 |
} |
|
| 592 |
} |
|
| 593 | ||
| 594 |
# 6b. exogenous lv variances if single indicator -- new in 0.5-21 |
|
| 595 | 114x |
lv.x <- lav_partable_vnames(lavpartable, "lv.x", group = group.values[g]) |
| 596 |
# FIXME: also for multilevel? |
|
| 597 | 114x |
lv.x <- unique(unlist(lv.x)) |
| 598 | 114x |
if (length(lv.x) > 0L) {
|
| 599 | 31x |
for (ll in lv.x) {
|
| 600 | 59x |
ind.idx <- which(lavpartable$op == "=~" & |
| 601 | 59x |
lavpartable$lhs == ll & |
| 602 | 59x |
lavpartable$group == group.values[g]) |
| 603 | 59x |
if (length(ind.idx) == 1L) {
|
| 604 | 2x |
single.ind <- lavpartable$rhs[ind.idx] |
| 605 | 2x |
single.fvar.idx <- which(lavpartable$op == "~~" & |
| 606 | 2x |
lavpartable$lhs == ll & |
| 607 | 2x |
lavpartable$rhs == ll & |
| 608 | 2x |
lavpartable$group == group.values[g]) |
| 609 | 2x |
single.var.idx <- which(lavpartable$op == "~~" & |
| 610 | 2x |
lavpartable$lhs == single.ind & |
| 611 | 2x |
lavpartable$rhs == single.ind & |
| 612 | 2x |
lavpartable$group == group.values[g]) |
| 613 |
# user-defined residual variance |
|
| 614 |
# fixme: we take the first, in case we have multiple matches |
|
| 615 |
# (eg nlevels) |
|
| 616 | 2x |
single.var <- lavpartable$ustart[single.var.idx[1]] |
| 617 | 2x |
if (is.na(single.var)) {
|
| 618 | ! |
single.var <- 1 |
| 619 |
} |
|
| 620 | 2x |
ov.idx <- match(single.ind, ov.names) |
| 621 | 2x |
if (conditional.x && nlevels == 1L) {
|
| 622 | ! |
ov.var <- diag(lavsamplestats@res.cov[[g]])[ov.idx] |
| 623 |
} else {
|
|
| 624 | 2x |
ov.var <- diag(lavsamplestats@cov[[g]])[ov.idx] |
| 625 |
} |
|
| 626 |
# take (1 - (rvar/ov.var) * ov.var |
|
| 627 | 2x |
tmp <- (1 - (single.var / ov.var)) * ov.var |
| 628 |
# just in case |
|
| 629 | 2x |
if (is.na(tmp) || tmp < 0.05) {
|
| 630 | 2x |
tmp <- 0.05 |
| 631 |
} |
|
| 632 | 2x |
start[single.fvar.idx] <- tmp |
| 633 |
} |
|
| 634 |
} |
|
| 635 |
} |
|
| 636 | ||
| 637 |
# 7g) regressions "~" # new in 0.6-10 |
|
| 638 | 114x |
if (length(lv.names) == 0L && nlevels == 1L && !conditional.x) {
|
| 639 |
# observed only |
|
| 640 | 75x |
reg.idx <- which(lavpartable$group == group.values[g] & |
| 641 | 75x |
lavpartable$op == "~") |
| 642 | 75x |
if (length(reg.idx) > 0L) {
|
| 643 | 16x |
eqs.y <- unique(lavpartable$lhs[reg.idx]) |
| 644 | 16x |
ny <- length(eqs.y) |
| 645 | 16x |
for (i in seq_len(ny)) {
|
| 646 | 32x |
y.name <- eqs.y[i] |
| 647 | 32x |
start.idx <- which(lavpartable$group == group.values[g] & |
| 648 | 32x |
lavpartable$op == "~" & |
| 649 | 32x |
lavpartable$lhs == y.name) |
| 650 | 32x |
x.names <- lavpartable$rhs[start.idx] |
| 651 | 32x |
COV <- lavsamplestats@cov[[g]] |
| 652 | 32x |
y.idx <- match(y.name, ov.names) |
| 653 | 32x |
x.idx <- match(x.names, ov.names) |
| 654 | 32x |
S.xx <- COV[x.idx, x.idx, drop = FALSE] |
| 655 | 32x |
S.xy <- COV[x.idx, y.idx, drop = FALSE] |
| 656 |
# regression coefficient(s) |
|
| 657 | 32x |
beta.i <- try(solve(S.xx, S.xy), silent = TRUE) |
| 658 | 32x |
if (inherits(beta.i, "try-error")) {
|
| 659 | ! |
start[start.idx] <- beta.i <- rep(0, length(start.idx)) |
| 660 |
} else {
|
|
| 661 | 32x |
start[start.idx] <- drop(beta.i) |
| 662 |
} |
|
| 663 |
# residual variance |
|
| 664 | 32x |
res.idx <- which(lavpartable$group == group.values[g] & |
| 665 | 32x |
lavpartable$op == "~~" & |
| 666 | 32x |
lavpartable$lhs == y.name & |
| 667 | 32x |
lavpartable$rhs == y.name) |
| 668 | 32x |
res.val <- COV[y.idx, y.idx] - drop(crossprod(beta.i, S.xy)) |
| 669 | 32x |
if (res.val > 0.001 * COV[y.idx, y.idx] && |
| 670 | 32x |
res.val < 0.999 * COV[y.idx, y.idx]) {
|
| 671 | 32x |
start[res.idx] <- res.val |
| 672 |
} else {
|
|
| 673 |
# do nothing (keep what we have) |
|
| 674 |
} |
|
| 675 |
# intercept |
|
| 676 | 32x |
int.idx <- which(lavpartable$group == group.values[g] & |
| 677 | 32x |
lavpartable$op == "~1" & |
| 678 | 32x |
lavpartable$lhs == y.name) |
| 679 | 32x |
if (length(int.idx) > 0L) {
|
| 680 | 26x |
MEAN <- lavsamplestats@mean[[g]] |
| 681 | 26x |
Ybar <- MEAN[y.idx] |
| 682 | 26x |
Xbar <- MEAN[x.idx] |
| 683 | 26x |
int.val <- Ybar - drop(crossprod(beta.i, Xbar)) |
| 684 | 26x |
if (is.finite(int.val)) {
|
| 685 | 26x |
start[int.idx] <- int.val |
| 686 |
} |
|
| 687 |
} |
|
| 688 |
} |
|
| 689 |
} |
|
| 690 |
} |
|
| 691 | ||
| 692 |
# # 8 latent variances (new in 0.6-2) |
|
| 693 |
# lv.names.y <- lav_partable_vnames(lavpartable, "lv.y", group = group.values[g]) |
|
| 694 |
# lv.names.x <- lav_partable_vnames(lavpartable, "lv.x", group = group.values[g]) |
|
| 695 |
# # multilevel? take first level only |
|
| 696 |
# if(is.list(lv.names.y)) {
|
|
| 697 |
# lv.names.y <- unlist(lv.names.y) # for now |
|
| 698 |
# } |
|
| 699 |
# if(is.list(lv.names.x)) {
|
|
| 700 |
# lv.names.x <- unlist(lv.names.x) # for now |
|
| 701 |
# } |
|
| 702 |
# lv.names.xy <- unique(c(lv.names.x, lv.names.y)) |
|
| 703 | ||
| 704 | ||
| 705 |
# if(length(lv.names.xy) > 0L) {
|
|
| 706 |
# free.var.idx <- which(lavpartable$op == "~~" & |
|
| 707 |
# lavpartable$lhs %in% lv.names.xy & |
|
| 708 |
# lavpartable$rhs == lavpartable$lhs & |
|
| 709 |
# lavpartable$group == group.values[g]) |
|
| 710 |
# if(length(free.var.idx) > 0L) {
|
|
| 711 |
# this.lv.names <- lavpartable$lhs[free.var.idx] |
|
| 712 |
# for(v in seq_len(length(free.var.idx))) {
|
|
| 713 |
# # single marker item? |
|
| 714 |
# ind.idx <- which(lavpartable$op == "=~" & |
|
| 715 |
# lavpartable$lhs %in% this.lv.names[v] & |
|
| 716 |
# #lavpartable$rhs %in% ov.names.num & |
|
| 717 |
# lavpartable$free == 0L & |
|
| 718 |
# lavpartable$group == group.values[g]) |
|
| 719 |
# if(length(ind.idx) == 0) {
|
|
| 720 |
# next |
|
| 721 |
# } else if(length(ind.idx) > 1L) {
|
|
| 722 |
# # FIXME! perhaps a random effect? do something clever |
|
| 723 |
# next |
|
| 724 |
# } else if(length(ind.idx) == 1L) {
|
|
| 725 |
# marker.ind <- lavpartable$rhs[ind.idx] |
|
| 726 |
# ov.idx <- match(marker.ind, ov.names) |
|
| 727 |
# if(conditional.x) {
|
|
| 728 |
# ov.var <- diag(lavsamplestats@res.cov[[g]])[ov.idx] |
|
| 729 |
# } else {
|
|
| 730 |
# ov.var <- diag(lavsamplestats@cov[[g]])[ov.idx] |
|
| 731 |
# } |
|
| 732 |
# |
|
| 733 |
# # exogenous? assume rel = 0.50 |
|
| 734 |
# lambda <- lavpartable$ustart[ind.idx] |
|
| 735 |
# tmp <- (0.50 * ov.var)/lambda^2 |
|
| 736 |
# if(this.lv.names[v] %in% lv.names.y) {
|
|
| 737 |
# # endogenous, assume R2 = 0.2 |
|
| 738 |
# tmp <- 0.8 * tmp |
|
| 739 |
# } |
|
| 740 |
# # within variance? |
|
| 741 |
# if(nlevels > 1L && |
|
| 742 |
# lavpartable$level[ free.var.idx[v] ] == 1L) {
|
|
| 743 |
# tmp <- tmp * 0.75 |
|
| 744 |
# } |
|
| 745 |
# # between variance? |
|
| 746 |
# if(nlevels > 1L && |
|
| 747 |
# lavpartable$level[ free.var.idx[v] ] > 1L) {
|
|
| 748 |
# tmp <- tmp * 0.25 |
|
| 749 |
# } |
|
| 750 |
# # just in case |
|
| 751 |
# if(is.na(tmp) || tmp < 0.05) {
|
|
| 752 |
# tmp <- 0.05 |
|
| 753 |
# } |
|
| 754 |
# start[ free.var.idx[v] ] <- tmp |
|
| 755 |
# } |
|
| 756 |
# } # v |
|
| 757 |
# } # free.var.idx |
|
| 758 |
# } # lv var |
|
| 759 | ||
| 760 |
# nlevels > 1L |
|
| 761 | 114x |
if (nlevels > 1L) {
|
| 762 | 8x |
level.values <- lav_partable_level_values(lavpartable) |
| 763 |
# Note: ov.names.x contains all levels within a group! |
|
| 764 | 8x |
if (length(ov.names.x) > 0) {
|
| 765 | ! |
for (l in 1:nlevels) {
|
| 766 |
# block number |
|
| 767 | ! |
block <- (g - 1L) * nlevels + l |
| 768 | ||
| 769 | ! |
this.block.x <- lav_partable_vnames(lavpartable, "ov.x", |
| 770 | ! |
block = block |
| 771 |
) |
|
| 772 | ! |
this.block.ov <- lav_partable_vnames(lavpartable, "ov", |
| 773 | ! |
block = block |
| 774 |
) |
|
| 775 | ! |
if (length(this.block.x) == 0L) {
|
| 776 | ! |
next |
| 777 |
} |
|
| 778 | ||
| 779 |
# var/cov |
|
| 780 | ! |
exo.idx <- which(lavpartable$group == group.values[g] & |
| 781 | ! |
lavpartable$level == level.values[l] & |
| 782 | ! |
lavpartable$op == "~~" & |
| 783 | ! |
lavpartable$lhs %in% this.block.x & |
| 784 | ! |
lavpartable$rhs %in% this.block.x) |
| 785 | ||
| 786 | ! |
if (is.null(lavh1$implied$cov[[1]])) {
|
| 787 | ! |
row.idx <- match(lavpartable$lhs[exo.idx], ov.names) |
| 788 | ! |
col.idx <- match(lavpartable$rhs[exo.idx], ov.names) |
| 789 | ! |
if (l == 1L) {
|
| 790 | ! |
COV <- lavsamplestats@YLp[[g]][[2]]$S.PW.start |
| 791 |
} else {
|
|
| 792 | ! |
COV <- lavsamplestats@YLp[[g]][[l]]$Sigma.B |
| 793 |
} |
|
| 794 |
} else {
|
|
| 795 | ! |
row.idx <- match(lavpartable$lhs[exo.idx], this.block.ov) |
| 796 | ! |
col.idx <- match(lavpartable$rhs[exo.idx], this.block.ov) |
| 797 | ! |
COV <- lavh1$implied$cov[[block]] |
| 798 |
} |
|
| 799 |
# make sure starting values for variances are positive |
|
| 800 | ! |
neg.idx <- which(diag(COV) < 0.001) |
| 801 | ! |
if (length(neg.idx) > 0L) {
|
| 802 | ! |
diag(COV)[neg.idx] <- 0.001 |
| 803 |
} |
|
| 804 | ! |
start[exo.idx] <- COV[cbind(row.idx, col.idx)] |
| 805 | ||
| 806 |
# intercepts |
|
| 807 | ! |
ov.int.idx <- which(lavpartable$group == group.values[g] & |
| 808 | ! |
lavpartable$level == level.values[l] & |
| 809 | ! |
lavpartable$op == "~1" & |
| 810 | ! |
lavpartable$lhs %in% this.block.x) |
| 811 | ||
| 812 | ! |
if (is.null(lavh1$implied$mean[[1]])) {
|
| 813 | ! |
idx <- match(lavpartable$lhs[ov.int.idx], ov.names) |
| 814 | ! |
if (l == 1L) {
|
| 815 | ! |
INT <- lavsamplestats@YLp[[g]][[2]]$Mu.W |
| 816 |
} else {
|
|
| 817 | ! |
INT <- lavsamplestats@YLp[[g]][[l]]$Mu.B.start |
| 818 |
} |
|
| 819 |
} else {
|
|
| 820 | ! |
idx <- match(lavpartable$lhs[ov.int.idx], this.block.ov) |
| 821 | ! |
INT <- lavh1$implied$mean[[block]] |
| 822 |
} |
|
| 823 | ! |
start[ov.int.idx] <- INT[idx] |
| 824 | ||
| 825 |
# new in 0.6-12 |
|
| 826 |
# very special case: conditional.x with a combination of |
|
| 827 |
# splitted-x and regular-x |
|
| 828 |
# here, we must: |
|
| 829 |
# 1) replace var/cov of splitted-x by *residual* varcov |
|
| 830 |
# after regressing out regular-x |
|
| 831 |
# 2) replace means of splitted-x by intercepts |
|
| 832 |
# 3) fill splitted-x ~ regular-x regression coefficients |
|
| 833 | ! |
if (conditional.x) {
|
| 834 | ! |
if (is.null(lavh1$implied$cov[[l]])) {
|
| 835 | ! |
lav_msg_stop(gettext( |
| 836 | ! |
"lavh1 information is needed; please rerun with h1 = TRUE")) |
| 837 |
} |
|
| 838 | ! |
blocks.within.group <- (g - 1L) * nlevels + seq_len(nlevels) |
| 839 | ! |
OTHER.BLOCK.NAMES <- lav_partable_vnames(lavpartable, "ov", |
| 840 | ! |
block = blocks.within.group[-block]) |
| 841 | ! |
ov.names.x.block <- this.block.x |
| 842 | ! |
idx <- which(ov.names.x.block %in% OTHER.BLOCK.NAMES) |
| 843 | ! |
if (length(idx) > 0L) {
|
| 844 | ! |
ov.names.x.block <- ov.names.x.block[-idx] |
| 845 |
} |
|
| 846 | ! |
ov.names.x1 <- this.block.x[!this.block.x %in% ov.names.x.block] |
| 847 | ! |
ov.names.x2 <- ov.names.x.block |
| 848 | ! |
nx1 <- length(ov.names.x1) # splitted x |
| 849 | ! |
nx2 <- length(ov.names.x2) # regular x |
| 850 | ! |
if (nx1 > 0L && nx2 > 0L) {
|
| 851 |
# COV |
|
| 852 | ! |
c1.idx <- match(ov.names.x1, this.block.ov) |
| 853 | ! |
c2.idx <- match(ov.names.x2, this.block.ov) |
| 854 | ||
| 855 | ! |
COV.Y <- COV[c1.idx, c1.idx, drop = FALSE] |
| 856 | ! |
COV.X <- COV[c2.idx, c2.idx, drop = FALSE] |
| 857 | ! |
COV.YX <- COV[c1.idx, c2.idx, drop = FALSE] |
| 858 | ! |
COV.XY <- COV[c2.idx, c1.idx, drop = FALSE] |
| 859 | ! |
COV.XinvYX <- solve(COV.X, COV.XY) |
| 860 | ! |
RES.COV <- COV.Y - COV.YX %*% COV.XinvYX |
| 861 | ||
| 862 | ! |
res.cov.idx <- which(lavpartable$group == group.values[g] & |
| 863 | ! |
lavpartable$level == level.values[l] & |
| 864 | ! |
lavpartable$op == "~~" & |
| 865 | ! |
lavpartable$lhs %in% ov.names.x1 & |
| 866 | ! |
lavpartable$rhs %in% ov.names.x1) |
| 867 | ||
| 868 | ! |
row.idx <- match(lavpartable$lhs[res.cov.idx], ov.names.x1) |
| 869 | ! |
col.idx <- match(lavpartable$rhs[res.cov.idx], ov.names.x1) |
| 870 | ! |
start[res.cov.idx] <- RES.COV[cbind(row.idx, col.idx)] |
| 871 | ||
| 872 |
# INT |
|
| 873 | ! |
INT.Y <- INT[c1.idx] |
| 874 | ! |
INT.X <- INT[c2.idx] |
| 875 | ! |
RES.INT <- INT.Y - t(COV.XinvYX) %*% INT.X |
| 876 | ||
| 877 | ! |
res.int.idx <- which(lavpartable$group == group.values[g] & |
| 878 | ! |
lavpartable$level == level.values[l] & |
| 879 | ! |
lavpartable$op == "~1" & |
| 880 | ! |
lavpartable$lhs %in% ov.names.x1) |
| 881 | ! |
idx <- match(lavpartable$lhs[res.int.idx], ov.names.x1) |
| 882 | ! |
start[res.int.idx] <- RES.INT[idx] |
| 883 | ||
| 884 |
# REG |
|
| 885 | ! |
reg.idx <- which(lavpartable$group == group.values[g] & |
| 886 | ! |
lavpartable$level == level.values[l] & |
| 887 | ! |
lavpartable$op == "~" & |
| 888 | ! |
lavpartable$lhs %in% ov.names.x1 & |
| 889 | ! |
lavpartable$rhs %in% ov.names.x2) |
| 890 | ! |
row.idx <- match(lavpartable$lhs[reg.idx], ov.names.x1) |
| 891 | ! |
col.idx <- match(lavpartable$rhs[reg.idx], ov.names.x2) |
| 892 | ! |
start[reg.idx] <- t(COV.XinvYX)[cbind(row.idx, col.idx)] |
| 893 |
} # special case |
|
| 894 |
} # conditional.x |
|
| 895 |
} # levels |
|
| 896 |
} # fixed.x |
|
| 897 |
} # nlevels > 1L |
|
| 898 |
} # groups |
|
| 899 | ||
| 900 | ||
| 901 | ||
| 902 | ||
| 903 |
# group weights |
|
| 904 | 106x |
group.idx <- which(lavpartable$lhs == "group" & |
| 905 | 106x |
lavpartable$op == "%") |
| 906 | 106x |
if (length(group.idx) > 0L) {
|
| 907 | ! |
ngroups <- length(group.idx) |
| 908 |
# prop <- rep(1/ngroups, ngroups) |
|
| 909 |
# use last group as reference |
|
| 910 |
# start[group.idx] <- log(prop/prop[ngroups]) |
|
| 911 | ||
| 912 |
# poisson version |
|
| 913 | ! |
start[group.idx] <- log(rep(lavsamplestats@ntotal / ngroups, ngroups)) |
| 914 |
} |
|
| 915 | ||
| 916 |
# growth models: |
|
| 917 |
# - compute starting values for mean latent variables |
|
| 918 |
# - compute starting values for variance latent variables |
|
| 919 | 106x |
if (start.initial %in% c("lavaan") &&
|
| 920 | 106x |
model.type == "growth") {
|
| 921 |
### DEBUG ONLY |
|
| 922 |
# lv.var.idx <- which(lavpartable$op == "~~" & |
|
| 923 |
# lavpartable$lhs %in% lv.names & |
|
| 924 |
# lavpartable$lhs == lavpartable$rhs) |
|
| 925 | ||
| 926 |
### DEBUG ONLY |
|
| 927 |
# lv.int.idx <- which(lavpartable$op == "~1" & |
|
| 928 |
# lavpartable$lhs %in% lv.names) |
|
| 929 |
} |
|
| 930 | ||
| 931 |
# adjust if outside bounds -- new in 0.6-6 |
|
| 932 | 106x |
if (!is.null(lavpartable$lower)) {
|
| 933 | 63x |
bad.idx <- which(start < lavpartable$lower) |
| 934 | 63x |
if (length(bad.idx)) {
|
| 935 | 26x |
start[bad.idx] <- lavpartable$lower[bad.idx] |
| 936 |
} |
|
| 937 |
} |
|
| 938 | 106x |
if (!is.null(lavpartable$upper)) {
|
| 939 | 63x |
bad.idx <- which(start > lavpartable$upper) |
| 940 | 63x |
if (length(bad.idx)) {
|
| 941 | 26x |
start[bad.idx] <- lavpartable$upper[bad.idx] |
| 942 |
} |
|
| 943 |
} |
|
| 944 | ||
| 945 | ||
| 946 |
# override if the model syntax contains explicit starting values (free only) |
|
| 947 |
# user.idx <- which(!is.na(lavpartable$ustart) & |
|
| 948 |
# lavpartable$user != 7L) # new in 0.6-7, if rotation and |
|
| 949 |
# # and we change the order of lv's |
|
| 950 | 106x |
user.idx <- which(!is.na(lavpartable$ustart) & lavpartable$free > 0L) |
| 951 | 106x |
start[user.idx] <- lavpartable$ustart[user.idx] |
| 952 | ||
| 953 |
# override if a user list with starting values is provided |
|
| 954 |
# we only look at the 'est' column for now |
|
| 955 | 106x |
if (!is.null(start.user)) {
|
| 956 | ! |
if (is.null(lavpartable$group)) {
|
| 957 | ! |
lavpartable$group <- rep(1L, length(lavpartable$lhs)) |
| 958 |
} |
|
| 959 | ! |
if (is.null(start.user$group)) {
|
| 960 | ! |
start.user$group <- rep(1L, length(start.user$lhs)) |
| 961 |
} |
|
| 962 | ||
| 963 |
# FIXME: avoid for loop!!! |
|
| 964 | ! |
for (i in seq_along(lavpartable$lhs)) {
|
| 965 |
# find corresponding parameters |
|
| 966 | ! |
lhs <- lavpartable$lhs[i] |
| 967 | ! |
op <- lavpartable$op[i] |
| 968 | ! |
rhs <- lavpartable$rhs[i] |
| 969 | ! |
grp <- lavpartable$group[i] |
| 970 | ||
| 971 | ! |
start.user.idx <- which(start.user$lhs == lhs & |
| 972 | ! |
start.user$op == op & |
| 973 | ! |
start.user$rhs == rhs & |
| 974 | ! |
start.user$group == grp) |
| 975 | ! |
if (length(start.user.idx) == 1L && |
| 976 | ! |
is.finite(start.user$est[start.user.idx])) {
|
| 977 | ! |
start[i] <- start.user$est[start.user.idx] |
| 978 |
} |
|
| 979 |
} |
|
| 980 |
} |
|
| 981 | ||
| 982 |
# override fixed values with ustart values |
|
| 983 | 106x |
user.idx <- which(!is.na(lavpartable$ustart) & lavpartable$free == 0L) |
| 984 | 106x |
start[user.idx] <- lavpartable$ustart[user.idx] |
| 985 | ||
| 986 |
# new in 0.6-21 |
|
| 987 |
# if any thresholds, make sure they are in increasing order |
|
| 988 |
# (could be an issue if the first and second were fixed to 0 and 1) |
|
| 989 | 106x |
for (g in 1:ngroups) {
|
| 990 | 114x |
th.idx <- which(lavpartable$group == group.values[g] & |
| 991 | 114x |
lavpartable$op == "|") |
| 992 | 114x |
if (length(th.idx) > 0L) {
|
| 993 |
# for every ov.ord, check if t1 < t2 < t3 < ... |
|
| 994 | 4x |
ov.ord <- unique(lavpartable$lhs[th.idx]) |
| 995 | 4x |
for (oo in ov.ord) {
|
| 996 | 16x |
this.idx <- which(lavpartable$group == group.values[g] & |
| 997 | 16x |
lavpartable$op == "|" & lavpartable$lhs == oo) |
| 998 | 16x |
item.th <- start[this.idx] |
| 999 | 16x |
if (length(item.th) > 1L && !all(diff(item.th) > 0)) {
|
| 1000 | ! |
start[this.idx] <- cumsum(abs(item.th)) |
| 1001 |
} |
|
| 1002 |
} |
|
| 1003 |
} |
|
| 1004 |
} |
|
| 1005 | ||
| 1006 | ||
| 1007 |
# final check: no NaN or other non-finite values |
|
| 1008 | 106x |
bad.idx <- which(!is.finite(start)) |
| 1009 | 106x |
if (length(bad.idx) > 0L) {
|
| 1010 | ! |
cat("starting values:\n")
|
| 1011 | ! |
print(start) |
| 1012 | ! |
lav_msg_warn(gettext( |
| 1013 | ! |
"some starting values are non-finite; replacing them with 0.5; |
| 1014 | ! |
please provide better starting values.")) |
| 1015 | ! |
start[bad.idx] <- 0.5 |
| 1016 |
} |
|
| 1017 | ||
| 1018 | 106x |
if (lav_debug()) {
|
| 1019 | ! |
cat("lavaan DEBUG: lavaanStart\n")
|
| 1020 | ! |
print(start) |
| 1021 |
} |
|
| 1022 | ||
| 1023 | 106x |
start |
| 1024 |
} |
|
| 1025 | ||
| 1026 |
# backwards compatibility |
|
| 1027 |
# StartingValues <- lav_start |
|
| 1028 | ||
| 1029 |
# sanity check: (user-specified) variances smaller than covariances |
|
| 1030 |
# but not for composites, as we have not 'set' their variances yet |
|
| 1031 |
lav_start_check_cov <- function(lavpartable = NULL, start = lavpartable$start) {
|
|
| 1032 | 47x |
nblocks <- lav_partable_nblocks(lavpartable) |
| 1033 | 47x |
block.values <- lav_partable_block_values(lavpartable) |
| 1034 | ||
| 1035 | 47x |
for (g in 1:nblocks) {
|
| 1036 | ||
| 1037 | 56x |
lv.names.c <- lav_partable_vnames(lavpartable, "lv.composite", block = g) |
| 1038 | ||
| 1039 |
# collect all non-zero covariances |
|
| 1040 | 56x |
cov.idx <- which(lavpartable$op == "~~" & |
| 1041 | 56x |
lavpartable$block == block.values[g] & |
| 1042 | 56x |
!lavpartable$lhs %in% lv.names.c & |
| 1043 | 56x |
lavpartable$lhs != lavpartable$rhs & |
| 1044 | 56x |
!lavpartable$exo & |
| 1045 | 56x |
start != 0) |
| 1046 | ||
| 1047 |
# for each covariance, use corresponding variances to standardize; |
|
| 1048 |
# the end result should not exceed abs(1) |
|
| 1049 | 56x |
for (cc in seq_along(cov.idx)) {
|
| 1050 | 6x |
this.cov.idx <- cov.idx[cc] |
| 1051 | ||
| 1052 |
# find corresponding variances |
|
| 1053 | 6x |
var.lhs <- lavpartable$lhs[this.cov.idx] |
| 1054 | 6x |
var.rhs <- lavpartable$rhs[this.cov.idx] |
| 1055 | ||
| 1056 | 6x |
var.lhs.idx <- which(lavpartable$op == "~~" & |
| 1057 | 6x |
lavpartable$block == block.values[g] & |
| 1058 | 6x |
lavpartable$lhs == var.lhs & |
| 1059 | 6x |
lavpartable$lhs == lavpartable$rhs) |
| 1060 | ||
| 1061 | 6x |
var.rhs.idx <- which(lavpartable$op == "~~" & |
| 1062 | 6x |
lavpartable$block == block.values[g] & |
| 1063 | 6x |
lavpartable$lhs == var.rhs & |
| 1064 | 6x |
lavpartable$lhs == lavpartable$rhs) |
| 1065 | ||
| 1066 | 6x |
var.lhs.value <- start[var.lhs.idx] |
| 1067 | 6x |
var.rhs.value <- start[var.rhs.idx] |
| 1068 | ||
| 1069 | 6x |
block.txt <- "" |
| 1070 | 6x |
if (nblocks > 1L) {
|
| 1071 | ! |
block.txt <- paste(" [in block ", g, "]", sep = "")
|
| 1072 |
} |
|
| 1073 | ||
| 1074 |
# check for zero variances |
|
| 1075 | 6x |
if (var.lhs.value == 0 || var.rhs.value == 0) {
|
| 1076 |
# this can only happen if it is user-specified |
|
| 1077 |
# cov.idx free? set it to zero |
|
| 1078 | ! |
if (start[this.cov.idx] == 0) {
|
| 1079 |
# nothing to do |
|
| 1080 | ! |
} else if (lavpartable$free[this.cov.idx] > 0L) {
|
| 1081 | ! |
lav_msg_warn(gettextf( |
| 1082 | ! |
"non-zero covariance element set to zero, due to fixed-to-zero |
| 1083 | ! |
variances variables involved are: %s", var.lhs), var.rhs, |
| 1084 | ! |
block.txt |
| 1085 |
) |
|
| 1086 | ! |
start[this.cov.idx] <- 0 |
| 1087 |
} else {
|
|
| 1088 | ! |
lav_msg_stop(gettextf( |
| 1089 | ! |
"please provide better fixed values for (co)variances; |
| 1090 | ! |
variables involved are: %s ", var.lhs), var.rhs, block.txt |
| 1091 |
) |
|
| 1092 |
} |
|
| 1093 | ! |
next |
| 1094 |
} |
|
| 1095 | ||
| 1096 |
# which one is the smallest? abs() in case of negative variances |
|
| 1097 | 6x |
if (abs(var.lhs.value) < abs(var.rhs.value)) {
|
| 1098 | 4x |
var.min.idx <- var.lhs.idx |
| 1099 | 4x |
var.max.idx <- var.rhs.idx |
| 1100 |
} else {
|
|
| 1101 | 2x |
var.min.idx <- var.rhs.idx |
| 1102 | 2x |
var.max.idx <- var.lhs.idx |
| 1103 |
} |
|
| 1104 | ||
| 1105 |
# check |
|
| 1106 | 6x |
COR <- abs(start[this.cov.idx] / sqrt(var.lhs.value * var.rhs.value)) |
| 1107 | ||
| 1108 |
# NOTE: we treat this as an unconditional COR! |
|
| 1109 | ||
| 1110 | 6x |
if (!is.finite(COR)) {
|
| 1111 |
# force simple values |
|
| 1112 | ! |
lav_msg_warn(gettextf( |
| 1113 | ! |
"starting values imply NaN for a correlation value; variables |
| 1114 | ! |
involved are: %s", var.lhs), var.rhs, block.txt |
| 1115 |
) |
|
| 1116 | ! |
start[var.lhs.idx] <- 1 |
| 1117 | ! |
start[var.rhs.idx] <- 1 |
| 1118 | ! |
start[this.cov.idx] <- 0 |
| 1119 | 6x |
} else if (COR > 1) {
|
| 1120 | ! |
txt <- gettextf( |
| 1121 | ! |
"starting values imply a correlation larger than 1; variables |
| 1122 | ! |
involved are: %1$s %2$s %3$s", var.lhs, var.rhs, block.txt) |
| 1123 | ||
| 1124 |
# three ways to fix it: rescale cov12, var1 or var2 |
|
| 1125 | ||
| 1126 |
# we prefer a free parameter, and not user-specified |
|
| 1127 | ! |
if (lavpartable$free[this.cov.idx] > 0L && |
| 1128 | ! |
is.na(lavpartable$ustart[this.cov.idx])) {
|
| 1129 | ! |
lav_msg_warn(gettext(txt)) |
| 1130 | ! |
start[this.cov.idx] <- start[this.cov.idx] / (COR * 1.1) |
| 1131 | ! |
} else if (lavpartable$free[var.min.idx] > 0L && |
| 1132 | ! |
is.na(lavpartable$ustart[var.min.idx])) {
|
| 1133 | ! |
lav_msg_warn(gettext(txt)) |
| 1134 | ! |
start[var.min.idx] <- start[var.min.idx] * (COR * 1.1)^2 |
| 1135 | ! |
} else if (lavpartable$free[var.max.idx] > 0L && |
| 1136 | ! |
is.na(lavpartable$ustart[var.max.idx])) {
|
| 1137 | ! |
lav_msg_warn(gettext(txt)) |
| 1138 | ! |
start[var.max.idx] <- start[var.max.idx] * (COR * 1.1)^2 |
| 1139 | ||
| 1140 |
# not found? try just a free parameter |
|
| 1141 | ! |
} else if (lavpartable$free[this.cov.idx] > 0L) {
|
| 1142 | ! |
lav_msg_warn(gettext(txt)) |
| 1143 | ! |
start[this.cov.idx] <- start[this.cov.idx] / (COR * 1.1) |
| 1144 | ! |
} else if (lavpartable$free[var.min.idx] > 0L) {
|
| 1145 | ! |
lav_msg_warn(gettext(txt)) |
| 1146 | ! |
start[var.min.idx] <- start[var.min.idx] * (COR * 1.1)^2 |
| 1147 | ! |
} else if (lavpartable$free[var.max.idx] > 0L) {
|
| 1148 | ! |
lav_msg_warn(gettext(txt)) |
| 1149 | ! |
start[var.max.idx] <- start[var.max.idx] * (COR * 1.1)^2 |
| 1150 | ||
| 1151 |
# nothing? abort or warn (and fail later...): warn |
|
| 1152 |
} else {
|
|
| 1153 | ! |
lav_msg_warn(gettext(txt)) |
| 1154 |
# lav_msg_stop(gettextf( |
|
| 1155 |
# "please provide better fixed values for (co)variances; |
|
| 1156 |
# variables involved are: %s ", var.lhs), var.rhs, block.txt) |
|
| 1157 |
} |
|
| 1158 |
} # COR > 1 |
|
| 1159 |
} # cov.idx |
|
| 1160 |
} |
|
| 1161 | 47x |
start |
| 1162 |
} |
| 1 |
# collection of functions that deal with rotation matrices |
|
| 2 |
# YR 3 April 2019 -- initial version |
|
| 3 |
# YR 6 Jan 2023: add promax |
|
| 4 |
# YR 30 Jan 2024: orthogonal rotation matrix now reaches the full space |
|
| 5 | ||
| 6 |
# generate random orthogonal rotation matrix |
|
| 7 |
# |
|
| 8 |
# reference for the orthogonal case: |
|
| 9 |
# |
|
| 10 |
# Stewart, G. W. (1980). The Efficient Generation of Random Orthogonal Matrices |
|
| 11 |
# with an Application to Condition Estimators. SIAM Journal on Numerical |
|
| 12 |
# Analysis, 17(3), 403-409. http://www.jstor.org/stable/2156882 |
|
| 13 |
# |
|
| 14 |
lav_matrix_rotate_gen <- function(M = 10L, orthogonal = TRUE) {
|
|
| 15 |
# catch M=1 |
|
| 16 | 90x |
if (M == 1L) {
|
| 17 | ! |
return(matrix(1, 1, 1)) |
| 18 |
} |
|
| 19 | ||
| 20 | 90x |
if (orthogonal) {
|
| 21 |
# create random normal matrix |
|
| 22 | 90x |
tmp <- matrix(rnorm(M * M), nrow = M, ncol = M) |
| 23 |
# use QR decomposition |
|
| 24 | 90x |
qr.out <- qr(tmp) |
| 25 | 90x |
Q <- qr.Q(qr.out) |
| 26 | 90x |
R <- qr.R(qr.out) |
| 27 |
# ... "normalized so that the diagonal elements of R are positive" |
|
| 28 | 90x |
sign.diag.r <- sign(diag(R)) |
| 29 | 90x |
out <- Q * rep(sign.diag.r, each = M) |
| 30 |
} else {
|
|
| 31 |
# just normalize *columns* of tmp -> crossprod(out) has 1 on diagonal |
|
| 32 | ! |
out <- t(t(tmp) / sqrt(diag(crossprod(tmp)))) |
| 33 |
} |
|
| 34 | ||
| 35 | 90x |
out |
| 36 |
} |
|
| 37 | ||
| 38 |
# check if ROT is an orthogonal matrix if orthogonal = TRUE, or normal if |
|
| 39 |
# orthogonal = FALSE |
|
| 40 |
lav_matrix_rotate_check <- function(ROT = NULL, orthogonal = TRUE, |
|
| 41 |
tolerance = sqrt(.Machine$double.eps)) {
|
|
| 42 |
# we assume ROT is a matrix |
|
| 43 | ! |
M <- nrow(ROT) |
| 44 | ||
| 45 |
# crossprod |
|
| 46 | ! |
RR <- crossprod(ROT) |
| 47 | ||
| 48 |
# target |
|
| 49 | ! |
if (orthogonal) {
|
| 50 |
# ROT^T %*% ROT = I |
|
| 51 | ! |
target <- diag(M) |
| 52 |
} else {
|
|
| 53 |
# diagonal should be 1 |
|
| 54 | ! |
target <- RR |
| 55 | ! |
diag(target) <- 1 |
| 56 |
} |
|
| 57 | ||
| 58 |
# compare for near-equality |
|
| 59 | ! |
res <- all.equal(target = target, current = RR, tolerance = tolerance) |
| 60 | ||
| 61 |
# return TRUE or FALSE |
|
| 62 | ! |
if (is.logical(res) && res) {
|
| 63 | ! |
out <- TRUE |
| 64 |
} else {
|
|
| 65 | ! |
out <- FALSE |
| 66 |
} |
|
| 67 | ||
| 68 | ! |
out |
| 69 |
} |
|
| 70 | ||
| 71 |
# get weights vector needed to weight the rows using Kaiser normalization |
|
| 72 |
lav_matrix_rotate_kaiser_weights <- function(A = NULL) {
|
|
| 73 | ! |
normalize <- 1 / sqrt(rowSums(A * A)) |
| 74 | ! |
idxZero <- which(normalize == 0) |
| 75 |
# catch rows with all zero (thanks to Coen Bernaards for suggesting this) |
|
| 76 | ! |
normalize[idxZero] <- normalize[idxZero] + .Machine$double.eps |
| 77 | ! |
normalize |
| 78 |
} |
|
| 79 | ||
| 80 |
# get weights vector needed to weight the rows using Cureton & Mulaik (1975) |
|
| 81 |
# standardization |
|
| 82 |
# see also Browne (2001) page 128-129 |
|
| 83 |
# |
|
| 84 |
# Note: the 'final' weights are mutliplied by the Kaiser weights (see CEFA) |
|
| 85 |
# |
|
| 86 |
lav_matrix_rotate_cm_weights <- function(A = NULL) {
|
|
| 87 | ! |
P <- nrow(A) |
| 88 | ! |
M <- ncol(A) |
| 89 | ||
| 90 |
# first principal component of AA' |
|
| 91 | ! |
A.eigen <- eigen(tcrossprod(A), symmetric = TRUE) |
| 92 | ! |
a <- A.eigen$vectors[, 1] * sqrt(A.eigen$values[1]) |
| 93 | ||
| 94 | ! |
Kaiser.weights <- 1 / sqrt(rowSums(A * A)) |
| 95 | ! |
a.star <- abs(a * Kaiser.weights) # always between 0 and 1 |
| 96 | ||
| 97 | ! |
m.sqrt.inv <- 1 / sqrt(M) |
| 98 | ! |
acos.m.sqrt.inv <- acos(m.sqrt.inv) |
| 99 | ||
| 100 | ! |
delta <- numeric(P) |
| 101 | ! |
delta[a.star < m.sqrt.inv] <- pi / 2 |
| 102 | ||
| 103 | ! |
tmp <- (acos.m.sqrt.inv - acos(a.star)) / (acos.m.sqrt.inv - delta) * (pi / 2) |
| 104 | ||
| 105 |
# add constant (see Cureton & Mulaik, 1975, page 187) |
|
| 106 | ! |
cm <- cos(tmp) * cos(tmp) + 0.001 |
| 107 | ||
| 108 |
# final weights = weighted by Kaiser weights |
|
| 109 | ! |
cm * Kaiser.weights |
| 110 |
} |
|
| 111 | ||
| 112 |
# taken from the stats package, but skipping varimax (already done): |
|
| 113 |
lav_matrix_rotate_promax <- function(x, m = 4, varimax.ROT = NULL) {
|
|
| 114 |
# this is based on promax() from factanal.R in /src/library/stats/R |
|
| 115 | ||
| 116 |
# 1. create 'ideal' pattern matrix |
|
| 117 | ! |
Q <- x * abs(x)^(m - 1) |
| 118 | ||
| 119 |
# 2. regress x on Q to obtain 'rotation matrix' (same as 'procrustes') |
|
| 120 | ! |
U <- lm.fit(x, Q)$coefficients |
| 121 | ||
| 122 |
# 3. rescale so that solve(crossprod(U)) has 1 on the diagonal |
|
| 123 | ||
| 124 | ! |
d <- diag(solve(t(U) %*% U)) |
| 125 | ! |
U <- U %*% diag(sqrt(d)) |
| 126 | ! |
dimnames(U) <- NULL |
| 127 | ||
| 128 |
# 4. create rotated factor matrix |
|
| 129 | ! |
z <- x %*% U |
| 130 | ||
| 131 |
# 5. update rotation amtrix |
|
| 132 | ! |
U <- varimax.ROT %*% U # here we plugin the rotation matrix from varimax |
| 133 | ||
| 134 | ! |
list(loadings = z, rotmat = U) |
| 135 |
} |
| 1 |
# utility functions needed to compute various (robust) fit measures: |
|
| 2 |
# |
|
| 3 |
# - lav_fit_catml_dwls (for 'robust' RMSEA/CFI if data is cateogrical) |
|
| 4 |
# - lav_fit_fiml_corrected (correct RMSEA/CFI if data is incomplete) |
|
| 5 | ||
| 6 |
# compute scaling-factor (c.hat3) for fit.dwls, using fit.catml ingredients |
|
| 7 |
# see: |
|
| 8 |
# Savalei, V. (2021) Improving Fit Indices In SEM with categorical data. |
|
| 9 |
# Multivariate Behavioral Research, 56(3), 390-407. |
|
| 10 |
# |
|
| 11 | ||
| 12 |
# YR Dec 2022: first version |
|
| 13 |
# YR Jan 2023: catml_dwls should check if the input 'correlation' matrix |
|
| 14 |
# is positive-definite (or not) |
|
| 15 | ||
| 16 |
lav_fit_catml_dwls <- function(lavobject, check.pd = TRUE) {
|
|
| 17 |
# empty list |
|
| 18 | 4x |
empty.list <- list( |
| 19 | 4x |
XX3 = as.numeric(NA), df3 = as.numeric(NA), |
| 20 | 4x |
c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA), |
| 21 | 4x |
XX3.null = as.numeric(NA), df3.null = as.numeric(NA), |
| 22 | 4x |
c.hat3.null = as.numeric(NA) |
| 23 |
) |
|
| 24 | ||
| 25 |
# limitations |
|
| 26 | 4x |
if (!lavobject@Model@categorical || |
| 27 | 4x |
lavobject@Options$conditional.x || |
| 28 | 4x |
length(unlist(lavobject@pta$vnames$ov.num)) > 0L) {
|
| 29 | 4x |
return(empty.list) |
| 30 |
} else {
|
|
| 31 | ! |
lavdata <- lavobject@Data |
| 32 | ! |
lavsamplestats <- lavobject@SampleStats |
| 33 |
} |
|
| 34 | ||
| 35 |
# check if input matrix (or matrices) are all positive definite |
|
| 36 |
# (perhaps later, we can rely on 'smoothing', but not for now |
|
| 37 | ! |
pd.flag <- TRUE |
| 38 | ! |
if (check.pd) {
|
| 39 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 40 | ! |
COR <- lavsamplestats@cov[[g]] |
| 41 | ! |
ev <- eigen(COR, symmetric = TRUE, only.values = TRUE)$values |
| 42 | ! |
if (any(ev < .Machine$double.eps^(1 / 2))) {
|
| 43 |
# non-pd! |
|
| 44 | ! |
pd.flag <- FALSE |
| 45 |
# should we give a warning here? (not for now) |
|
| 46 |
# warning("lavaan WARNING: robust RMSEA/CFI could not be computed because the input correlation matrix is not positive-definite")
|
|
| 47 |
# what should we do? return NA (for now) |
|
| 48 | ! |
return(empty.list) |
| 49 |
} |
|
| 50 |
} |
|
| 51 |
} |
|
| 52 | ||
| 53 |
# 'refit' using estimator = "catML" |
|
| 54 | ! |
fit.catml <- try(lav_object_catml(lavobject), silent = TRUE) |
| 55 | ! |
if (inherits(fit.catml, "try-error")) {
|
| 56 | ! |
return(empty.list) |
| 57 |
} |
|
| 58 | ||
| 59 | ! |
XX3 <- fit.catml@test[[1]]$stat |
| 60 | ! |
df3 <- fit.catml@test[[1]]$df |
| 61 | ||
| 62 | ||
| 63 |
# compute 'k' |
|
| 64 | ! |
V <- lavTech(fit.catml, "wls.v") # NT-ML weight matrix |
| 65 | ||
| 66 | ! |
W.dwls <- lavTech(lavobject, "wls.v") # DWLS weight matrix |
| 67 | ! |
Gamma <- lavTech(lavobject, "gamma") # acov of polychorics |
| 68 | ! |
Delta <- lavTech(lavobject, "delta") |
| 69 | ! |
E.inv <- lavTech(lavobject, "inverted.information") |
| 70 | ||
| 71 | ! |
fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal |
| 72 | ||
| 73 |
# Fixme: as we only need the trace, perhaps we could do this |
|
| 74 |
# group-specific? (see lav_test_satorra_bentler_trace_original) |
|
| 75 | ! |
V.g <- V |
| 76 | ! |
W.dwls.g <- W.dwls |
| 77 | ! |
Gamma.f <- Gamma |
| 78 | ! |
Delta.g <- Delta |
| 79 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 80 | ! |
ntotal <- nrow(Gamma[[g]]) |
| 81 | ! |
nvar <- lavobject@Model@nvar[[g]] |
| 82 | ! |
pstar <- nvar * (nvar - 1) / 2 |
| 83 | ! |
rm.idx <- seq_len(ntotal - pstar) |
| 84 | ||
| 85 |
# reduce |
|
| 86 | ! |
Delta.g[[g]] <- Delta[[g]][-rm.idx, , drop = FALSE] |
| 87 |
# reduce and weight |
|
| 88 | ! |
W.dwls.g[[g]] <- fg[g] * W.dwls[[g]][-rm.idx, -rm.idx] |
| 89 | ! |
V.g[[g]] <- fg[g] * V[[g]] # should already have the right dims |
| 90 | ! |
Gamma.f[[g]] <- 1 / fg[g] * Gamma[[g]][-rm.idx, -rm.idx] |
| 91 |
} |
|
| 92 |
# create 'big' matrices |
|
| 93 | ! |
W.dwls.all <- lav_matrix_bdiag(W.dwls.g) |
| 94 | ! |
V.all <- lav_matrix_bdiag(V.g) |
| 95 | ! |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 96 | ! |
Delta.all <- do.call("rbind", Delta.g)
|
| 97 | ||
| 98 |
# compute trace |
|
| 99 | ! |
WiU.all <- diag(nrow(W.dwls.all)) - Delta.all %*% E.inv %*% t(Delta.all) %*% W.dwls.all |
| 100 | ! |
ks <- sum(diag(t(WiU.all) %*% V.all %*% WiU.all %*% Gamma.all)) |
| 101 | ||
| 102 |
# convert to lavaan 'scaling.factor' |
|
| 103 | ! |
c.hat3 <- ks / df3 |
| 104 | ! |
XX3.scaled <- XX3 / c.hat3 |
| 105 | ||
| 106 |
# baseline model |
|
| 107 | ! |
XX3.null <- fit.catml@baseline$test[[1]]$stat |
| 108 | ! |
if (is.null(XX3.null)) {
|
| 109 | ! |
XX3.null <- as.numeric(NA) |
| 110 | ! |
df3.null <- as.numeric(NA) |
| 111 | ! |
kbs <- as.numeric(NA) |
| 112 | ! |
c.hat3.null <- as.numeric(NA) |
| 113 |
} else {
|
|
| 114 | ! |
df3.null <- fit.catml@baseline$test[[1]]$df |
| 115 | ! |
kbs <- sum(diag(Gamma.all)) |
| 116 | ! |
c.hat3.null <- kbs / df3.null |
| 117 |
} |
|
| 118 | ||
| 119 |
# return values |
|
| 120 | ! |
list( |
| 121 | ! |
XX3 = XX3, df3 = df3, c.hat3 = c.hat3, XX3.scaled = XX3.scaled, |
| 122 | ! |
XX3.null = XX3.null, df3.null = df3.null, c.hat3.null = c.hat3.null |
| 123 |
) |
|
| 124 |
} |
|
| 125 | ||
| 126 | ||
| 127 |
# compute ingredients to compute FIML-Corrected RMSEA/CFI |
|
| 128 |
# see: |
|
| 129 |
# Zhang X, Savalei V. (2022). New computations for RMSEA and CFI |
|
| 130 |
# following FIML and TS estimation with missing data. Psychological Methods. |
|
| 131 | ||
| 132 |
lav_fit_fiml_corrected <- function(lavobject, baseline.model, |
|
| 133 |
version = "V3") {
|
|
| 134 | 16x |
version <- toupper(version) |
| 135 | 16x |
if (!version %in% c("V3", "V6")) {
|
| 136 | ! |
lav_msg_stop(gettext("only FIML-C(V3) and FIML-C(V6) are available."))
|
| 137 |
} |
|
| 138 | ||
| 139 |
# empty list |
|
| 140 | 16x |
empty.list <- list( |
| 141 | 16x |
XX3 = as.numeric(NA), df3 = as.numeric(NA), |
| 142 | 16x |
c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA), |
| 143 | 16x |
XX3.null = as.numeric(NA), df3.null = as.numeric(NA), |
| 144 | 16x |
c.hat3.null = as.numeric(NA) |
| 145 |
) |
|
| 146 | ||
| 147 |
# limitations |
|
| 148 | 16x |
if (lavobject@Options$conditional.x || |
| 149 | 16x |
lavobject@Data@nlevels > 1L || |
| 150 | 16x |
is.null(lavobject@h1$implied$cov[[1]])) {
|
| 151 | ! |
return(empty.list) |
| 152 |
} else {
|
|
| 153 | 16x |
lavdata <- lavobject@Data |
| 154 | 16x |
lavsamplestats <- lavobject@SampleStats |
| 155 | ||
| 156 | 16x |
h1 <- lavTech(lavobject, "h1", add.labels = TRUE) |
| 157 | 16x |
COV.tilde <- lapply(h1, "[[", "cov") |
| 158 | 16x |
MEAN.tilde <- lapply(h1, "[[", "mean") |
| 159 | 16x |
sample.nobs <- unlist(lavsamplestats@nobs) |
| 160 |
} |
|
| 161 | ||
| 162 |
# 'refit' using 'tilde' (=EM/saturated) sample statistics |
|
| 163 | 16x |
fit.tilde <- try(lavaan( |
| 164 | 16x |
model = parTable(lavobject), |
| 165 | 16x |
sample.cov = COV.tilde, |
| 166 | 16x |
sample.mean = MEAN.tilde, |
| 167 | 16x |
sample.nobs = sample.nobs, |
| 168 | 16x |
sample.cov.rescale = FALSE, |
| 169 | 16x |
information = "observed", |
| 170 | 16x |
optim.method = "none", |
| 171 | 16x |
se = "none", |
| 172 | 16x |
test = "standard", |
| 173 | 16x |
baseline = FALSE, |
| 174 | 16x |
check.post = FALSE |
| 175 | 16x |
), silent = TRUE) |
| 176 | 16x |
if (inherits(fit.tilde, "try-error")) {
|
| 177 | ! |
return(empty.list) |
| 178 |
} |
|
| 179 | ||
| 180 | 16x |
XX3 <- fit.tilde@test[[1]]$stat |
| 181 | 16x |
df3 <- fit.tilde@test[[1]]$df |
| 182 | ||
| 183 |
# compute 'k' |
|
| 184 | ||
| 185 |
# V3/V6: always use h1.information = "unstructured"!! |
|
| 186 | 16x |
lavobject@Options$h1.information <- c("unstructured", "unstructured")
|
| 187 | 16x |
lavobject@Options$observed.information <- c("h1", "h1")
|
| 188 | 16x |
fit.tilde@Options$h1.information <- c("unstructured", "unstructured")
|
| 189 | 16x |
fit.tilde@Options$observed.information <- c("h1", "h1")
|
| 190 | ||
| 191 | 16x |
Wm <- Wm.g <- lav_model_h1_information_observed(lavobject) |
| 192 | 16x |
Wc <- Wc.g <- lav_model_h1_information_observed(fit.tilde) |
| 193 | ||
| 194 | 16x |
if (version == "V3") {
|
| 195 | 4x |
Jm <- Jm.g <- lav_model_h1_information_firstorder(lavobject) |
| 196 | 4x |
Gamma.f <- vector("list", length = lavdata@ngroups)
|
| 197 |
} |
|
| 198 | 16x |
Delta <- lavTech(lavobject, "delta") |
| 199 | 16x |
E.inv <- lavTech(lavobject, "inverted.information") |
| 200 | 16x |
Wmi <- Wmi.g <- try(lapply(Wm, lav_matrix_symmetric_inverse), |
| 201 | 16x |
silent = TRUE |
| 202 |
) |
|
| 203 | 16x |
if (inherits(Wmi, "try-error")) {
|
| 204 | ! |
return(empty.list) |
| 205 |
} |
|
| 206 | ||
| 207 | 16x |
fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal |
| 208 |
# Fixme: as we only need the trace, perhaps we could do this |
|
| 209 |
# group-specific? (see lav_test_satorra_bentler_trace_original) |
|
| 210 | 16x |
for (g in seq_len(lavdata@ngroups)) {
|
| 211 |
# group weight |
|
| 212 | 16x |
Wc.g[[g]] <- fg[g] * Wc[[g]] |
| 213 | 16x |
Wm.g[[g]] <- fg[g] * Wm[[g]] |
| 214 | 16x |
Wmi.g[[g]] <- 1 / fg[g] * Wmi[[g]] |
| 215 | ||
| 216 |
# Gamma |
|
| 217 | 16x |
if (version == "V3") {
|
| 218 | 4x |
Jm.g[[g]] <- fg[g] * Jm[[g]] |
| 219 | 4x |
Gamma.g <- Wmi[[g]] %*% Jm[[g]] %*% Wmi[[g]] |
| 220 | 4x |
Gamma.f[[g]] <- 1 / fg[g] * Gamma.g |
| 221 |
} |
|
| 222 |
} |
|
| 223 |
# create 'big' matrices |
|
| 224 | 16x |
Wc.all <- lav_matrix_bdiag(Wc.g) |
| 225 | 16x |
Wm.all <- lav_matrix_bdiag(Wm.g) |
| 226 | 16x |
Wmi.all <- lav_matrix_bdiag(Wmi.g) |
| 227 | 16x |
Delta.all <- do.call("rbind", Delta)
|
| 228 | ||
| 229 | 16x |
E.comp <- t(Delta.all) %*% Wc.all %*% Delta.all # VS: or grab from fit.tilde, with observed.info="h1" |
| 230 | ||
| 231 | ||
| 232 |
# compute trace |
|
| 233 | 16x |
if (version == "V3") {
|
| 234 | 4x |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 235 |
# VS: Simplification of k.fimlc to minimize matrix multiplication of big matrices |
|
| 236 | 4x |
Jm.all <- lav_matrix_bdiag(Jm.g) |
| 237 | ||
| 238 |
# VS: tr11 is also used for baseline |
|
| 239 |
# VS: tr(AB) = sum(A*t(B)) is more efficient |
|
| 240 | ||
| 241 | 4x |
tr11 <- sum(Wc.all * Gamma.all) |
| 242 | 4x |
tr12 <- sum((t(Delta.all) %*% Jm.all %*% Wmi.all %*% Wc.all %*% Delta.all) * E.inv) |
| 243 | 4x |
tr22 <- sum((t(Delta.all) %*% Jm.all %*% Delta.all %*% E.inv) * t(t(Delta.all) %*% Wc.all %*% Delta.all %*% E.inv)) |
| 244 | ||
| 245 | 4x |
k.fimlc <- tr11 - 2 * tr12 + tr22 |
| 246 |
} else {
|
|
| 247 |
# V6 |
|
| 248 | 12x |
tr1 <- sum(Wc.all * Wmi.all) |
| 249 | 12x |
k.fimlc <- tr1 - sum(E.comp * E.inv) |
| 250 |
} |
|
| 251 | ||
| 252 |
# convert to lavaan 'scaling.factor' |
|
| 253 | 16x |
c.hat3 <- k.fimlc / df3 |
| 254 | 16x |
XX3.scaled <- XX3 / c.hat3 |
| 255 | ||
| 256 |
# collect temp results |
|
| 257 | 16x |
out <- list( |
| 258 | 16x |
XX3 = XX3, df3 = df3, |
| 259 | 16x |
c.hat3 = c.hat3, XX3.scaled = XX3.scaled, |
| 260 | 16x |
XX3.null = as.numeric(NA), df3.null = as.numeric(NA), |
| 261 | 16x |
c.hat3.null = as.numeric(NA) |
| 262 |
) |
|
| 263 | ||
| 264 |
# baseline model |
|
| 265 | 16x |
if (!is.null(baseline.model)) {
|
| 266 | ! |
fitB <- baseline.model |
| 267 |
} else {
|
|
| 268 | 16x |
fitB <- try(lav_object_independence(lavobject), silent = TRUE) |
| 269 |
} |
|
| 270 | ||
| 271 | 16x |
if (inherits(fitB, "try-error")) {
|
| 272 | ! |
return(out) |
| 273 |
} |
|
| 274 | ||
| 275 |
# 'refit' using 'tilde' (=EM/saturated) sample statistics |
|
| 276 | 16x |
fitB.tilde <- try(lavaan( |
| 277 | 16x |
model = parTable(fitB), |
| 278 | 16x |
sample.cov = COV.tilde, |
| 279 | 16x |
sample.mean = MEAN.tilde, |
| 280 | 16x |
sample.nobs = sample.nobs, |
| 281 | 16x |
sample.cov.rescale = FALSE, |
| 282 | 16x |
information = "observed", |
| 283 | 16x |
optim.method = "none", |
| 284 | 16x |
se = "none", |
| 285 | 16x |
test = "standard", |
| 286 | 16x |
baseline = FALSE, |
| 287 | 16x |
check.post = FALSE |
| 288 | 16x |
), silent = TRUE) |
| 289 | 16x |
if (inherits(fitB.tilde, "try-error")) {
|
| 290 | ! |
return(out) |
| 291 |
} |
|
| 292 | ||
| 293 | 16x |
XX3.null <- fitB.tilde@test[[1]]$stat |
| 294 | 16x |
df3.null <- fitB.tilde@test[[1]]$df |
| 295 | ||
| 296 | 16x |
fitB@Options$h1.information <- c("unstructured", "unstructured")
|
| 297 | 16x |
fitB@Options$observed.information <- c("h1", "h1")
|
| 298 | 16x |
fitB.tilde@Options$h1.information <- c("unstructured", "unstructured")
|
| 299 | 16x |
fitB.tilde@Options$observed.information <- c("h1", "h1")
|
| 300 | ||
| 301 | 16x |
E.invB <- lavTech(fitB, "inverted.information") |
| 302 | 16x |
DeltaB <- lavTech(fitB, "Delta") |
| 303 | 16x |
DeltaB.all <- do.call("rbind", DeltaB)
|
| 304 | ||
| 305 | 16x |
E.compB <- t(DeltaB.all) %*% Wc.all %*% DeltaB.all # or grab from fitB.tilde |
| 306 | ||
| 307 |
# V3 or V6? |
|
| 308 | 16x |
if (version == "V3") {
|
| 309 | 4x |
tr12B <- sum((t(DeltaB.all) %*% Jm.all %*% Wmi.all %*% Wc.all %*% DeltaB.all) * E.invB) |
| 310 | 4x |
tr22B <- sum((t(DeltaB.all) %*% Jm.all %*% DeltaB.all %*% E.invB) * t(t(DeltaB.all) %*% Wc.all %*% DeltaB.all %*% E.invB)) |
| 311 | 4x |
kb.fimlc <- tr11 - 2 * tr12B + tr22B |
| 312 |
} else {
|
|
| 313 |
# V6 |
|
| 314 | 12x |
kb.fimlc <- tr1 - sum(E.compB * E.invB) |
| 315 |
} |
|
| 316 | ||
| 317 |
# convert to lavaan 'scaling.factor' |
|
| 318 | 16x |
c.hat3.null <- kb.fimlc / df3.null |
| 319 | ||
| 320 |
# return values |
|
| 321 | 16x |
list( |
| 322 | 16x |
XX3 = XX3, df3 = df3, c.hat3 = c.hat3, XX3.scaled = XX3.scaled, |
| 323 | 16x |
XX3.null = XX3.null, df3.null = df3.null, c.hat3.null = c.hat3.null |
| 324 |
) |
|
| 325 |
} |
| 1 |
# overview NLMINB (default) versus CONSTR (=constrained optimization) |
|
| 2 | ||
| 3 |
# | cin.simple | nonlinear | no cin |
|
| 4 |
# ---------------------------------------------------------- |
|
| 5 |
# eq.constraints (linear) | CONSTR | CONSTR | NLMINB |
|
| 6 |
# ceq.nonlinear | CONSTR | CONSTR | CONSTR |
|
| 7 |
# ceq.simple | NLMINB | CONSTR | NLMINB |
|
| 8 |
# no ceq | NLMINB | CONSTR | NLMINB |
|
| 9 | ||
| 10 | ||
| 11 | ||
| 12 |
# model estimation |
|
| 13 |
lav_model_estimate <- function(lavmodel = NULL, |
|
| 14 |
lavpartable = NULL, # for parscale = "stand" |
|
| 15 |
lavh1 = NULL, # for multilevel + parsc |
|
| 16 |
lavsamplestats = NULL, |
|
| 17 |
lavdata = NULL, |
|
| 18 |
lavoptions = NULL, |
|
| 19 |
lavcache = list(), |
|
| 20 |
start = "model", |
|
| 21 |
do.fit = TRUE) {
|
|
| 22 | 142x |
lavpartable <- lav_partable_set_cache(lavpartable) |
| 23 | 142x |
estimator <- lavoptions$estimator |
| 24 | 142x |
verbose <- lav_verbose() |
| 25 | 142x |
debug <- lav_debug() |
| 26 | 142x |
ngroups <- lavsamplestats@ngroups |
| 27 | ||
| 28 | 142x |
if (lavsamplestats@missing.flag || estimator == "PML" || |
| 29 | 142x |
lavdata@nlevels > 1L) {
|
| 30 | 36x |
group.weight <- FALSE |
| 31 |
} else {
|
|
| 32 | 106x |
group.weight <- TRUE |
| 33 |
} |
|
| 34 | ||
| 35 |
# backwards compatibility < 0.6-11 |
|
| 36 | 142x |
if (is.null(lavoptions$optim.partrace)) {
|
| 37 | ! |
lavoptions$optim.partrace <- FALSE |
| 38 |
} |
|
| 39 | ||
| 40 | 142x |
if (lavoptions$optim.partrace) {
|
| 41 |
# fx + parameter values |
|
| 42 | ! |
PENV <- new.env() |
| 43 | ! |
PENV$PARTRACE <- matrix(NA, nrow = 0, ncol = lavmodel@nx.free + 1L) |
| 44 |
} |
|
| 45 | ||
| 46 |
# starting values (ignoring equality constraints) |
|
| 47 | 142x |
x.unpack <- lav_model_get_parameters(lavmodel) |
| 48 | ||
| 49 |
# override? use simple instead? (new in 0.6-7) |
|
| 50 | 142x |
if (start == "simple") {
|
| 51 | 2x |
START <- numeric(length(lavpartable$lhs)) |
| 52 |
# set loadings to 0.7 |
|
| 53 | 2x |
loadings.idx <- which(lavpartable$free > 0L & |
| 54 | 2x |
lavpartable$op == "=~") |
| 55 | 2x |
if (length(loadings.idx) > 0L) {
|
| 56 | 2x |
START[loadings.idx] <- 0.7 |
| 57 |
} |
|
| 58 |
# set (only) variances to 1 |
|
| 59 | 2x |
var.idx <- which(lavpartable$free > 0L & |
| 60 | 2x |
lavpartable$op == "~~" & |
| 61 | 2x |
lavpartable$lhs == lavpartable$rhs) |
| 62 | 2x |
if (length(var.idx) > 0L) {
|
| 63 | 2x |
START[var.idx] <- 1 |
| 64 |
} |
|
| 65 | ||
| 66 | 2x |
if (lavmodel@ceq.simple.only) {
|
| 67 | ! |
x.unpack <- START[lavpartable$free > 0L & |
| 68 | ! |
!duplicated(lavpartable$free)] |
| 69 |
} else {
|
|
| 70 | 2x |
x.unpack <- START[lavpartable$free > 0L] |
| 71 |
} |
|
| 72 | ||
| 73 |
# override? use random starting values instead? (new in 0.6-18) |
|
| 74 | 140x |
} else if (start == "random") {
|
| 75 | ! |
START <- lav_partable_random( |
| 76 | ! |
lavpartable = lavpartable, |
| 77 |
# needed if we still need to compute bounds: |
|
| 78 | ! |
lavh1 = lavh1, |
| 79 | ! |
lavdata = lavdata, |
| 80 | ! |
lavsamplestats = lavsamplestats, |
| 81 | ! |
lavoptions = lavoptions |
| 82 |
) |
|
| 83 | ||
| 84 | ! |
if (lavmodel@ceq.simple.only) {
|
| 85 | ! |
x.unpack <- START[lavpartable$free > 0L & |
| 86 | ! |
!duplicated(lavpartable$free)] |
| 87 |
} else {
|
|
| 88 | ! |
x.unpack <- START[lavpartable$free > 0L] |
| 89 |
} |
|
| 90 |
} |
|
| 91 | ||
| 92 | ||
| 93 |
# 1. parameter scaling (to handle data scaling, not parameter scaling) |
|
| 94 | 142x |
parscale <- rep(1.0, length(x.unpack)) |
| 95 | ||
| 96 |
# for < 0.6 compatibility |
|
| 97 | 142x |
if (is.null(lavoptions$optim.parscale)) {
|
| 98 | ! |
lavoptions$optim.parscale <- "none" |
| 99 |
} |
|
| 100 | ||
| 101 | 142x |
if (lavoptions$optim.parscale == "none") {
|
| 102 |
# do nothing, but still set SCALE, as before |
|
| 103 | ||
| 104 | ||
| 105 |
# 0.6-17: |
|
| 106 |
# only temporarily: 'keep' this mistake, and change it later: |
|
| 107 |
# (note the "standarized") |
|
| 108 |
# we only do this to avoid breaking a test in semlbci |
|
| 109 |
# } else if(lavoptions$optim.parscale %in% c("stand", "st", "standardize",
|
|
| 110 |
# "standarized", "stand.all")) {
|
|
| 111 | ||
| 112 |
# this is what it should be: |
|
| 113 | 2x |
} else if (lavoptions$optim.parscale %in% c( |
| 114 | 2x |
"stand", "st", "standardize", |
| 115 | 2x |
"standardized", "stand.all" |
| 116 |
)) {
|
|
| 117 |
# rescale parameters as if the data was standardized |
|
| 118 |
# new in 0.6-2 |
|
| 119 |
# |
|
| 120 |
# FIXME: this works well, as long as the variances of the |
|
| 121 |
# latent variables (which we do not know) are more or less |
|
| 122 |
# equal to 1.0 (eg std.lv = TRUE) |
|
| 123 |
# |
|
| 124 |
# Once we have better estimates of those variances, we could |
|
| 125 |
# use them to set the scale |
|
| 126 |
# |
|
| 127 | ||
| 128 | 2x |
if (lavdata@nlevels > 1L) {
|
| 129 | ! |
if (length(lavh1) > 0L) {
|
| 130 | ! |
OV.VAR <- lapply(lavh1$implied$cov, diag) |
| 131 |
} else {
|
|
| 132 | ! |
OV.VAR <- lapply( |
| 133 | ! |
do.call(c, lapply(lavdata@Lp, "[[", "ov.idx")), |
| 134 | ! |
function(x) rep(1, length(x)) |
| 135 |
) |
|
| 136 |
} |
|
| 137 |
} else {
|
|
| 138 | 2x |
if (lavoptions$conditional.x) {
|
| 139 | 2x |
OV.VAR <- lavsamplestats@res.var |
| 140 |
} else {
|
|
| 141 | ! |
OV.VAR <- lavsamplestats@var |
| 142 |
} |
|
| 143 |
} |
|
| 144 | ||
| 145 | 2x |
if (lavoptions$std.lv) {
|
| 146 | ! |
parscale <- lav_standardize_all( |
| 147 | ! |
lavobject = NULL, |
| 148 | ! |
est = rep(1, length(lavpartable$lhs)), |
| 149 | ! |
est.std = rep(1, length(lavpartable$lhs)), |
| 150 | ! |
cov.std = FALSE, ov.var = OV.VAR, |
| 151 | ! |
lavmodel = lavmodel, lavpartable = lavpartable, |
| 152 | ! |
cov.x = lavsamplestats@cov.x |
| 153 |
) |
|
| 154 |
} else {
|
|
| 155 |
# needs good estimates for lv variances! |
|
| 156 |
# if there is a single 'marker' indicator, we could use |
|
| 157 |
# its observed variance as an upper bound |
|
| 158 | ||
| 159 |
# for the moment, set them to 1.0 (instead of 0.05) |
|
| 160 | ||
| 161 |
# TODO: USE Bentler's 1982 approach to get an estimate of |
|
| 162 |
# VETA; use those diagonal elements... |
|
| 163 |
# but only if we have 'marker' indicators for each LV |
|
| 164 | 2x |
LV.VAR <- vector("list", lavmodel@ngroups)
|
| 165 | 2x |
for (g in seq_len(lavmodel@ngroups)) {
|
| 166 | 2x |
mm.in.group <- 1:lavmodel@nmat[g] + cumsum(c(0, lavmodel@nmat))[g] |
| 167 | 2x |
MLIST <- lavmodel@GLIST[mm.in.group] |
| 168 | 2x |
LAMBDA <- MLIST$lambda |
| 169 | 2x |
n.lv <- ncol(LAMBDA) |
| 170 | 2x |
LV.VAR[[g]] <- rep(1.0, n.lv) |
| 171 |
} |
|
| 172 | ||
| 173 | 2x |
parscale <- lav_standardize_all( |
| 174 | 2x |
lavobject = NULL, |
| 175 | 2x |
est = rep(1, length(lavpartable$lhs)), |
| 176 |
# est.std = rep(1, length(lavpartable$lhs)), |
|
| 177 |
# here, we use whatever the starting values are |
|
| 178 |
# for the latent variances... |
|
| 179 | 2x |
cov.std = FALSE, ov.var = OV.VAR, |
| 180 | 2x |
lv.var = LV.VAR, |
| 181 | 2x |
lavmodel = lavmodel, lavpartable = lavpartable, |
| 182 | 2x |
cov.x = lavsamplestats@cov.x |
| 183 |
) |
|
| 184 |
} |
|
| 185 | ||
| 186 |
# in addition, take sqrt for variance parameters |
|
| 187 | 2x |
var.idx <- which(lavpartable$op == "~~" & |
| 188 | 2x |
lavpartable$lhs == lavpartable$rhs) |
| 189 | 2x |
if (length(var.idx) > 0L) {
|
| 190 | 2x |
parscale[var.idx] <- sqrt(abs(parscale[var.idx])) |
| 191 |
} |
|
| 192 | ||
| 193 | 2x |
if (lavmodel@ceq.simple.only) {
|
| 194 | ! |
parscale <- parscale[lavpartable$free > 0 & |
| 195 | ! |
!duplicated(lavpartable$free)] |
| 196 |
} else {
|
|
| 197 | 2x |
parscale <- parscale[lavpartable$free > 0] |
| 198 |
} |
|
| 199 |
} |
|
| 200 |
# parscale should obey the equality constraints |
|
| 201 | 142x |
if (lavmodel@eq.constraints && lavoptions$optim.parscale != "none") {
|
| 202 |
# pack |
|
| 203 | ! |
p.pack <- as.numeric((parscale - lavmodel@eq.constraints.k0) %*% |
| 204 | ! |
lavmodel@eq.constraints.K) |
| 205 |
# unpack |
|
| 206 | ! |
parscale <- as.numeric(lavmodel@eq.constraints.K %*% p.pack) + |
| 207 | ! |
lavmodel@eq.constraints.k0 |
| 208 |
} |
|
| 209 | 142x |
if (debug) {
|
| 210 | ! |
cat("parscale = ", parscale, "\n")
|
| 211 |
} |
|
| 212 | 142x |
z.unpack <- x.unpack * parscale |
| 213 | ||
| 214 |
# 2. pack (apply equality constraints) |
|
| 215 | 142x |
if (lavmodel@eq.constraints && ncol(lavmodel@eq.constraints.K) > 0L) {
|
| 216 | 10x |
z.pack <- as.numeric((z.unpack - lavmodel@eq.constraints.k0) %*% |
| 217 | 10x |
lavmodel@eq.constraints.K) |
| 218 |
} else {
|
|
| 219 | 132x |
z.pack <- z.unpack |
| 220 |
} |
|
| 221 | ||
| 222 |
# 3. transform (already constrained) variances to standard deviations? |
|
| 223 |
# TODO |
|
| 224 |
# if(lavoptions$optim.var.transform == "sqrt" && |
|
| 225 |
# length(lavmodel@x.free.var.idx) > 0L) {
|
|
| 226 |
# # transforming variances using atan (or another sigmoid function?) |
|
| 227 |
# # FIXME: better approach? |
|
| 228 |
# #start.x[lavmodel@x.free.var.idx] <- |
|
| 229 |
# # atan(start.x[lavmodel@x.free.var.idx]) |
|
| 230 |
# start.x[lavmodel@x.free.var.idx] <- |
|
| 231 |
# sqrt(start.x[lavmodel@x.free.var.idx]) # assuming positive var |
|
| 232 |
# } |
|
| 233 | ||
| 234 |
# final starting values for optimizer |
|
| 235 | 142x |
start.x <- z.pack |
| 236 | 142x |
if (debug) {
|
| 237 | ! |
cat("start.x = ", start.x, "\n")
|
| 238 |
} |
|
| 239 | ||
| 240 |
# user-specified bounds? (new in 0.6-2) |
|
| 241 | 142x |
if (is.null(lavpartable$lower)) {
|
| 242 | 63x |
lower <- -Inf |
| 243 |
} else {
|
|
| 244 | 79x |
if (lavmodel@ceq.simple.only) {
|
| 245 | ! |
free.idx <- which(lavpartable$free > 0L & |
| 246 | ! |
!duplicated(lavpartable$free)) |
| 247 | ! |
lower <- lavpartable$lower[free.idx] |
| 248 | 79x |
} else if (lavmodel@eq.constraints) {
|
| 249 |
# bounds have no effect any longer.... |
|
| 250 |
# 0.6-19 -> we switch to constrained estimation |
|
| 251 |
#lav_msg_warn(gettext( |
|
| 252 |
# "bounds have no effect in the presence of linear equality constraints")) |
|
| 253 | ! |
lower <- -Inf |
| 254 |
} else {
|
|
| 255 | 79x |
lower <- lavpartable$lower[lavpartable$free > 0L] |
| 256 |
} |
|
| 257 |
} |
|
| 258 | 142x |
if (is.null(lavpartable$upper)) {
|
| 259 | 63x |
upper <- +Inf |
| 260 |
} else {
|
|
| 261 | 79x |
if (lavmodel@ceq.simple.only) {
|
| 262 | ! |
free.idx <- which(lavpartable$free > 0L & |
| 263 | ! |
!duplicated(lavpartable$free)) |
| 264 | ! |
upper <- lavpartable$upper[free.idx] |
| 265 | 79x |
} else if (lavmodel@eq.constraints) {
|
| 266 |
# bounds have no effect any longer.... |
|
| 267 | ! |
if (is.null(lavpartable$lower)) {
|
| 268 |
# bounds have no effect any longer.... |
|
| 269 |
# 0.6-19 -> we switch to constrained estimation |
|
| 270 |
#lav_msg_warn(gettext( |
|
| 271 |
#"bounds have no effect in the presence of linear equality constraints")) |
|
| 272 |
} |
|
| 273 | ! |
upper <- +Inf |
| 274 |
} else {
|
|
| 275 | 79x |
upper <- lavpartable$upper[lavpartable$free > 0L] |
| 276 |
} |
|
| 277 |
} |
|
| 278 | ||
| 279 |
# check for inconsistent lower/upper bounds |
|
| 280 |
# this may happen if we have equality constraints; qr() may switch |
|
| 281 |
# the sign... |
|
| 282 | 142x |
bad.idx <- which(lower > upper) |
| 283 | 142x |
if (length(bad.idx) > 0L) {
|
| 284 |
# switch |
|
| 285 |
# tmp <- lower[bad.idx] |
|
| 286 |
# lower[bad.idx] <- upper[bad.idx] |
|
| 287 |
# upper[bad.idx] <- tmp |
|
| 288 | ! |
lower[bad.idx] <- -Inf |
| 289 | ! |
upper[bad.idx] <- +Inf |
| 290 |
} |
|
| 291 | ||
| 292 |
# function to be minimized |
|
| 293 | 142x |
objective_function <- function(x, verbose = FALSE, infToMax = FALSE, |
| 294 | 142x |
debug = FALSE) {
|
| 295 |
# 3. standard deviations to variances |
|
| 296 |
# WARNING: x is still packed here! |
|
| 297 |
# if(lavoptions$optim.var.transform == "sqrt" && |
|
| 298 |
# length(lavmodel@x.free.var.idx) > 0L) {
|
|
| 299 |
# #x[lavmodel@x.free.var.idx] <- tan(x[lavmodel@x.free.var.idx]) |
|
| 300 |
# x.var <- x[lavmodel@x.free.var.idx] |
|
| 301 |
# x.var.sign <- sign(x.var) |
|
| 302 |
# x[lavmodel@x.free.var.idx] <- x.var.sign * (x.var * x.var) # square! |
|
| 303 |
# } |
|
| 304 | ||
| 305 |
# 2. unpack |
|
| 306 | 6172x |
if (lavmodel@eq.constraints) {
|
| 307 | 1026x |
x <- as.numeric(lavmodel@eq.constraints.K %*% x) + |
| 308 | 1026x |
lavmodel@eq.constraints.k0 |
| 309 |
} |
|
| 310 | ||
| 311 |
# 1. unscale |
|
| 312 | 6172x |
x <- x / parscale |
| 313 | ||
| 314 |
# update GLIST (change `state') and make a COPY! |
|
| 315 | 6172x |
GLIST <- lav_model_x2glist(lavmodel, x = x) |
| 316 | ||
| 317 | 6172x |
fx <- lav_model_objective( |
| 318 | 6172x |
lavmodel = lavmodel, |
| 319 | 6172x |
GLIST = GLIST, |
| 320 | 6172x |
lavsamplestats = lavsamplestats, |
| 321 | 6172x |
lavdata = lavdata, |
| 322 | 6172x |
lavcache = lavcache |
| 323 |
) |
|
| 324 | ||
| 325 |
# only for PML: divide by N (to speed up convergence) |
|
| 326 | 6172x |
if (estimator == "PML") {
|
| 327 | ! |
fx <- fx / lavsamplestats@ntotal |
| 328 |
} |
|
| 329 | ||
| 330 | ||
| 331 | ||
| 332 | 6172x |
if (debug || verbose) {
|
| 333 | ! |
cat(" objective function = ",
|
| 334 | ! |
sprintf("%18.16f", fx), "\n",
|
| 335 | ! |
sep = "" |
| 336 |
) |
|
| 337 |
} |
|
| 338 | 6172x |
if (debug) {
|
| 339 |
# cat("Current unconstrained parameter values =\n")
|
|
| 340 |
# tmp.x <- lav_model_get_parameters(lavmodel, GLIST=GLIST, type="unco") |
|
| 341 |
# print(tmp.x); cat("\n")
|
|
| 342 | ! |
cat("Current free parameter values =\n")
|
| 343 | ! |
print(x) |
| 344 | ! |
cat("\n")
|
| 345 |
} |
|
| 346 | ||
| 347 | 6172x |
if (lavoptions$optim.partrace) {
|
| 348 | ! |
PENV$PARTRACE <- rbind(PENV$PARTRACE, c(fx, x)) |
| 349 |
} |
|
| 350 | ||
| 351 |
# for L-BFGS-B |
|
| 352 |
# if(infToMax && is.infinite(fx)) fx <- 1e20 |
|
| 353 | 6172x |
if (!is.finite(fx)) {
|
| 354 | 20x |
fx.group <- attr(fx, "fx.group") |
| 355 | 20x |
fx <- 1e20 |
| 356 | 20x |
attr(fx, "fx.group") <- fx.group # only for lav_model_fit() |
| 357 |
} |
|
| 358 | ||
| 359 | 6172x |
fx |
| 360 |
} |
|
| 361 | ||
| 362 | 142x |
gradient_function <- function(x, verbose = FALSE, infToMax = FALSE, |
| 363 | 142x |
debug = FALSE) {
|
| 364 |
# transform variances back |
|
| 365 |
# if(lavoptions$optim.var.transform == "sqrt" && |
|
| 366 |
# length(lavmodel@x.free.var.idx) > 0L) {
|
|
| 367 |
# #x[lavmodel@x.free.var.idx] <- tan(x[lavmodel@x.free.var.idx]) |
|
| 368 |
# x.var <- x[lavmodel@x.free.var.idx] |
|
| 369 |
# x.var.sign <- sign(x.var) |
|
| 370 |
# x[lavmodel@x.free.var.idx] <- x.var.sign * (x.var * x.var) # square! |
|
| 371 |
# } |
|
| 372 | ||
| 373 |
# 2. unpack |
|
| 374 | 4948x |
if (lavmodel@eq.constraints) {
|
| 375 | 850x |
x <- as.numeric(lavmodel@eq.constraints.K %*% x) + |
| 376 | 850x |
lavmodel@eq.constraints.k0 |
| 377 |
} |
|
| 378 | ||
| 379 |
# 1. unscale |
|
| 380 | 4948x |
x <- x / parscale |
| 381 | ||
| 382 |
# update GLIST (change `state') and make a COPY! |
|
| 383 | 4948x |
GLIST <- lav_model_x2glist(lavmodel, x = x) |
| 384 | ||
| 385 | 4948x |
dx <- lav_model_gradient( |
| 386 | 4948x |
lavmodel = lavmodel, |
| 387 | 4948x |
GLIST = GLIST, |
| 388 | 4948x |
lavsamplestats = lavsamplestats, |
| 389 | 4948x |
lavdata = lavdata, |
| 390 | 4948x |
lavcache = lavcache, |
| 391 | 4948x |
type = "free", |
| 392 | 4948x |
group.weight = group.weight, ### check me!! |
| 393 | 4948x |
ceq.simple = lavmodel@ceq.simple.only |
| 394 |
) |
|
| 395 | ||
| 396 | 4948x |
if (debug) {
|
| 397 | ! |
cat("Gradient function (analytical) =\n")
|
| 398 | ! |
print(dx) |
| 399 | ! |
cat("\n")
|
| 400 |
} |
|
| 401 | ||
| 402 |
# 1. scale (note: divide, not multiply!) |
|
| 403 | 4948x |
dx <- dx / parscale |
| 404 | ||
| 405 |
# 2. pack |
|
| 406 | 4948x |
if (lavmodel@eq.constraints) {
|
| 407 | 850x |
dx <- as.numeric(dx %*% lavmodel@eq.constraints.K) |
| 408 |
} |
|
| 409 | ||
| 410 |
# 3. transform variances back |
|
| 411 |
# if(lavoptions$optim.var.transform == "sqrt" && |
|
| 412 |
# length(lavmodel@x.free.var.idx) > 0L) {
|
|
| 413 |
# x.var <- x[lavmodel@x.free.var.idx] # here in 'var' metric |
|
| 414 |
# x.var.sign <- sign(x.var) |
|
| 415 |
# x.var <- abs(x.var) |
|
| 416 |
# x.sd <- sqrt(x.var) |
|
| 417 |
# dx[lavmodel@x.free.var.idx] <- |
|
| 418 |
# ( 2 * x.var.sign * dx[lavmodel@x.free.var.idx] * x.sd ) |
|
| 419 |
# } |
|
| 420 | ||
| 421 |
# only for PML: divide by N (to speed up convergence) |
|
| 422 | 4948x |
if (estimator == "PML") {
|
| 423 | ! |
dx <- dx / lavsamplestats@ntotal |
| 424 |
} |
|
| 425 | ||
| 426 | 4948x |
if (debug) {
|
| 427 | ! |
cat("Gradient function (analytical, after eq.constraints.K) =\n")
|
| 428 | ! |
print(dx) |
| 429 | ! |
cat("\n")
|
| 430 |
} |
|
| 431 | ||
| 432 | 4948x |
dx |
| 433 |
} |
|
| 434 | ||
| 435 | 142x |
gradient_function_numerical <- function(x, verbose = FALSE, debug = FALSE) {
|
| 436 |
# NOTE: no need to 'tranform' anything here (var/eq) |
|
| 437 |
# this is done anyway in objective_function |
|
| 438 | ||
| 439 |
# numerical approximation using the Richardson method |
|
| 440 | ! |
npar <- length(x) |
| 441 | ! |
h <- 10e-6 |
| 442 | ! |
dx <- numeric(npar) |
| 443 | ||
| 444 |
## FIXME: call lav_model_objective directly!! |
|
| 445 | ! |
for (i in 1:npar) {
|
| 446 | ! |
x.left <- x.left2 <- x.right <- x.right2 <- x |
| 447 | ! |
x.left[i] <- x[i] - h |
| 448 | ! |
x.left2[i] <- x[i] - 2 * h |
| 449 | ! |
x.right[i] <- x[i] + h |
| 450 | ! |
x.right2[i] <- x[i] + 2 * h |
| 451 | ! |
fx.left <- objective_function(x.left, verbose = FALSE, debug = FALSE) |
| 452 | ! |
fx.left2 <- objective_function(x.left2, verbose = FALSE, debug = FALSE) |
| 453 | ! |
fx.right <- objective_function(x.right, verbose = FALSE, debug = FALSE) |
| 454 | ! |
fx.right2 <- objective_function(x.right2, verbose = FALSE, debug = FALSE) |
| 455 | ! |
dx[i] <- (fx.left2 - 8 * fx.left + 8 * fx.right - fx.right2) / (12 * h) |
| 456 |
} |
|
| 457 | ||
| 458 |
# dx <- lavGradientC(func=objective_function, x=x) |
|
| 459 |
# does not work if pnorm is involved... (eg PML) |
|
| 460 | ||
| 461 | ! |
if (debug) {
|
| 462 | ! |
cat("Gradient function (numerical) =\n")
|
| 463 | ! |
print(dx) |
| 464 | ! |
cat("\n")
|
| 465 |
} |
|
| 466 | ||
| 467 | ! |
dx |
| 468 |
} |
|
| 469 | ||
| 470 | 142x |
gradient_function_numerical_complex <- function(x, verbose = FALSE, debug = FALSE) {
|
| 471 | ! |
dx <- Re(lav_func_gradient_complex( |
| 472 | ! |
func = objective_function, x = x, |
| 473 | ! |
h = sqrt(.Machine$double.eps) |
| 474 |
)) |
|
| 475 |
# does not work if pnorm is involved... (eg PML) |
|
| 476 | ||
| 477 | ! |
if (debug) {
|
| 478 | ! |
cat("Gradient function (numerical complex) =\n")
|
| 479 | ! |
print(dx) |
| 480 | ! |
cat("\n")
|
| 481 |
} |
|
| 482 | ||
| 483 | ! |
dx |
| 484 |
} |
|
| 485 | ||
| 486 | ||
| 487 |
# check if the initial values produce a positive definite Sigma |
|
| 488 |
# to begin with -- but only for estimator="ML" |
|
| 489 | 142x |
if (estimator %in% c("ML", "FML", "MML")) {
|
| 490 | 118x |
Sigma.hat <- lav_model_sigma(lavmodel, extra = TRUE) |
| 491 | 118x |
for (g in 1:ngroups) {
|
| 492 | 126x |
if (!attr(Sigma.hat[[g]], "po")) {
|
| 493 | ! |
group.txt <- |
| 494 | ! |
if(ngroups > 1) gettextf(" in group %s.", g) else "."
|
| 495 | ! |
if (debug) {
|
| 496 | ! |
print(Sigma.hat[[g]][, ]) |
| 497 |
} |
|
| 498 | ! |
lav_msg_warn(gettext( |
| 499 | ! |
"initial model-implied matrix (Sigma) is not positive definite; |
| 500 | ! |
check your model and/or starting parameters"), group.txt) |
| 501 | ! |
x <- start.x |
| 502 | ! |
fx <- as.numeric(NA) |
| 503 | ! |
attr(fx, "fx.group") <- rep(as.numeric(NA), ngroups) |
| 504 | ! |
attr(x, "converged") <- FALSE |
| 505 | ! |
attr(x, "iterations") <- 0L |
| 506 | ! |
attr(x, "control") <- lavoptions$control |
| 507 | ! |
attr(x, "fx") <- fx |
| 508 | ! |
return(x) |
| 509 |
} |
|
| 510 |
} |
|
| 511 |
} |
|
| 512 | ||
| 513 | ||
| 514 |
# parameter scaling |
|
| 515 |
# FIXME: what is the best way to set the scale?? |
|
| 516 |
# current strategy: if startx > 1.0, we rescale by using |
|
| 517 |
# 1/startx |
|
| 518 | 142x |
SCALE <- rep(1.0, length(start.x)) |
| 519 | 142x |
if (lavoptions$optim.parscale == "none") {
|
| 520 | 140x |
idx <- which(abs(start.x) > 1.0) |
| 521 | 140x |
if (length(idx) > 0L) {
|
| 522 | 125x |
SCALE[idx] <- abs(1.0 / start.x[idx]) |
| 523 |
} |
|
| 524 |
} |
|
| 525 | 142x |
if (debug) {
|
| 526 | ! |
cat("SCALE = ", SCALE, "\n")
|
| 527 |
} |
|
| 528 | ||
| 529 | ||
| 530 |
# first try: check if starting values return a finite value |
|
| 531 | 142x |
fx <- objective_function(start.x, verbose = verbose, debug = debug) |
| 532 | 142x |
if (!is.finite(fx)) {
|
| 533 |
# emergency change of start.x |
|
| 534 | ! |
start.x <- start.x / 10 |
| 535 |
} |
|
| 536 | ||
| 537 | ||
| 538 | ||
| 539 |
# first some nelder mead steps? (default = FALSE) |
|
| 540 | 142x |
INIT_NELDER_MEAD <- lavoptions$optim.init_nelder_mead |
| 541 | ||
| 542 |
# gradient: analytic, numerical or NULL? |
|
| 543 | 142x |
if (is.character(lavoptions$optim.gradient)) {
|
| 544 | 142x |
if (lavoptions$optim.gradient %in% c("analytic", "analytical")) {
|
| 545 | 142x |
GRADIENT <- gradient_function |
| 546 | ! |
} else if (lavoptions$optim.gradient %in% c("numerical", "numeric")) {
|
| 547 | ! |
GRADIENT <- gradient_function_numerical |
| 548 | ! |
} else if (lavoptions$optim.gradient %in% c("numeric.complex", "complex")) {
|
| 549 | ! |
GRADIENT <- gradient_function_numerical_complex |
| 550 | ! |
} else if (lavoptions$optim.gradient %in% c("NULL", "null")) {
|
| 551 | ! |
GRADIENT <- NULL |
| 552 |
} else {
|
|
| 553 | ! |
lav_msg_warn(gettext("gradient should be analytic, numerical or NULL"))
|
| 554 |
} |
|
| 555 | ! |
} else if (is.logical(lavoptions$optim.gradient)) {
|
| 556 | ! |
if (lavoptions$optim.gradient) {
|
| 557 | ! |
GRADIENT <- gradient_function |
| 558 |
} else {
|
|
| 559 | ! |
GRADIENT <- NULL |
| 560 |
} |
|
| 561 | ! |
} else if (is.null(lavoptions$optim.gradient)) {
|
| 562 | ! |
GRADIENT <- gradient_function |
| 563 |
} |
|
| 564 | ||
| 565 | ||
| 566 |
# default optimizer |
|
| 567 | 142x |
if (length(lavmodel@ceq.nonlinear.idx) == 0L && |
| 568 | 142x |
(lavmodel@cin.simple.only || (length(lavmodel@cin.linear.idx) == 0L && |
| 569 | 142x |
length(lavmodel@cin.nonlinear.idx) == 0L)) |
| 570 |
) {
|
|
| 571 | 140x |
if (is.null(lavoptions$optim.method)) {
|
| 572 | ! |
OPTIMIZER <- "NLMINB" |
| 573 |
# OPTIMIZER <- "BFGS" # slightly slower, no bounds; better scaling! |
|
| 574 |
# OPTIMIZER <- "L-BFGS-B" # trouble with Inf values for fx! |
|
| 575 |
} else {
|
|
| 576 | 140x |
OPTIMIZER <- toupper(lavoptions$optim.method) |
| 577 | 140x |
stopifnot(OPTIMIZER %in% c( |
| 578 | 140x |
"NLMINB0", "NLMINB1", "NLMINB2", |
| 579 | 140x |
"NLMINB", "BFGS", "L.BFGS.B", "NONE" |
| 580 |
)) |
|
| 581 | 140x |
if (OPTIMIZER == "NLMINB1") {
|
| 582 | ! |
OPTIMIZER <- "NLMINB" |
| 583 |
} |
|
| 584 |
} |
|
| 585 |
} else {
|
|
| 586 | 2x |
if (is.null(lavoptions$optim.method)) {
|
| 587 | ! |
OPTIMIZER <- "NLMINB.CONSTR" |
| 588 |
} else {
|
|
| 589 | 2x |
OPTIMIZER <- toupper(lavoptions$optim.method) |
| 590 | 2x |
stopifnot(OPTIMIZER %in% c("NLMINB.CONSTR", "NLMINB", "NONE"))
|
| 591 |
} |
|
| 592 | 2x |
if (OPTIMIZER == "NLMINB") {
|
| 593 | 2x |
OPTIMIZER <- "NLMINB.CONSTR" |
| 594 |
} |
|
| 595 |
} |
|
| 596 | ||
| 597 | 142x |
if (INIT_NELDER_MEAD) {
|
| 598 | ! |
if (verbose) cat(" initial Nelder-Mead step:\n")
|
| 599 | ! |
trace <- 0L |
| 600 | ! |
if (verbose) trace <- 1L |
| 601 | ! |
optim.out <- optim( |
| 602 | ! |
par = start.x, |
| 603 | ! |
fn = objective_function, |
| 604 | ! |
method = "Nelder-Mead", |
| 605 |
# control=list(maxit=10L, |
|
| 606 |
# parscale=SCALE, |
|
| 607 |
# trace=trace), |
|
| 608 | ! |
hessian = FALSE, |
| 609 | ! |
verbose = verbose, debug = debug |
| 610 |
) |
|
| 611 | ! |
cat("\n")
|
| 612 | ! |
start.x <- optim.out$par |
| 613 |
} |
|
| 614 | ||
| 615 | ||
| 616 | ||
| 617 | 142x |
if (OPTIMIZER == "NLMINB0") {
|
| 618 | ! |
if (verbose) cat(" quasi-Newton steps using NLMINB0 (no analytic gradient):\n")
|
| 619 |
# if(debug) control$trace <- 1L; |
|
| 620 | ! |
control.nlminb <- list( |
| 621 | ! |
eval.max = 20000L, |
| 622 | ! |
iter.max = 10000L, |
| 623 | ! |
trace = 0L, |
| 624 |
# abs.tol=1e-20, ### important!! fx never negative |
|
| 625 | ! |
abs.tol = (.Machine$double.eps * 10), |
| 626 | ! |
rel.tol = 1e-10, |
| 627 |
# step.min=2.2e-14, # in =< 0.5-12 |
|
| 628 | ! |
step.min = 1.0, # 1.0 in < 0.5-21 |
| 629 | ! |
step.max = 1.0, |
| 630 | ! |
x.tol = 1.5e-8, |
| 631 | ! |
xf.tol = 2.2e-14 |
| 632 |
) |
|
| 633 | ! |
control.nlminb <- modifyList(control.nlminb, lavoptions$control) |
| 634 | ! |
control <- control.nlminb[c( |
| 635 | ! |
"eval.max", "iter.max", "trace", |
| 636 | ! |
"step.min", "step.max", |
| 637 | ! |
"abs.tol", "rel.tol", "x.tol", "xf.tol" |
| 638 |
)] |
|
| 639 |
# cat("DEBUG: control = "); print(str(control.nlminb)); cat("\n")
|
|
| 640 | ! |
optim.out <- nlminb( |
| 641 | ! |
start = start.x, |
| 642 | ! |
objective = objective_function, |
| 643 | ! |
gradient = NULL, |
| 644 | ! |
lower = lower, |
| 645 | ! |
upper = upper, |
| 646 | ! |
control = control, |
| 647 | ! |
scale = SCALE, |
| 648 | ! |
verbose = verbose, debug = debug |
| 649 |
) |
|
| 650 | ! |
if (verbose) {
|
| 651 | ! |
cat(" convergence status (0=ok): ", optim.out$convergence, "\n")
|
| 652 | ! |
cat(" nlminb message says: ", optim.out$message, "\n")
|
| 653 | ! |
cat(" number of iterations: ", optim.out$iterations, "\n")
|
| 654 | ! |
cat( |
| 655 | ! |
" number of function evaluations [objective, gradient]: ", |
| 656 | ! |
optim.out$evaluations, "\n" |
| 657 |
) |
|
| 658 |
} |
|
| 659 | ||
| 660 |
# try again |
|
| 661 | ! |
if (optim.out$convergence != 0L) {
|
| 662 | ! |
optim.out <- nlminb( |
| 663 | ! |
start = start.x, |
| 664 | ! |
objective = objective_function, |
| 665 | ! |
gradient = NULL, |
| 666 | ! |
lower = lower, |
| 667 | ! |
upper = upper, |
| 668 | ! |
control = control, |
| 669 | ! |
scale = SCALE, |
| 670 | ! |
verbose = verbose, debug = debug |
| 671 |
) |
|
| 672 |
} |
|
| 673 | ||
| 674 | ! |
iterations <- optim.out$iterations |
| 675 | ! |
x <- optim.out$par |
| 676 | ! |
if (optim.out$convergence == 0L) {
|
| 677 | ! |
converged <- TRUE |
| 678 |
} else {
|
|
| 679 | ! |
converged <- FALSE |
| 680 |
} |
|
| 681 | 142x |
} else if (OPTIMIZER == "NLMINB") {
|
| 682 | ! |
if (verbose) cat(" quasi-Newton steps using NLMINB:\n")
|
| 683 |
# if(debug) control$trace <- 1L; |
|
| 684 | 108x |
control.nlminb <- list( |
| 685 | 108x |
eval.max = 20000L, |
| 686 | 108x |
iter.max = 10000L, |
| 687 | 108x |
trace = 0L, |
| 688 |
# abs.tol=1e-20, ### important!! fx never negative |
|
| 689 | 108x |
abs.tol = (.Machine$double.eps * 10), |
| 690 | 108x |
rel.tol = 1e-10, |
| 691 |
# step.min=2.2e-14, # in =< 0.5-12 |
|
| 692 | 108x |
step.min = 1.0, # 1.0 in < 0.5-21 |
| 693 | 108x |
step.max = 1.0, |
| 694 | 108x |
x.tol = 1.5e-8, |
| 695 | 108x |
xf.tol = 2.2e-14 |
| 696 |
) |
|
| 697 | 108x |
control.nlminb <- modifyList(control.nlminb, lavoptions$control) |
| 698 | 108x |
control <- control.nlminb[c( |
| 699 | 108x |
"eval.max", "iter.max", "trace", |
| 700 | 108x |
"step.min", "step.max", |
| 701 | 108x |
"abs.tol", "rel.tol", "x.tol", "xf.tol" |
| 702 |
)] |
|
| 703 |
# cat("DEBUG: control = "); print(str(control.nlminb)); cat("\n")
|
|
| 704 | 108x |
optim.out <- nlminb( |
| 705 | 108x |
start = start.x, |
| 706 | 108x |
objective = objective_function, |
| 707 | 108x |
gradient = GRADIENT, |
| 708 | 108x |
lower = lower, |
| 709 | 108x |
upper = upper, |
| 710 | 108x |
control = control, |
| 711 | 108x |
scale = SCALE, |
| 712 | 108x |
verbose = verbose, debug = debug |
| 713 |
) |
|
| 714 | 108x |
if (verbose) {
|
| 715 | ! |
cat(" convergence status (0=ok): ", optim.out$convergence, "\n")
|
| 716 | ! |
cat(" nlminb message says: ", optim.out$message, "\n")
|
| 717 | ! |
cat(" number of iterations: ", optim.out$iterations, "\n")
|
| 718 | ! |
cat( |
| 719 | ! |
" number of function evaluations [objective, gradient]: ", |
| 720 | ! |
optim.out$evaluations, "\n" |
| 721 |
) |
|
| 722 |
} |
|
| 723 | ||
| 724 | 108x |
iterations <- optim.out$iterations |
| 725 | 108x |
x <- optim.out$par |
| 726 | 108x |
if (optim.out$convergence == 0L) {
|
| 727 | 104x |
converged <- TRUE |
| 728 |
} else {
|
|
| 729 | 4x |
converged <- FALSE |
| 730 |
} |
|
| 731 | 34x |
} else if (OPTIMIZER == "BFGS") {
|
| 732 |
# warning: Bollen example with estimator=GLS does NOT converge! |
|
| 733 |
# (but WLS works!) |
|
| 734 |
# - BB.ML works too |
|
| 735 | ||
| 736 | ! |
control.bfgs <- list( |
| 737 | ! |
trace = 0L, fnscale = 1, |
| 738 | ! |
parscale = SCALE, ## or not? |
| 739 | ! |
ndeps = 1e-3, |
| 740 | ! |
maxit = 10000, |
| 741 | ! |
abstol = 1e-20, |
| 742 | ! |
reltol = 1e-10, |
| 743 | ! |
REPORT = 1L |
| 744 |
) |
|
| 745 | ! |
control.bfgs <- modifyList(control.bfgs, lavoptions$control) |
| 746 | ! |
control <- control.bfgs[c( |
| 747 | ! |
"trace", "fnscale", "parscale", "ndeps", |
| 748 | ! |
"maxit", "abstol", "reltol", "REPORT" |
| 749 |
)] |
|
| 750 |
# trace <- 0L; if(verbose) trace <- 1L |
|
| 751 | ! |
optim.out <- optim( |
| 752 | ! |
par = start.x, |
| 753 | ! |
fn = objective_function, |
| 754 | ! |
gr = GRADIENT, |
| 755 | ! |
method = "BFGS", |
| 756 | ! |
control = control, |
| 757 | ! |
hessian = FALSE, |
| 758 | ! |
verbose = verbose, debug = debug |
| 759 |
) |
|
| 760 | ! |
if (verbose) {
|
| 761 | ! |
cat(" convergence status (0=ok): ", optim.out$convergence, "\n")
|
| 762 | ! |
cat(" optim BFGS message says: ", optim.out$message, "\n")
|
| 763 |
# cat("number of iterations: ", optim.out$iterations, "\n")
|
|
| 764 | ! |
cat( |
| 765 | ! |
" number of function evaluations [objective, gradient]: ", |
| 766 | ! |
optim.out$counts, "\n" |
| 767 |
) |
|
| 768 |
} |
|
| 769 | ||
| 770 |
# iterations <- optim.out$iterations |
|
| 771 | ! |
iterations <- optim.out$counts[1] |
| 772 | ! |
x <- optim.out$par |
| 773 | ! |
if (optim.out$convergence == 0L) {
|
| 774 | ! |
converged <- TRUE |
| 775 |
} else {
|
|
| 776 | ! |
converged <- FALSE |
| 777 |
} |
|
| 778 | 34x |
} else if (OPTIMIZER == "L.BFGS.B") {
|
| 779 |
# warning, does not cope with Inf values!! |
|
| 780 | ||
| 781 | ! |
control.lbfgsb <- list( |
| 782 | ! |
trace = 0L, fnscale = 1, |
| 783 | ! |
parscale = SCALE, ## or not? |
| 784 | ! |
ndeps = 1e-3, |
| 785 | ! |
maxit = 10000, |
| 786 | ! |
REPORT = 1L, |
| 787 | ! |
lmm = 5L, |
| 788 | ! |
factr = 1e7, |
| 789 | ! |
pgtol = 0 |
| 790 |
) |
|
| 791 | ! |
control.lbfgsb <- modifyList(control.lbfgsb, lavoptions$control) |
| 792 | ! |
control <- control.lbfgsb[c( |
| 793 | ! |
"trace", "fnscale", "parscale", |
| 794 | ! |
"ndeps", "maxit", "REPORT", "lmm", |
| 795 | ! |
"factr", "pgtol" |
| 796 |
)] |
|
| 797 | ! |
optim.out <- optim( |
| 798 | ! |
par = start.x, |
| 799 | ! |
fn = objective_function, |
| 800 | ! |
gr = GRADIENT, |
| 801 | ! |
method = "L-BFGS-B", |
| 802 | ! |
lower = lower, |
| 803 | ! |
upper = upper, |
| 804 | ! |
control = control, |
| 805 | ! |
hessian = FALSE, |
| 806 | ! |
verbose = verbose, debug = debug, |
| 807 | ! |
infToMax = TRUE |
| 808 |
) |
|
| 809 | ! |
if (verbose) {
|
| 810 | ! |
cat(" convergence status (0=ok): ", optim.out$convergence, "\n")
|
| 811 | ! |
cat(" optim L-BFGS-B message says: ", optim.out$message, "\n")
|
| 812 |
# cat("number of iterations: ", optim.out$iterations, "\n")
|
|
| 813 | ! |
cat( |
| 814 | ! |
" number of function evaluations [objective, gradient]: ", |
| 815 | ! |
optim.out$counts, "\n" |
| 816 |
) |
|
| 817 |
} |
|
| 818 | ||
| 819 |
# iterations <- optim.out$iterations |
|
| 820 | ! |
iterations <- optim.out$counts[1] |
| 821 | ! |
x <- optim.out$par |
| 822 | ! |
if (optim.out$convergence == 0L) {
|
| 823 | ! |
converged <- TRUE |
| 824 |
} else {
|
|
| 825 | ! |
converged <- FALSE |
| 826 |
} |
|
| 827 | 34x |
} else if (OPTIMIZER == "NLMINB.CONSTR") {
|
| 828 | 2x |
ocontrol <- list(verbose = verbose) |
| 829 | 2x |
if (!is.null(lavoptions$control$control.outer)) {
|
| 830 | ! |
ocontrol <- c(lavoptions$control$control.outer, verbose = verbose) |
| 831 |
} |
|
| 832 | 2x |
control.nlminb <- list( |
| 833 | 2x |
eval.max = 20000L, |
| 834 | 2x |
iter.max = 10000L, |
| 835 | 2x |
trace = 0L, |
| 836 |
# abs.tol=1e-20, |
|
| 837 | 2x |
abs.tol = (.Machine$double.eps * 10), |
| 838 | 2x |
rel.tol = 1e-9, # 1e-10 seems 'too strict' |
| 839 | 2x |
step.min = 1.0, # 1.0 in < 0.5-21 |
| 840 | 2x |
step.max = 1.0, |
| 841 | 2x |
x.tol = 1.5e-8, |
| 842 | 2x |
xf.tol = 2.2e-14 |
| 843 |
) |
|
| 844 | 2x |
control.nlminb <- modifyList(control.nlminb, lavoptions$control) |
| 845 | 2x |
control <- control.nlminb[c( |
| 846 | 2x |
"eval.max", "iter.max", "trace", |
| 847 | 2x |
"abs.tol", "rel.tol" |
| 848 |
)] |
|
| 849 | 2x |
cin <- cin.jac <- ceq <- ceq.jac <- NULL |
| 850 | 2x |
if (!is.null(body(lavmodel@cin.function))) cin <- lavmodel@cin.function |
| 851 | ! |
if (!is.null(body(lavmodel@cin.jacobian))) cin.jac <- lavmodel@cin.jacobian |
| 852 | ! |
if (!is.null(body(lavmodel@ceq.function))) ceq <- lavmodel@ceq.function |
| 853 | ! |
if (!is.null(body(lavmodel@ceq.jacobian))) ceq.jac <- lavmodel@ceq.jacobian |
| 854 | 2x |
trace <- FALSE |
| 855 | ! |
if (verbose) trace <- TRUE |
| 856 | 2x |
optim.out <- nlminb.constr( |
| 857 | 2x |
start = start.x, |
| 858 | 2x |
objective = objective_function, |
| 859 | 2x |
gradient = GRADIENT, |
| 860 | 2x |
control = control, |
| 861 | 2x |
scale = SCALE, |
| 862 | 2x |
verbose = verbose, debug = debug, |
| 863 | 2x |
lower = lower, |
| 864 | 2x |
upper = upper, |
| 865 | 2x |
cin = cin, cin.jac = cin.jac, |
| 866 | 2x |
ceq = ceq, ceq.jac = ceq.jac, |
| 867 | 2x |
control.outer = ocontrol |
| 868 |
) |
|
| 869 | 2x |
if (verbose) {
|
| 870 | ! |
cat(" convergence status (0=ok): ", optim.out$convergence, "\n")
|
| 871 | ! |
cat(" nlminb.constr message says: ", optim.out$message, "\n")
|
| 872 | ! |
cat(" number of outer iterations: ", optim.out$outer.iterations, "\n")
|
| 873 | ! |
cat(" number of inner iterations: ", optim.out$iterations, "\n")
|
| 874 | ! |
cat( |
| 875 | ! |
" number of function evaluations [objective, gradient]: ", |
| 876 | ! |
optim.out$evaluations, "\n" |
| 877 |
) |
|
| 878 |
} |
|
| 879 | ||
| 880 | 2x |
iterations <- optim.out$iterations |
| 881 | 2x |
x <- optim.out$par |
| 882 | 2x |
if (optim.out$convergence == 0) {
|
| 883 | 2x |
converged <- TRUE |
| 884 |
} else {
|
|
| 885 | ! |
converged <- FALSE |
| 886 |
} |
|
| 887 | 32x |
} else if (OPTIMIZER == "NONE") {
|
| 888 | 32x |
x <- start.x |
| 889 | 32x |
iterations <- 0L |
| 890 | 32x |
converged <- TRUE |
| 891 | 32x |
control <- list() |
| 892 | ||
| 893 |
# if inequality constraints, add con.jac/lambda |
|
| 894 |
# needed for df! |
|
| 895 | 32x |
if (length(lavmodel@ceq.nonlinear.idx) == 0L && |
| 896 | 32x |
(lavmodel@cin.simple.only || |
| 897 | 32x |
(length(lavmodel@cin.linear.idx) == 0L && |
| 898 | 32x |
length(lavmodel@cin.nonlinear.idx) == 0L))) {
|
| 899 | 32x |
optim.out <- list() |
| 900 |
} else {
|
|
| 901 |
# if inequality constraints, add con.jac/lambda |
|
| 902 |
# needed for df! |
|
| 903 | ||
| 904 | ! |
optim.out <- list() |
| 905 | ! |
if (is.null(body(lavmodel@ceq.function))) {
|
| 906 | ! |
ceq <- function(x, ...) {
|
| 907 | ! |
return(numeric(0)) |
| 908 |
} |
|
| 909 |
} else {
|
|
| 910 | ! |
ceq <- lavmodel@ceq.function |
| 911 |
} |
|
| 912 | ! |
if (is.null(body(lavmodel@cin.function))) {
|
| 913 | ! |
cin <- function(x, ...) {
|
| 914 | ! |
return(numeric(0)) |
| 915 |
} |
|
| 916 |
} else {
|
|
| 917 | ! |
cin <- lavmodel@cin.function |
| 918 |
} |
|
| 919 | ! |
ceq0 <- ceq(start.x) |
| 920 | ! |
cin0 <- cin(start.x) |
| 921 | ! |
con0 <- c(ceq0, cin0) |
| 922 | ! |
JAC <- rbind( |
| 923 | ! |
numDeriv::jacobian(ceq, x = start.x), |
| 924 | ! |
numDeriv::jacobian(cin, x = start.x) |
| 925 |
) |
|
| 926 | ! |
nceq <- length(ceq(start.x)) |
| 927 | ! |
ncin <- length(cin(start.x)) |
| 928 | ! |
ncon <- nceq + ncin |
| 929 | ! |
ceq.idx <- cin.idx <- integer(0) |
| 930 | ! |
if (nceq > 0L) ceq.idx <- 1:nceq |
| 931 | ! |
if (ncin > 0L) cin.idx <- nceq + 1:ncin |
| 932 | ! |
cin.flag <- rep(FALSE, length(ncon)) |
| 933 | ! |
if (ncin > 0L) cin.flag[cin.idx] <- TRUE |
| 934 | ||
| 935 | ! |
inactive.idx <- integer(0L) |
| 936 | ! |
cin.idx <- which(cin.flag) |
| 937 | ! |
if (ncin > 0L) {
|
| 938 | ! |
slack <- 1e-05 |
| 939 | ! |
inactive.idx <- which(cin.flag & con0 > slack) |
| 940 |
} |
|
| 941 | ! |
attr(JAC, "inactive.idx") <- inactive.idx |
| 942 | ! |
attr(JAC, "cin.idx") <- cin.idx |
| 943 | ! |
attr(JAC, "ceq.idx") <- ceq.idx |
| 944 | ||
| 945 | ! |
optim.out$con.jac <- JAC |
| 946 | ! |
optim.out$lambda <- rep(0, ncon) |
| 947 |
} |
|
| 948 |
} |
|
| 949 | ||
| 950 |
# new in 0.6-19 |
|
| 951 |
# if NLMINB() + cin.simple.only, add con.jac and lambda to optim.out |
|
| 952 | 142x |
if (OPTIMIZER %in% c("NLMINB", "NLMINB0", "L.BFGS.B") &&
|
| 953 | 142x |
(lavmodel@cin.simple.only || lavmodel@ceq.simple.only)) {
|
| 954 | ||
| 955 | 63x |
if (lavmodel@cin.simple.only && nrow(lavmodel@cin.JAC) > 0L) {
|
| 956 |
# JAC |
|
| 957 | 63x |
cin.JAC <- lavmodel@cin.JAC |
| 958 | 63x |
con0 <- lavmodel@cin.function(x) |
| 959 | 63x |
slack <- 1e-05 |
| 960 | 63x |
inactive.idx <- which(abs(con0) > slack) |
| 961 | ||
| 962 |
# lambda |
|
| 963 |
# FIXME! HOW to compute this (post-hoc)? |
|
| 964 | 63x |
dx <- GRADIENT(x) |
| 965 | 63x |
if(lavmodel@ceq.simple.only) {
|
| 966 | ! |
dx.unpack <- numeric(ncol(cin.JAC)) |
| 967 | ! |
dx.unpack <- dx[lavpartable$free[lavpartable$free > 0]] |
| 968 | 63x |
} else if (lavmodel@eq.constraints) {
|
| 969 |
# this should not happen! |
|
| 970 | ! |
cat("\n DEBUG: NLMINB + cin.simple.only + lavmodel@eq.constraints \n")
|
| 971 | ! |
dx.unpack <- as.numeric(lavmodel@eq.constraints.K %*% dx) |
| 972 |
} else {
|
|
| 973 | 63x |
dx.unpack <- dx |
| 974 |
} |
|
| 975 | 63x |
cin.lambda <- drop(cin.JAC %*% dx.unpack) |
| 976 | 63x |
cin.lambda[inactive.idx] <- 0 |
| 977 | ||
| 978 |
# remove all inactive rows |
|
| 979 |
#if (length(inactive.idx) > 0L) {
|
|
| 980 |
# cin.JAC <- cin.JAC[-inactive.idx, , drop = FALSE] |
|
| 981 |
# cin.lambda <- cin.lambda[-inactive.idx] |
|
| 982 |
# inactive.idx <- integer(0L) |
|
| 983 |
#} |
|
| 984 |
} else {
|
|
| 985 | ! |
npar <- length(lavpartable$free[lavpartable$free > 0]) |
| 986 | ! |
cin.JAC <- matrix(0, nrow = 0L, ncol = npar) |
| 987 | ! |
inactive.idx <- integer(0L) |
| 988 | ! |
cin.lambda <- numeric(0L) |
| 989 |
} |
|
| 990 | ||
| 991 | 63x |
if (lavmodel@ceq.simple.only && nrow(lavmodel@ceq.simple.K) > 0L) {
|
| 992 | ! |
ceq.JAC <- t(lav_matrix_orthogonal_complement(lavmodel@ceq.simple.K)) |
| 993 | ! |
ceq.lambda <- numeric(nrow(ceq.JAC)) |
| 994 |
} else {
|
|
| 995 | 63x |
npar <- length(lavpartable$free[lavpartable$free > 0]) |
| 996 | 63x |
ceq.JAC <- matrix(0, nrow = 0L, ncol = npar) |
| 997 | 63x |
ceq.lambda <- numeric(0L) |
| 998 |
} |
|
| 999 | ||
| 1000 |
# combine |
|
| 1001 | 63x |
JAC <- rbind(cin.JAC, ceq.JAC) |
| 1002 | 63x |
attr(JAC, "inactive.idx") <- inactive.idx |
| 1003 | 63x |
attr(JAC, "cin.idx") <- seq_len(nrow(cin.JAC)) |
| 1004 | 63x |
attr(JAC, "ceq.idx") <- nrow(cin.JAC) + seq_len(nrow(ceq.JAC)) |
| 1005 | 63x |
lambda <- c(cin.lambda, ceq.lambda) |
| 1006 | ||
| 1007 | 63x |
optim.out$con.jac <- JAC |
| 1008 | 63x |
optim.out$lambda <- lambda |
| 1009 |
} |
|
| 1010 | ||
| 1011 | ||
| 1012 | 142x |
fx <- objective_function(x) # to get "fx.group" attribute |
| 1013 | ||
| 1014 |
# check convergence |
|
| 1015 | 142x |
warn.txt <- "" |
| 1016 | 142x |
if (converged) {
|
| 1017 |
# check.gradient |
|
| 1018 | 138x |
if (!is.null(GRADIENT) && |
| 1019 | 138x |
OPTIMIZER %in% c("NLMINB", "BFGS", "L.BFGS.B")) {
|
| 1020 |
# compute unscaled gradient |
|
| 1021 | 104x |
dx <- GRADIENT(x) |
| 1022 | ||
| 1023 |
# NOTE: unscaled gradient!!! |
|
| 1024 | 104x |
if (converged && lavoptions$check.gradient && |
| 1025 | 104x |
any(abs(dx) > lavoptions$optim.dx.tol)) {
|
| 1026 |
# ok, identify the non-zero elements |
|
| 1027 | ! |
non.zero <- which(abs(dx) > lavoptions$optim.dx.tol) |
| 1028 | ||
| 1029 |
# which ones are 'boundary' points, defined by lower/upper? |
|
| 1030 | ! |
bound.idx <- integer(0L) |
| 1031 | ! |
if (!is.null(lavpartable$lower)) {
|
| 1032 | ! |
bound.idx <- c(bound.idx, which(lower == x)) |
| 1033 |
} |
|
| 1034 | ! |
if (!is.null(lavpartable$upper)) {
|
| 1035 | ! |
bound.idx <- c(bound.idx, which(upper == x)) |
| 1036 |
} |
|
| 1037 | ! |
if (length(bound.idx) > 0L) {
|
| 1038 | ! |
non.zero <- non.zero[-which(non.zero %in% bound.idx)] |
| 1039 |
} |
|
| 1040 | ||
| 1041 |
# this has many implications ... so should be careful to |
|
| 1042 |
# avoid false alarm |
|
| 1043 | ! |
if (length(non.zero) > 0L) {
|
| 1044 | ! |
converged <- FALSE |
| 1045 | ! |
warn.txt <- paste("the optimizer (", OPTIMIZER, ") ",
|
| 1046 | ! |
"claimed the model converged,\n", |
| 1047 | ! |
" but not all elements of the gradient are (near) zero;\n", |
| 1048 | ! |
" the optimizer may not have found a local solution\n", |
| 1049 | ! |
" use check.gradient = FALSE to skip this check.", |
| 1050 | ! |
sep = "" |
| 1051 |
) |
|
| 1052 |
} |
|
| 1053 |
} |
|
| 1054 |
} else {
|
|
| 1055 | 34x |
dx <- numeric(0L) |
| 1056 |
} |
|
| 1057 |
} else {
|
|
| 1058 | 4x |
dx <- numeric(0L) |
| 1059 | 4x |
warn.txt <- "the optimizer warns that a solution has NOT been found!" |
| 1060 |
} |
|
| 1061 | ||
| 1062 |
# transform back |
|
| 1063 |
# 3. |
|
| 1064 |
# if(lavoptions$optim.var.transform == "sqrt" && |
|
| 1065 |
# length(lavmodel@x.free.var.idx) > 0L) {
|
|
| 1066 |
# #x[lavmodel@x.free.var.idx] <- tan(x[lavmodel@x.free.var.idx]) |
|
| 1067 |
# x.var <- x[lavmodel@x.free.var.idx] |
|
| 1068 |
# x.var.sign <- sign(x.var) |
|
| 1069 |
# x[lavmodel@x.free.var.idx] <- x.var.sign * (x.var * x.var) # square! |
|
| 1070 |
# } |
|
| 1071 | ||
| 1072 |
# 2. unpack |
|
| 1073 | 142x |
if (lavmodel@eq.constraints) {
|
| 1074 | 10x |
x <- as.numeric(lavmodel@eq.constraints.K %*% x) + |
| 1075 | 10x |
lavmodel@eq.constraints.k0 |
| 1076 |
} |
|
| 1077 | ||
| 1078 |
# 1. unscale |
|
| 1079 | 142x |
x <- x / parscale |
| 1080 | ||
| 1081 | 142x |
attr(x, "converged") <- converged |
| 1082 | 142x |
attr(x, "start") <- start.x |
| 1083 | 142x |
attr(x, "warn.txt") <- warn.txt |
| 1084 | 142x |
attr(x, "iterations") <- iterations |
| 1085 | 142x |
attr(x, "control") <- control |
| 1086 | 142x |
attr(x, "fx") <- fx |
| 1087 | 142x |
attr(x, "dx") <- dx |
| 1088 | 142x |
attr(x, "parscale") <- parscale |
| 1089 | 65x |
if (!is.null(optim.out$con.jac)) attr(x, "con.jac") <- optim.out$con.jac |
| 1090 | 65x |
if (!is.null(optim.out$lambda)) attr(x, "con.lambda") <- optim.out$lambda |
| 1091 | 142x |
if (lavoptions$optim.partrace) {
|
| 1092 | ! |
attr(x, "partrace") <- PENV$PARTRACE |
| 1093 |
} |
|
| 1094 | ||
| 1095 | 142x |
x |
| 1096 |
} |
|
| 1097 | ||
| 1098 |
# backwards compatibility |
|
| 1099 |
# estimateModel <- lav_model_estimate |
| 1 |
# functions related to the RMSEA index of approximate fit |
|
| 2 | ||
| 3 |
# lower-level functions: no checking of input: just compute the number(s): |
|
| 4 |
# - lav_fit_rmsea |
|
| 5 |
# - lav_fit_rmsea_ci |
|
| 6 |
# - lav_fit_rmsea_closefit |
|
| 7 |
# - lav_fit_rmsea_notclosefit (TODO) |
|
| 8 | ||
| 9 |
# higher-level functions: |
|
| 10 |
# - lav_fit_rmsea_lavobject |
|
| 11 | ||
| 12 |
# Y.R. 19 July 2022 |
|
| 13 | ||
| 14 |
# we assume X2 = N * F.val |
|
| 15 |
# lambda = (X2 - df) is the non-centrality parameter |
|
| 16 | ||
| 17 |
# RMSEA: sqrt( (X2 - df)/(N * df) ) |
|
| 18 |
# = sqrt( lambda/(N * df) ) |
|
| 19 |
# = sqrt( ((N*F.val) - df)/(N * df) ) |
|
| 20 |
# = sqrt( (N.F.val)/(N * df) - df/(N * df) ) |
|
| 21 |
# = sqrt( F.val/df - 1/N ) |
|
| 22 |
# = sqrt( (X2/N)/df - 1/N ) |
|
| 23 | ||
| 24 | ||
| 25 |
# 'scaled' RMSEA: X2 is replaced by X2-SB (or any other 'scaled' statistic) |
|
| 26 | ||
| 27 |
# robust RMSEA: sqrt( (X2/N)/df - c.hat/N ) |
|
| 28 |
# note: |
|
| 29 |
# - robust RMSEA == scaled RMSEA * sqrt(c.hat) |
|
| 30 |
# - robust RMSEA CI == scaled RMSEA CI * sqrt(c.hat) |
|
| 31 | ||
| 32 |
# robust RMSEA for MLMV (ie. scaled.shifted): |
|
| 33 |
# - c == a * (df - b) / df |
|
| 34 |
# - robust RMSEA MLM == robust RMSEA MLMV |
|
| 35 |
# - robust RMSEA MLMV == scaled RMSEA MLMV * sqrt(a) |
|
| 36 |
# - robust RMSEA CI MLMV == scaled RMSEA CI MLMV * sqrt(a) |
|
| 37 | ||
| 38 |
# References: |
|
| 39 |
# Steiger, J. H., & Lind, J. C. (1980, May). Statistically based tests for the |
|
| 40 |
# number of common factors. Paper presented at the annual meeting of the |
|
| 41 |
# Psychometric Society, Iowa City, IA. |
|
| 42 | ||
| 43 |
# confidence interval: |
|
| 44 |
# Browne, M. W., & Cudeck, R. (1993). Alternative ways of assessing model fit. |
|
| 45 |
# In K. A. Bollen & J. S. Long (Eds.), Testing structural equation models (pp. |
|
| 46 |
# 136-162). Newbury Park, CA: Sage. |
|
| 47 | ||
| 48 |
# problems with low df |
|
| 49 |
# Kenny, D. A., Kaniskan, B., & McCoach, D. B. (2015). The performance of RMSEA |
|
| 50 |
# in models with small degrees of freedom. Sociological Methods & Research, 44, |
|
| 51 |
# 486-507. |
|
| 52 | ||
| 53 |
# robust version MLM |
|
| 54 |
# Patricia E. Brosseau-Liard , Victoria Savalei & Libo Li (2012) An |
|
| 55 |
# Investigation of the Sample Performance of Two Nonnormality Corrections for |
|
| 56 |
# RMSEA, Multivariate Behavioral Research, 47:6, 904-930, DOI: |
|
| 57 |
# 10.1080/00273171.2012.715252 |
|
| 58 | ||
| 59 |
# robust version MLMV (scaled.shifted) |
|
| 60 |
# Savalei, V. (2018). On the computation of the RMSEA and CFI from the |
|
| 61 |
# mean-and-variance corrected test statistic with nonnormal data in SEM. |
|
| 62 |
# Multivariate behavioral research, 53(3), 419-429. |
|
| 63 | ||
| 64 |
# categorical data: |
|
| 65 |
# Savalei, V. (2021). Improving fit indices in structural equation modeling with |
|
| 66 |
# categorical data. Multivariate Behavioral Research, 56(3), 390-407. doi: |
|
| 67 |
# 10.1080/00273171.2020.1717922 |
|
| 68 | ||
| 69 |
# missing = "fiml": |
|
| 70 |
# Zhang, X., & Savalei, V. (2022). New computations for RMSEA and CFI following |
|
| 71 |
# FIML and TS estimation with missing data. Psychological Methods. |
|
| 72 | ||
| 73 | ||
| 74 |
# always using N (if a user needs N-1, just replace N by N-1) |
|
| 75 |
# vectorized! |
|
| 76 |
lav_fit_rmsea <- function(X2 = NULL, df = NULL, N = NULL, |
|
| 77 |
F.val = NULL, G = 1L, c.hat = 1.0) {
|
|
| 78 |
# did we get a sample size? |
|
| 79 | 58x |
if (missing(N) && !missing(F.val)) {
|
| 80 |
# population version |
|
| 81 | ! |
RMSEA <- sqrt(F.val / df) |
| 82 |
} else {
|
|
| 83 | 58x |
nel <- length(X2) |
| 84 | 58x |
if (nel == 0) {
|
| 85 | ! |
return(as.numeric(NA)) |
| 86 |
} |
|
| 87 | 58x |
RMSEA <- ifelse(df > 0, |
| 88 |
# 'standard' way to compute RMSEA |
|
| 89 | 58x |
RMSEA <- sqrt(pmax((X2 / N) / df - c.hat / N, rep(0, nel))) * sqrt(G), |
| 90 | 58x |
0 |
| 91 | 58x |
) # if df == 0 |
| 92 |
} |
|
| 93 | ||
| 94 | 58x |
RMSEA |
| 95 |
} |
|
| 96 | ||
| 97 |
# note: for 'robust' version, X2 should be SB-X2 |
|
| 98 |
lav_fit_rmsea_ci <- function(X2 = NULL, df = NULL, N = NULL, |
|
| 99 |
G = 1L, c.hat = 1, level = 0.90) {
|
|
| 100 | 31x |
if (missing(N) || missing(X2) || missing(df) || |
| 101 | 31x |
!is.finite(X2) || !is.finite(df) || !is.finite(N)) {
|
| 102 | 2x |
return(list( |
| 103 | 2x |
rmsea.ci.lower = as.numeric(NA), |
| 104 | 2x |
rmsea.ci.upper = as.numeric(NA) |
| 105 |
)) |
|
| 106 |
} |
|
| 107 | ||
| 108 | 29x |
if (!is.finite(level) || level < 0 || level > 1.0) {
|
| 109 | ! |
lav_msg_warn(gettextf( |
| 110 | ! |
"invalid level value [%s] set to default 0.90.", level |
| 111 |
)) |
|
| 112 | ! |
level <- 0.90 |
| 113 |
} |
|
| 114 | ||
| 115 | 29x |
upper.perc <- (1 - (1 - level) / 2) |
| 116 | 29x |
lower.perc <- (1 - level) / 2 |
| 117 | ||
| 118 |
# internal function |
|
| 119 | 29x |
lower.lambda <- function(lambda) {
|
| 120 | 185x |
(pchisq(X2, df = df, ncp = lambda) - upper.perc) |
| 121 |
} |
|
| 122 | ||
| 123 | 29x |
upper.lambda <- function(lambda) {
|
| 124 | 321x |
(pchisq(X2, df = df, ncp = lambda) - lower.perc) |
| 125 |
} |
|
| 126 | ||
| 127 | ||
| 128 |
# lower bound |
|
| 129 | 29x |
if (df < 1 || lower.lambda(0) < 0.0) {
|
| 130 | 16x |
rmsea.ci.lower <- 0 |
| 131 |
} else {
|
|
| 132 | 13x |
lambda.l <- try(uniroot(f = lower.lambda, lower = 0, upper = X2)$root, |
| 133 | 13x |
silent = TRUE |
| 134 |
) |
|
| 135 | 13x |
if (inherits(lambda.l, "try-error")) {
|
| 136 | ! |
lambda.l <- as.numeric(NA) |
| 137 |
} |
|
| 138 |
# lower bound |
|
| 139 | 13x |
rmsea.ci.lower <- sqrt((c.hat * lambda.l) / (N * df)) |
| 140 | ||
| 141 |
# multiple groups? -> correction |
|
| 142 | 13x |
if (G > 1L) {
|
| 143 | 1x |
rmsea.ci.lower <- rmsea.ci.lower * sqrt(G) |
| 144 |
} |
|
| 145 |
} |
|
| 146 | ||
| 147 |
# upper bound |
|
| 148 | 29x |
N.RMSEA <- max(N, X2 * 4) |
| 149 | 29x |
if (df < 1 || upper.lambda(N.RMSEA) > 0 || upper.lambda(0) < 0) {
|
| 150 | 10x |
rmsea.ci.upper <- 0 |
| 151 |
} else {
|
|
| 152 | 19x |
lambda.u <- try( |
| 153 | 19x |
uniroot( |
| 154 | 19x |
f = upper.lambda, lower = 0, |
| 155 | 19x |
upper = N.RMSEA |
| 156 | 19x |
)$root, |
| 157 | 19x |
silent = TRUE |
| 158 |
) |
|
| 159 | 19x |
if (inherits(lambda.u, "try-error")) {
|
| 160 | ! |
lambda.u <- NA |
| 161 |
} |
|
| 162 |
# upper bound |
|
| 163 | 19x |
rmsea.ci.upper <- sqrt((c.hat * lambda.u) / (N * df)) |
| 164 | ||
| 165 |
# multiple groups? -> correction |
|
| 166 | 19x |
if (G > 1L) {
|
| 167 | 2x |
rmsea.ci.upper <- rmsea.ci.upper * sqrt(G) |
| 168 |
} |
|
| 169 |
} |
|
| 170 | ||
| 171 | 29x |
list( |
| 172 | 29x |
rmsea.ci.lower = rmsea.ci.lower, |
| 173 | 29x |
rmsea.ci.upper = rmsea.ci.upper |
| 174 |
) |
|
| 175 |
} |
|
| 176 | ||
| 177 |
# H_0: RMSEA <= rmsea.h0 |
|
| 178 |
lav_fit_rmsea_closefit <- function(X2 = NULL, df = NULL, N = NULL, |
|
| 179 |
G = 1L, c.hat = 1, rmsea.h0 = 0.05) {
|
|
| 180 | 31x |
if (missing(N) || missing(X2) || missing(df) || |
| 181 | 31x |
!is.finite(X2) || !is.finite(df) || !is.finite(N)) {
|
| 182 | 2x |
return(as.numeric(NA)) |
| 183 |
} |
|
| 184 | ||
| 185 | 29x |
rmsea.pvalue <- as.numeric(NA) |
| 186 | 29x |
if (df > 0) {
|
| 187 |
# see Dudgeon 2004, eq 16 for the 'G' correction |
|
| 188 | 19x |
ncp <- (N * df * 1 / c.hat * rmsea.h0^2) / G |
| 189 | 19x |
rmsea.pvalue <- 1 - pchisq(X2, df = df, ncp = ncp) |
| 190 |
} |
|
| 191 | ||
| 192 | 29x |
rmsea.pvalue |
| 193 |
} |
|
| 194 | ||
| 195 |
# MacCallum, R. C., Browne, M. W., & Sugawara, H. M. (1996). |
|
| 196 |
# H_0: RMSEA >= rmsea.h0 |
|
| 197 |
lav_fit_rmsea_notclosefit <- function(X2 = NULL, df = NULL, N = NULL, |
|
| 198 |
G = 1L, c.hat = 1, rmsea.h0 = 0.05) {
|
|
| 199 | 31x |
if (missing(N) || missing(X2) || missing(df) || |
| 200 | 31x |
!is.finite(X2) || !is.finite(df) || !is.finite(N)) {
|
| 201 | 2x |
return(as.numeric(NA)) |
| 202 |
} |
|
| 203 | ||
| 204 | 29x |
rmsea.pvalue <- as.numeric(NA) |
| 205 | 29x |
if (df > 0) {
|
| 206 |
# see Dudgeon 2004, eq 16 for the 'G' correction |
|
| 207 | 19x |
ncp <- (N * df * 1 / c.hat * rmsea.h0^2) / G |
| 208 | 19x |
rmsea.pvalue <- pchisq(X2, df = df, ncp = ncp) |
| 209 |
} |
|
| 210 | ||
| 211 | 29x |
rmsea.pvalue |
| 212 |
} |
|
| 213 | ||
| 214 | ||
| 215 |
lav_fit_rmsea_lavobject <- function(lavobject = NULL, fit.measures = "rmsea", |
|
| 216 |
standard.test = "standard", |
|
| 217 |
scaled.test = "none", |
|
| 218 |
ci.level = 0.90, |
|
| 219 |
close.h0 = 0.05, notclose.h0 = 0.08, |
|
| 220 |
robust = TRUE, |
|
| 221 |
cat.check.pd = TRUE) {
|
|
| 222 |
# check lavobject |
|
| 223 | 44x |
stopifnot(inherits(lavobject, "lavaan")) |
| 224 | ||
| 225 |
# check for categorical |
|
| 226 | 44x |
categorical.flag <- lavobject@Model@categorical |
| 227 | ||
| 228 |
# tests |
|
| 229 | 44x |
TEST <- lavobject@test |
| 230 | 44x |
test.names <- sapply(lavobject@test, "[[", "test") |
| 231 | 44x |
if (test.names[1] == "none" || standard.test == "none") {
|
| 232 | ! |
return(list()) |
| 233 |
} |
|
| 234 | 44x |
test.idx <- which(test.names == standard.test)[1] |
| 235 | 44x |
if (length(test.idx) == 0L) {
|
| 236 | ! |
return(list()) |
| 237 |
} |
|
| 238 | ||
| 239 | 44x |
scaled.flag <- FALSE |
| 240 | 44x |
if (!scaled.test %in% c("none", "standard", "default")) {
|
| 241 | 4x |
scaled.idx <- which(test.names == scaled.test) |
| 242 | 4x |
if (length(scaled.idx) > 0L) {
|
| 243 | 4x |
scaled.idx <- scaled.idx[1] # only the first one |
| 244 | 4x |
scaled.flag <- TRUE |
| 245 |
} |
|
| 246 |
} |
|
| 247 | ||
| 248 |
# robust? |
|
| 249 | 44x |
robust.flag <- FALSE |
| 250 | 44x |
if (robust && scaled.flag && |
| 251 | 44x |
scaled.test %in% c( |
| 252 | 44x |
"satorra.bentler", "yuan.bentler.mplus", |
| 253 | 44x |
"yuan.bentler", "scaled.shifted" |
| 254 |
)) {
|
|
| 255 | 4x |
robust.flag <- TRUE |
| 256 |
} |
|
| 257 | ||
| 258 |
# FIML? |
|
| 259 | 44x |
fiml.flag <- FALSE |
| 260 | 44x |
if (robust && lavobject@Options$missing %in% c("ml", "ml.x")) {
|
| 261 | 8x |
fiml.flag <- robust.flag <- TRUE |
| 262 |
# check if we can compute corrected values |
|
| 263 | 8x |
if (scaled.flag) {
|
| 264 | 2x |
version <- "V3" |
| 265 |
} else {
|
|
| 266 | 6x |
version <- "V6" |
| 267 |
} |
|
| 268 | 8x |
fiml <- try( |
| 269 | 8x |
lav_fit_fiml_corrected(lavobject, |
| 270 | 8x |
baseline.model = NULL, |
| 271 | 8x |
version = version |
| 272 |
), |
|
| 273 | 8x |
silent = TRUE |
| 274 |
) |
|
| 275 | 8x |
if (inherits(fiml, "try-error")) {
|
| 276 | ! |
lav_msg_warn(gettext("computation of robust RMSEA failed."))
|
| 277 | ! |
fiml <- list( |
| 278 | ! |
XX3 = as.numeric(NA), df3 = as.numeric(NA), |
| 279 | ! |
c.hat3 = as.numeric(NA), XX3.scaled = as.numeric(NA) |
| 280 |
) |
|
| 281 | 8x |
} else if (anyNA(c(fiml$XX3, fiml$df3, fiml$c.hat3, fiml$XX3.scaled))) {
|
| 282 | ! |
lav_msg_warn(gettext( |
| 283 | ! |
"computation of robust RMSEA resulted in NA values." |
| 284 |
)) |
|
| 285 |
} |
|
| 286 |
} |
|
| 287 | ||
| 288 |
# supported fit measures in this function |
|
| 289 | 44x |
fit.rmsea <- c( |
| 290 | 44x |
"rmsea", |
| 291 | 44x |
"rmsea.ci.lower", "rmsea.ci.upper", "rmsea.ci.level", |
| 292 | 44x |
"rmsea.pvalue", "rmsea.close.h0", |
| 293 | 44x |
"rmsea.notclose.pvalue", "rmsea.notclose.h0" |
| 294 |
) |
|
| 295 | 44x |
if (scaled.flag) {
|
| 296 | 4x |
fit.rmsea <- c( |
| 297 | 4x |
fit.rmsea, "rmsea.scaled", "rmsea.ci.lower.scaled", |
| 298 | 4x |
"rmsea.ci.upper.scaled", "rmsea.pvalue.scaled", |
| 299 | 4x |
"rmsea.notclose.pvalue.scaled" |
| 300 |
) |
|
| 301 |
} |
|
| 302 | 44x |
if (robust.flag) {
|
| 303 | 10x |
fit.rmsea <- c( |
| 304 | 10x |
fit.rmsea, "rmsea.robust", "rmsea.ci.lower.robust", |
| 305 | 10x |
"rmsea.ci.upper.robust", "rmsea.pvalue.robust", |
| 306 | 10x |
"rmsea.notclose.pvalue.robust" |
| 307 |
) |
|
| 308 |
} |
|
| 309 | ||
| 310 |
# which one do we need? |
|
| 311 | 44x |
if (missing(fit.measures)) {
|
| 312 |
# default set |
|
| 313 | ! |
fit.measures <- fit.rmsea |
| 314 |
} else {
|
|
| 315 |
# remove any not-RMSEA related index from fit.measures |
|
| 316 | 44x |
rm.idx <- which(!fit.measures %in% fit.rmsea) |
| 317 | 44x |
if (length(rm.idx) > 0L) {
|
| 318 | 44x |
fit.measures <- fit.measures[-rm.idx] |
| 319 |
} |
|
| 320 | 44x |
if (length(fit.measures) == 0L) {
|
| 321 | ! |
return(list()) |
| 322 |
} |
|
| 323 |
} |
|
| 324 | ||
| 325 | ||
| 326 |
# basic test statistics |
|
| 327 | 44x |
X2 <- TEST[[test.idx]]$stat |
| 328 | 44x |
df <- TEST[[test.idx]]$df |
| 329 | 44x |
G <- lavobject@Data@ngroups # number of groups |
| 330 | 44x |
N <- lav_object_inspect_ntotal(object = lavobject) # N vs N-1 |
| 331 | ||
| 332 |
# scaled X2/df values |
|
| 333 | 44x |
if (scaled.flag) {
|
| 334 | 4x |
if (scaled.test == "scaled.shifted") {
|
| 335 | 2x |
XX2 <- TEST[[scaled.idx]]$stat |
| 336 | 2x |
df2 <- df |
| 337 |
} else {
|
|
| 338 | 2x |
XX2 <- X2 |
| 339 | 2x |
df2 <- sum(TEST[[scaled.idx]]$trace.UGamma) |
| 340 | 2x |
if (!is.finite(df2) || df2 == 0) {
|
| 341 | 2x |
df2 <- as.numeric(NA) |
| 342 |
} |
|
| 343 |
} |
|
| 344 |
} |
|
| 345 | ||
| 346 |
# robust ingredients |
|
| 347 | 44x |
if (robust.flag) {
|
| 348 | 10x |
if (categorical.flag) {
|
| 349 | 2x |
out <- try(lav_fit_catml_dwls(lavobject, check.pd = cat.check.pd), |
| 350 | 2x |
silent = TRUE |
| 351 |
) |
|
| 352 | 2x |
if (inherits(out, "try-error")) {
|
| 353 | ! |
XX3 <- df3 <- c.hat3 <- XX3.scaled <- as.numeric(NA) |
| 354 |
} else {
|
|
| 355 | 2x |
XX3 <- out$XX3 |
| 356 | 2x |
df3 <- out$df3 |
| 357 | 2x |
c.hat3 <- c.hat <- out$c.hat3 |
| 358 | 2x |
XX3.scaled <- out$XX3.scaled |
| 359 |
} |
|
| 360 | 8x |
} else if (fiml.flag) {
|
| 361 | 8x |
XX3 <- fiml$XX3 |
| 362 | 8x |
df3 <- fiml$df3 |
| 363 | 8x |
c.hat3 <- c.hat <- fiml$c.hat3 |
| 364 | 8x |
XX3.scaled <- fiml$XX3.scaled |
| 365 |
} else {
|
|
| 366 | ! |
XX3 <- X2 |
| 367 | ! |
df3 <- df |
| 368 | ! |
c.hat <- TEST[[scaled.idx]]$scaling.factor |
| 369 | ! |
if (scaled.test == "scaled.shifted") {
|
| 370 |
# compute c.hat from a and b |
|
| 371 | ! |
a <- TEST[[scaled.idx]]$scaling.factor |
| 372 | ! |
b <- TEST[[scaled.idx]]$shift.parameter |
| 373 | ! |
c.hat3 <- a * (df - b) / df |
| 374 |
} else {
|
|
| 375 | ! |
c.hat3 <- c.hat |
| 376 |
} |
|
| 377 | ! |
XX3.scaled <- TEST[[scaled.idx]]$stat |
| 378 |
} |
|
| 379 |
} |
|
| 380 | ||
| 381 |
# output container |
|
| 382 | 44x |
indices <- list() |
| 383 | ||
| 384 |
# what do we need? |
|
| 385 | 44x |
rmsea.val.flag <- rmsea.ci.flag <- rmsea.pvalue.flag <- FALSE |
| 386 | 44x |
if (any(c("rmsea", "rmsea.scaled", "rmsea.robust") %in% fit.measures)) {
|
| 387 | 44x |
rmsea.val.flag <- TRUE |
| 388 |
} |
|
| 389 | 44x |
if (any(c( |
| 390 | 44x |
"rmsea.ci.lower", "rmsea.ci.upper", "rmsea.ci.level", |
| 391 | 44x |
"rmsea.ci.lower.scaled", "rmsea.ci.upper.scaled", |
| 392 | 44x |
"rmsea.ci.lower.robust", "rmsea.ci.upper.robust" |
| 393 |
) |
|
| 394 | 44x |
%in% fit.measures)) {
|
| 395 | 24x |
rmsea.ci.flag <- TRUE |
| 396 |
} |
|
| 397 | 44x |
if (any(c( |
| 398 | 44x |
"rmsea.pvalue", "rmsea.pvalue.scaled", "rmsea.pvalue.robust", |
| 399 | 44x |
"rmsea.notclose.pvalue", "rmsea.notclose.pvalue.scaled", |
| 400 | 44x |
"rmsea.notclose.pvalue.robust", |
| 401 | 44x |
"rmsea.close.h0", "rmsea.notclose.h0" |
| 402 |
) |
|
| 403 | 44x |
%in% fit.measures)) {
|
| 404 | 24x |
rmsea.pvalue.flag <- TRUE |
| 405 |
} |
|
| 406 | ||
| 407 | ||
| 408 |
# 1. RMSEA |
|
| 409 | 44x |
if (rmsea.val.flag) {
|
| 410 | 44x |
indices["rmsea"] <- lav_fit_rmsea(X2 = X2, df = df, N = N, G = G) |
| 411 | 44x |
if (scaled.flag) {
|
| 412 | 4x |
indices["rmsea.scaled"] <- lav_fit_rmsea( |
| 413 | 4x |
X2 = XX2, df = df2, |
| 414 | 4x |
N = N, G = G |
| 415 |
) |
|
| 416 |
} |
|
| 417 | 44x |
if (robust.flag) {
|
| 418 | 10x |
indices["rmsea.robust"] <- |
| 419 | 10x |
lav_fit_rmsea(X2 = XX3, df = df3, N = N, c.hat = c.hat3, G = G) |
| 420 |
} |
|
| 421 |
} |
|
| 422 | ||
| 423 |
# 2. RMSEA CI |
|
| 424 | 44x |
if (rmsea.ci.flag) {
|
| 425 | 24x |
indices["rmsea.ci.level"] <- ci.level |
| 426 | 24x |
ci <- lav_fit_rmsea_ci(X2 = X2, df = df, N = N, G = G, level = ci.level) |
| 427 | 24x |
indices["rmsea.ci.lower"] <- ci$rmsea.ci.lower |
| 428 | 24x |
indices["rmsea.ci.upper"] <- ci$rmsea.ci.upper |
| 429 | ||
| 430 | 24x |
if (scaled.flag) {
|
| 431 | 2x |
ci.scaled <- lav_fit_rmsea_ci( |
| 432 | 2x |
X2 = XX2, df = df2, N = N, G = G, |
| 433 | 2x |
level = ci.level |
| 434 |
) |
|
| 435 | 2x |
indices["rmsea.ci.lower.scaled"] <- ci.scaled$rmsea.ci.lower |
| 436 | 2x |
indices["rmsea.ci.upper.scaled"] <- ci.scaled$rmsea.ci.upper |
| 437 |
} |
|
| 438 | 24x |
if (robust.flag) {
|
| 439 |
# note: input is scaled test statistic! |
|
| 440 | 5x |
ci.robust <- lav_fit_rmsea_ci( |
| 441 | 5x |
X2 = XX3.scaled, |
| 442 | 5x |
df = df3, N = N, G = G, c.hat = c.hat, |
| 443 | 5x |
level = ci.level |
| 444 |
) |
|
| 445 | 5x |
indices["rmsea.ci.lower.robust"] <- ci.robust$rmsea.ci.lower |
| 446 | 5x |
indices["rmsea.ci.upper.robust"] <- ci.robust$rmsea.ci.upper |
| 447 |
} |
|
| 448 |
} |
|
| 449 | ||
| 450 |
# 3. RMSEA pvalue |
|
| 451 | 44x |
if (rmsea.pvalue.flag) {
|
| 452 | 24x |
indices["rmsea.close.h0"] <- close.h0 |
| 453 | 24x |
indices["rmsea.notclose.h0"] <- notclose.h0 |
| 454 | 24x |
indices["rmsea.pvalue"] <- |
| 455 | 24x |
lav_fit_rmsea_closefit( |
| 456 | 24x |
X2 = X2, df = df, N = N, G = G, |
| 457 | 24x |
rmsea.h0 = close.h0 |
| 458 |
) |
|
| 459 | 24x |
indices["rmsea.notclose.pvalue"] <- |
| 460 | 24x |
lav_fit_rmsea_notclosefit( |
| 461 | 24x |
X2 = X2, df = df, N = N, G = G, |
| 462 | 24x |
rmsea.h0 = notclose.h0 |
| 463 |
) |
|
| 464 | 24x |
if (scaled.flag) {
|
| 465 | 2x |
indices["rmsea.pvalue.scaled"] <- |
| 466 | 2x |
lav_fit_rmsea_closefit( |
| 467 | 2x |
X2 = XX2, df = df2, N = N, G = G, |
| 468 | 2x |
rmsea.h0 = close.h0 |
| 469 |
) |
|
| 470 | 2x |
indices["rmsea.notclose.pvalue.scaled"] <- |
| 471 | 2x |
lav_fit_rmsea_notclosefit( |
| 472 | 2x |
X2 = XX2, df = df2, N = N, G = G, |
| 473 | 2x |
rmsea.h0 = notclose.h0 |
| 474 |
) |
|
| 475 |
} |
|
| 476 | 24x |
if (robust.flag) {
|
| 477 | 5x |
indices["rmsea.pvalue.robust"] <- # new in 0.6-13 |
| 478 | 5x |
lav_fit_rmsea_closefit( |
| 479 | 5x |
X2 = XX3.scaled, |
| 480 | 5x |
df = df3, |
| 481 | 5x |
N = N, G = G, c.hat = c.hat, |
| 482 | 5x |
rmsea.h0 = close.h0 |
| 483 |
) |
|
| 484 | 5x |
indices["rmsea.notclose.pvalue.robust"] <- # new in 0.6-13 |
| 485 | 5x |
lav_fit_rmsea_notclosefit( |
| 486 | 5x |
X2 = XX3.scaled, |
| 487 | 5x |
df = df3, |
| 488 | 5x |
N = N, G = G, c.hat = c.hat, |
| 489 | 5x |
rmsea.h0 = notclose.h0 |
| 490 |
) |
|
| 491 |
} |
|
| 492 |
} |
|
| 493 | ||
| 494 |
# return only those that were requested |
|
| 495 | 44x |
indices[fit.measures] |
| 496 |
} |
| 1 |
# contributed by Myrsini Katsikatsou (March 2016) |
|
| 2 | ||
| 3 |
# the function lav_pml_bi_lik_x gives the value of the bivariate likelihood |
|
| 4 |
# for a specific pair of ordinal variables casewise when covariates are present and estimator=="PML" |
|
| 5 |
# (the bivariate likelihood is essentially the bivariate probability of the |
|
| 6 |
# observed response pattern of two ordinal variables) |
|
| 7 | ||
| 8 |
# Input arguments: |
|
| 9 |
# Y1 is a vector, includes the observed values for the first variable for all cases/units, |
|
| 10 |
# Y1 is ordinal |
|
| 11 |
# Y2 similar to Y1 |
|
| 12 |
# Rho is the polychoric correlation of Y1 and Y2 |
|
| 13 |
# th.y1 is the vector of the thresholds for Y1* excluding the first and |
|
| 14 |
# the last thresholds which are -Inf and Inf |
|
| 15 |
# th.y2 is similar to th.y1 |
|
| 16 |
# eXo is the data for the covariates in a matrix format where nrows= no of cases, |
|
| 17 |
# ncols= no of covariates |
|
| 18 |
# PI.y1 is a vector, includes the regression coefficients of the covariates |
|
| 19 |
# for the first variable, Y1, the length of the vector is the no of covariates; |
|
| 20 |
# to obtain this vector apply the function lavaan:::lav_model_pi()[row_correspondin_to_Y1, ] |
|
| 21 |
# PI.y2 is similar to PI.y2 |
|
| 22 |
# missing.ind is of "character" value, taking the values listwise, pairwise, available_cases; |
|
| 23 |
# to obtain a value use lavdata@missing |
|
| 24 | ||
| 25 |
# Output: |
|
| 26 |
# It is a vector, length= no of cases, giving the bivariate likelihood for each case. |
|
| 27 |
lav_pml_bi_lik_x <- function(Y1, Y2, Rho, |
|
| 28 |
th.y1, th.y2, |
|
| 29 |
eXo, |
|
| 30 |
PI.y1, PI.y2, |
|
| 31 |
missing.ind) {
|
|
| 32 | ! |
th.y1 <- c(-100, th.y1, 100) |
| 33 | ! |
th.y2 <- c(-100, th.y2, 100) |
| 34 | ! |
pred.y1 <- c(eXo %*% PI.y1) |
| 35 | ! |
pred.y2 <- c(eXo %*% PI.y2) |
| 36 | ||
| 37 | ! |
th.y1.upper <- th.y1[Y1 + 1L] - pred.y1 |
| 38 | ! |
th.y1.lower <- th.y1[Y1] - pred.y1 |
| 39 | ! |
th.y2.upper <- th.y2[Y2 + 1L] - pred.y2 |
| 40 | ! |
th.y2.lower <- th.y2[Y2] - pred.y2 |
| 41 | ||
| 42 | ! |
if (missing.ind == "listwise") { # I guess this is the default which
|
| 43 |
# also handles the case of complete data |
|
| 44 | ! |
biv_prob <- pbivnorm(th.y1.upper, th.y2.upper, rho = Rho) - |
| 45 | ! |
pbivnorm(th.y1.lower, th.y2.upper, rho = Rho) - |
| 46 | ! |
pbivnorm(th.y1.upper, th.y2.lower, rho = Rho) + |
| 47 | ! |
pbivnorm(th.y1.lower, th.y2.lower, rho = Rho) |
| 48 | ! |
lik <- biv_prob |
| 49 | ! |
} else if (missing.ind %in% c( |
| 50 | ! |
"pairwise", |
| 51 | ! |
"available.cases", |
| 52 | ! |
"available_cases" |
| 53 |
)) {
|
|
| 54 |
# index of cases with complete pairs |
|
| 55 | ! |
CP.idx <- which(complete.cases(cbind(Y1, Y2))) |
| 56 | ||
| 57 | ! |
th.y1.upper <- th.y1.upper[CP.idx] |
| 58 | ! |
th.y1.lower <- th.y1.lower[CP.idx] |
| 59 | ! |
th.y2.upper <- th.y2.upper[CP.idx] |
| 60 | ! |
th.y2.lower <- th.y2.lower[CP.idx] |
| 61 | ||
| 62 | ! |
biv_prob <- pbivnorm(th.y1.upper, th.y2.upper, rho = Rho) - |
| 63 | ! |
pbivnorm(th.y1.lower, th.y2.upper, rho = Rho) - |
| 64 | ! |
pbivnorm(th.y1.upper, th.y2.lower, rho = Rho) + |
| 65 | ! |
pbivnorm(th.y1.lower, th.y2.lower, rho = Rho) |
| 66 | ||
| 67 |
# lik <- numeric( length(Y1) ) |
|
| 68 | ! |
lik <- rep(as.numeric(NA), length(Y1)) |
| 69 | ! |
lik[CP.idx] <- biv_prob |
| 70 |
} |
|
| 71 | ! |
lik |
| 72 |
} |
|
| 73 | ||
| 74 |
################################################################# |
|
| 75 | ||
| 76 | ||
| 77 |
# The function lav_pml_uni_lik gives the value of the univariate likelihood for a |
|
| 78 |
# specific ordinal variable, casewise (which is essentially the probability for |
|
| 79 |
# the observed response category for each case). |
|
| 80 |
# The input arguments are explained before the function lav_pml_bi_lik_x above. |
|
| 81 |
# Output: |
|
| 82 |
# It is a vector, length= no of cases, giving the univariate likelihoods for each case. |
|
| 83 | ||
| 84 |
lav_pml_uni_lik <- function(Y1, th.y1, eXo = NULL, PI.y1 = NULL) {
|
|
| 85 | ! |
th.y1 <- c(-100, th.y1, 100) |
| 86 | ! |
if (!is.null(eXo)) {
|
| 87 | ! |
pred.y1 <- c(eXo %*% PI.y1) |
| 88 |
} |
|
| 89 | ||
| 90 | ! |
if (is.null(eXo)) {
|
| 91 | ! |
th.y1.upper <- th.y1[Y1 + 1L] |
| 92 | ! |
th.y1.lower <- th.y1[Y1] |
| 93 |
} else {
|
|
| 94 | ! |
th.y1.upper <- th.y1[Y1 + 1L] - pred.y1 |
| 95 | ! |
th.y1.lower <- th.y1[Y1] - pred.y1 |
| 96 |
} |
|
| 97 | ||
| 98 | ! |
lav_pml_uni_lik <- pnorm(th.y1.upper) - pnorm(th.y1.lower) |
| 99 | ||
| 100 | ! |
lav_pml_uni_lik[is.na(lav_pml_uni_lik)] <- 0 |
| 101 | ||
| 102 | ! |
lav_pml_uni_lik |
| 103 |
} |
|
| 104 | ||
| 105 |
################################################################# |
|
| 106 | ||
| 107 |
# The function lav_pml_th_uni_prob gives the model-based univariate probabilities |
|
| 108 |
# for all ordinal indicators and for all of their response categories, i.e. pi(xi=a), where |
|
| 109 |
# a=1,...,ci and i=1,...,p with a index running faster than i index. |
|
| 110 |
# Input arguments: |
|
| 111 |
# TH is a vector giving the thresholds for all variables, tau_ia, with a running |
|
| 112 |
# faster than i (the first and the last thresholds which are -Inf and Inf are |
|
| 113 |
# not included). TH can be given by the lavaan function lav_model_th . |
|
| 114 |
# th.idx is a vector of same length as TH which gives the value of the i index, |
|
| 115 |
# namely which variable each thresholds refers to. This can be obtained by |
|
| 116 |
# lavmodel@th.idx . |
|
| 117 |
# Output: |
|
| 118 |
# It is a vector, lenght= Sum_i(ci), i.e. the sum of the response categories of |
|
| 119 |
# all ordinal variables. The vector contains the model-based univariate probabilities pi(xi=a). |
|
| 120 | ||
| 121 |
lav_pml_th_uni_prob <- function(TH = TH, th.idx = th.idx) {
|
|
| 122 | ! |
TH.split <- split(TH, th.idx) |
| 123 | ! |
TH.lower <- unlist(lapply(TH.split, function(x) {
|
| 124 | ! |
c(-100, x) |
| 125 | ! |
}), use.names = FALSE) |
| 126 | ! |
TH.upper <- unlist(lapply(TH.split, function(x) {
|
| 127 | ! |
c(x, 100) |
| 128 | ! |
}), use.names = FALSE) |
| 129 | ! |
prob <- pnorm(TH.upper) - pnorm(TH.lower) |
| 130 |
# to avoid Nan/-Inf |
|
| 131 | ! |
prob[prob < .Machine$double.eps] <- .Machine$double.eps |
| 132 | ! |
prob |
| 133 |
} |
|
| 134 | ||
| 135 |
############################################################################# |
|
| 136 | ||
| 137 | ||
| 138 |
# The function lav_pml_dbilogl_dpar_x computes the derivatives of a bivariate |
|
| 139 |
# log-likelihood of two ordinal variables casewise with respect to thresholds, |
|
| 140 |
# slopes (reduced-form regression coefficients for the covariates), and polychoric correlation. |
|
| 141 |
# The function lav_dbinorm of lavaan is used. |
|
| 142 |
# The function gives the right result for both listwise and pairwise deletion, |
|
| 143 |
# and the case of complete data. |
|
| 144 |
# Input arguments are explained before the function lav_pml_bi_lik_x defined above. |
|
| 145 |
# The only difference is that PI.y1 and PI.y2 are (accidentally) renamed here as sl.y1 and sl.y2 |
|
| 146 |
# Output: |
|
| 147 |
# It is a list containing the following |
|
| 148 |
# a) the derivatives w.r.t. the thresholds of the first variable casewise. |
|
| 149 |
# This is a matrix, nrows=no of cases, ncols= no of thresholds of variable 1. |
|
| 150 |
# b) the derivatives w.r.t. the thresholds of the second variable casewise. |
|
| 151 |
# This is a matrix, nrows=no of cases, ncols= no of thresholds of variable 2. |
|
| 152 |
# c) the derivatives w.r.t slopes for variable 1. This is a matrix, where |
|
| 153 |
# nrows=no of cases, ncols= no of covariates. |
|
| 154 |
# d) the derivatives w.r.t slopes for variable 2. This is a matrix, where |
|
| 155 |
# nrows=no of cases, ncols= no of covariates. |
|
| 156 |
# e) the derivative w.r.t the polychoric correlation of the two variables. |
|
| 157 |
# This is a vector of length= no of cases. |
|
| 158 | ||
| 159 | ||
| 160 |
lav_pml_dbilogl_dpar_x <- function(Y1, Y2, eXo, Rho, |
|
| 161 |
th.y1, th.y2, |
|
| 162 |
sl.y1, sl.y2, |
|
| 163 |
missing.ind) {
|
|
| 164 | ! |
nth.y1 <- length(th.y1) |
| 165 | ! |
nth.y2 <- length(th.y2) |
| 166 | ||
| 167 | ! |
start.th.y1 <- th.y1 |
| 168 | ! |
start.th.y2 <- th.y2 |
| 169 | ||
| 170 | ! |
Nobs <- length(Y1) |
| 171 | ||
| 172 | ! |
R <- sqrt(1 - Rho * Rho) |
| 173 | ! |
th.y1 <- c(-100, th.y1, 100) |
| 174 | ! |
th.y2 <- c(-100, th.y2, 100) |
| 175 | ! |
pred.y1 <- c(eXo %*% sl.y1) |
| 176 | ! |
pred.y2 <- c(eXo %*% sl.y2) |
| 177 | ||
| 178 | ! |
th.y1.z1 <- th.y1[Y1 + 1L] - pred.y1 |
| 179 | ! |
th.y1.z2 <- th.y1[Y1] - pred.y1 |
| 180 | ! |
th.y2.z1 <- th.y2[Y2 + 1L] - pred.y2 |
| 181 | ! |
th.y2.z2 <- th.y2[Y2] - pred.y2 |
| 182 | ||
| 183 |
# lik, i.e. the bivariate probability case-wise |
|
| 184 | ! |
lik <- lav_pml_bi_lik_x( |
| 185 | ! |
Y1 = Y1, Y2 = Y2, |
| 186 | ! |
Rho = Rho, |
| 187 | ! |
th.y1 = start.th.y1, |
| 188 | ! |
th.y2 = start.th.y2, |
| 189 | ! |
eXo = eXo, |
| 190 | ! |
PI.y1 = sl.y1, |
| 191 | ! |
PI.y2 = sl.y2, |
| 192 | ! |
missing.ind = missing.ind |
| 193 |
) |
|
| 194 | ||
| 195 | ||
| 196 |
# w.r.t. th.y1, mean tau tilde |
|
| 197 |
# derivarive bivariate prob w.r.t. tau^xi_ci, see formula in paper 2012 |
|
| 198 | ! |
y1.Z1 <- dnorm(th.y1.z1) * (pnorm((th.y2.z1 - Rho * th.y1.z1) / R) - |
| 199 | ! |
pnorm((th.y2.z2 - Rho * th.y1.z1) / R)) |
| 200 |
# derivarive bivariate prob w.r.t. tau^xi_(ci-1), |
|
| 201 | ! |
y1.Z2 <- (-1) * (dnorm(th.y1.z2) * (pnorm((th.y2.z1 - Rho * th.y1.z2) / R) - |
| 202 | ! |
pnorm((th.y2.z2 - Rho * th.y1.z2) / R))) |
| 203 | ||
| 204 | ||
| 205 |
# allocate the derivatives at the right column casewise |
|
| 206 | ! |
idx.y1.z1 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == Y1 |
| 207 | ! |
idx.y1.z2 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == (Y1 - 1L) |
| 208 | ! |
der.table.y1 <- idx.y1.z1 * y1.Z1 + idx.y1.z2 * y1.Z2 |
| 209 | ||
| 210 |
# der of pl w.r.t. th.y1 |
|
| 211 | ! |
dx.th.tilde.y1 <- der.table.y1 / lik |
| 212 | ! |
dx.th.tilde.y1[is.na(dx.th.tilde.y1)] <- 0 |
| 213 | ||
| 214 |
# w.r.t. th.y2, mean tau tilde |
|
| 215 |
# derivarive bivariate prob w.r.t. tau^xi_ci, see formula in paper 2012 |
|
| 216 | ! |
y2.Z1 <- dnorm(th.y2.z1) * (pnorm((th.y1.z1 - Rho * th.y2.z1) / R) - |
| 217 | ! |
pnorm((th.y1.z2 - Rho * th.y2.z1) / R)) |
| 218 |
# derivarive bivariate prob w.r.t. tau^xi_(ci-1), |
|
| 219 | ! |
y2.Z2 <- (-1) * (dnorm(th.y2.z2) * (pnorm((th.y1.z1 - Rho * th.y2.z2) / R) - |
| 220 | ! |
pnorm((th.y1.z2 - Rho * th.y2.z2) / R))) |
| 221 |
# allocate the derivatives at the right column casewise |
|
| 222 | ! |
idx.y2.z1 <- matrix(1:nth.y2, nrow = Nobs, ncol = nth.y2, byrow = TRUE) == Y2 |
| 223 | ! |
idx.y2.z2 <- matrix(1:nth.y2, nrow = Nobs, ncol = nth.y2, byrow = TRUE) == (Y2 - 1L) |
| 224 | ! |
der.table.y2 <- idx.y2.z1 * y2.Z1 + idx.y2.z2 * y2.Z2 |
| 225 | ||
| 226 |
# der of pl w.r.t. th.y2 |
|
| 227 | ! |
dx.th.tilde.y2 <- der.table.y2 / lik |
| 228 | ! |
dx.th.tilde.y2[is.na(dx.th.tilde.y2)] <- 0 |
| 229 | ||
| 230 | ||
| 231 | ||
| 232 |
# w.r.t. rho |
|
| 233 |
# derivarive bivariate prob w.r.t. rho, see formula in paper 2012 |
|
| 234 | ! |
dbivprob.wrt.rho <- (lav_dbinorm(th.y1.z1, th.y2.z1, Rho) - |
| 235 | ! |
lav_dbinorm(th.y1.z2, th.y2.z1, Rho) - |
| 236 | ! |
lav_dbinorm(th.y1.z1, th.y2.z2, Rho) + |
| 237 | ! |
lav_dbinorm(th.y1.z2, th.y2.z2, Rho)) |
| 238 |
# der of pl w.r.t. rho |
|
| 239 | ! |
dx.rho <- dbivprob.wrt.rho / lik |
| 240 | ! |
dx.rho[is.na(dx.rho)] <- 0 |
| 241 | ||
| 242 | ||
| 243 |
# der of pl w.r.t. slopes (also referred to PI obtained by lav_model_pi function) |
|
| 244 | ! |
row.sums.y1 <- rowSums(dx.th.tilde.y1) |
| 245 | ! |
row.sums.y2 <- rowSums(dx.th.tilde.y2) |
| 246 | ! |
dx.sl.y1 <- (-1) * eXo * row.sums.y1 |
| 247 | ! |
dx.sl.y2 <- (-1) * eXo * row.sums.y2 |
| 248 | ||
| 249 | ||
| 250 | ! |
list( |
| 251 | ! |
dx.th.y1 = dx.th.tilde.y1, # note that dx.th.tilde=dx.th |
| 252 | ! |
dx.th.y2 = dx.th.tilde.y2, |
| 253 | ! |
dx.sl.y1 = dx.sl.y1, |
| 254 | ! |
dx.sl.y2 = dx.sl.y2, |
| 255 | ! |
dx.rho = dx.rho |
| 256 |
) |
|
| 257 |
} |
|
| 258 | ||
| 259 |
############################################################### |
|
| 260 | ||
| 261 | ||
| 262 |
# The function lav_pml_uni_scores gives, casewise, the derivative of a univariate |
|
| 263 |
# log-likelihood w.r.t. thresholds and slopes if present weighted by the |
|
| 264 |
# casewise uni-weights as those defined in AC-PL (essentially the number of missing values per case). |
|
| 265 |
# The function closely follows the "logic" of the function lav_pml_dbilogl_dpar_x defined above. |
|
| 266 |
# Input arguments are as before plus: weights.casewise given by |
|
| 267 |
# lavcavhe$uniweights.casewise . |
|
| 268 |
# Output: |
|
| 269 |
# A list including the following: |
|
| 270 |
# a) the derivatives w.r.t. the thresholds of the variable. This is a matrix, |
|
| 271 |
# nrows=no of cases, ncols= no of thresholds of variable 1. |
|
| 272 |
# b) the derivatives w.r.t slopes for the variable. If covariates are present, |
|
| 273 |
# this is a matrix, nrows=no of cases, ncols= no of covariates. |
|
| 274 |
# Otherwise it takes the value NULL. |
|
| 275 | ||
| 276 | ||
| 277 |
lav_pml_uni_scores <- function(Y1, th.y1, eXo = NULL, sl.y1 = NULL, |
|
| 278 |
weights.casewise) {
|
|
| 279 | ! |
nth.y1 <- length(th.y1) |
| 280 | ! |
start.th.y1 <- th.y1 |
| 281 | ! |
Nobs <- length(Y1) |
| 282 | ! |
th.y1 <- c(-100, th.y1, 100) |
| 283 | ||
| 284 | ! |
if (is.null(eXo)) {
|
| 285 | ! |
th.y1.z1 <- th.y1[Y1 + 1L] |
| 286 | ! |
th.y1.z2 <- th.y1[Y1] |
| 287 |
} else {
|
|
| 288 | ! |
pred.y1 <- c(eXo %*% sl.y1) |
| 289 | ! |
th.y1.z1 <- th.y1[Y1 + 1L] - pred.y1 |
| 290 | ! |
th.y1.z2 <- th.y1[Y1] - pred.y1 |
| 291 |
} |
|
| 292 | ||
| 293 |
# lik, i.e. the univariate probability case-wise |
|
| 294 | ! |
lik <- lav_pml_uni_lik( # Y1 = X[,i], |
| 295 | ! |
Y1 = Y1, |
| 296 |
# th.y1 = TH[th.idx==i], |
|
| 297 | ! |
th.y1 = th.y1, |
| 298 | ! |
eXo = eXo, |
| 299 |
# PI.y1 = PI[i,]) |
|
| 300 | ! |
PI.y1 = sl.y1 |
| 301 |
) |
|
| 302 | ||
| 303 |
# w.r.t. th.y1 |
|
| 304 |
# derivarive of the univariate prob w.r.t. to the upper limit threshold |
|
| 305 | ! |
y1.Z1 <- dnorm(th.y1.z1) |
| 306 |
# derivarive of the univariate prob w.r.t. to the lower limit threshold |
|
| 307 | ! |
y1.Z2 <- (-1) * dnorm(th.y1.z2) |
| 308 | ||
| 309 |
# allocate the derivatives at the right column casewise |
|
| 310 | ! |
idx.y1.z1 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == Y1 |
| 311 | ! |
idx.y1.z2 <- matrix(1:nth.y1, nrow = Nobs, ncol = nth.y1, byrow = TRUE) == (Y1 - 1L) |
| 312 | ! |
der.table.y1 <- idx.y1.z1 * y1.Z1 + idx.y1.z2 * y1.Z2 |
| 313 | ||
| 314 |
# der of pl w.r.t. th.y1 |
|
| 315 | ! |
dx.th.tilde.y1 <- der.table.y1 * (weights.casewise / lik) |
| 316 | ! |
dx.th.tilde.y1[is.na(dx.th.tilde.y1)] <- 0 |
| 317 | ||
| 318 |
# der of pl w.r.t. slopes (also referred to PI obtained by lav_model_pi function) |
|
| 319 | ! |
dx.sl.y1 <- NULL |
| 320 | ! |
if (!is.null(eXo)) {
|
| 321 | ! |
row.sums.y1 <- rowSums(dx.th.tilde.y1) |
| 322 | ! |
dx.sl.y1 <- (-1) * eXo * row.sums.y1 |
| 323 |
} |
|
| 324 | ||
| 325 | ! |
list( |
| 326 | ! |
dx.th.y1 = dx.th.tilde.y1, # note that dx.th.tilde=dx.th |
| 327 | ! |
dx.sl.y1 = dx.sl.y1 |
| 328 |
) |
|
| 329 |
} |
| 1 |
# a partial implementation of the Bentler (1982) non-iterative method for CFA |
|
| 2 |
# |
|
| 3 |
# Bentler, P. M. (1982). Confirmatory factor-analysis via noniterative |
|
| 4 |
# estimation - a fast, inexpensive method. Journal of Marketing Research, |
|
| 5 |
# 19(4), 417-424. https://doi.org/10.1177/002224378201900403 |
|
| 6 |
# |
|
| 7 |
# |
|
| 8 |
# YR 03 Feb 2023: - first version in lavaan: simple setting only, |
|
| 9 |
# no constraints, no 'fixed' (but nonzero) values, |
|
| 10 |
# no correlated residuals (ie diagonal-theta only!) |
|
| 11 |
# YR 23 Apr 2023: - quadprog is not needed if we have no (in)equality |
|
| 12 |
# constraints |
|
| 13 | ||
| 14 |
lav_cfa_bentler1982 <- function(S, |
|
| 15 |
marker.idx = NULL, |
|
| 16 |
lambda.nonzero.idx = NULL, |
|
| 17 |
GLS = FALSE, |
|
| 18 |
bounds = TRUE, |
|
| 19 |
min.reliability.marker = 0.1, |
|
| 20 |
quadprog = FALSE, |
|
| 21 |
nobs = 20L) { # for cutoff
|
|
| 22 |
# dimensions |
|
| 23 | ! |
nvar <- ncol(S) |
| 24 | ! |
nfac <- length(marker.idx) |
| 25 | ||
| 26 |
# lambda structure |
|
| 27 | ! |
B <- matrix(0, nvar, nfac) |
| 28 | ! |
lambda.marker.idx <- (seq_len(nfac) - 1L) * nvar + marker.idx |
| 29 | ! |
B[lambda.marker.idx] <- 1L |
| 30 | ! |
B[lambda.nonzero.idx] <- 1L |
| 31 | ||
| 32 |
# partition sample covariance matrix: marker vs non-marker |
|
| 33 | ! |
S.xx <- S[marker.idx, marker.idx, drop = FALSE] |
| 34 | ! |
S.yx <- S[-marker.idx, marker.idx, drop = FALSE] |
| 35 | ! |
S.xy <- S[marker.idx, -marker.idx, drop = FALSE] |
| 36 | ! |
S.yy <- S[-marker.idx, -marker.idx, drop = FALSE] |
| 37 | ! |
p <- nvar - nfac |
| 38 | ! |
B.y <- B[-marker.idx, , drop = FALSE] |
| 39 | ||
| 40 |
# check for p = 0? |
|
| 41 | ||
| 42 |
# phase 1: initial estimate for Sigma.yx |
|
| 43 | ! |
Sigma.yx.hat <- S.yx |
| 44 | ||
| 45 |
# phase 2: using GLS/ULS to obtain PSI and Theta |
|
| 46 | ! |
if (GLS) {
|
| 47 | ! |
W <- try(solve(S.yy), silent = TRUE) |
| 48 | ! |
if (inherits(W, "try-error")) {
|
| 49 | ! |
lav_msg_warn(gettext("could not inverte S.yy; switching to ULS"))
|
| 50 | ! |
W <- diag(p) |
| 51 |
} |
|
| 52 | ! |
WS.yx <- W %*% S.yx |
| 53 | ! |
xy.SWS.yx <- crossprod(S.yx, WS.yx) |
| 54 | ! |
G <- WS.yx %*% solve(xy.SWS.yx) %*% t(WS.yx) |
| 55 |
} else {
|
|
| 56 | ! |
Ip <- diag(p) |
| 57 | ! |
xy.SS.yx <- crossprod(S.yx) |
| 58 | ! |
G <- S.yx %*% solve(xy.SS.yx) %*% t(S.yx) |
| 59 |
} |
|
| 60 | ||
| 61 |
# only needed if theta.y is not diagonal: |
|
| 62 |
# q <- 6 # all free |
|
| 63 |
# # dimension P: q x p*p where q is the number of free elements theta.y |
|
| 64 |
# theta.fy <- function(x) {
|
|
| 65 |
# theta.y <- matrix(0, p, p) |
|
| 66 |
# # insert 'free' parameters only |
|
| 67 |
# diag(theta.y) <- x |
|
| 68 |
# lav_matrix_vec(theta.y) |
|
| 69 |
# } |
|
| 70 |
# P <- t(numDeriv::jacobian(func = theta.fy, x = rep(1, q))) |
|
| 71 | ||
| 72 |
# tmp1 <- P %*% ((W %x% W) - (G %x% G)) %*% t(P) |
|
| 73 |
# NOTE: |
|
| 74 |
# if only the 'diagonal' element of Theta are free (as usual), then we |
|
| 75 |
# can write tmp1 as |
|
| 76 | ! |
if (GLS) {
|
| 77 | ! |
tmp1 <- W * W - G * G |
| 78 |
} else {
|
|
| 79 | ! |
tmp1 <- Ip - G * G |
| 80 |
} |
|
| 81 | ||
| 82 |
# only needed if fixed values |
|
| 83 |
# Theta.F <- matrix(0, p, p) # all free |
|
| 84 |
# tmp2 <- W %*% (S.yy - Theta.F) %*% W - G %*% (S.yy - Theta.F) %*% G |
|
| 85 | ! |
if (GLS) {
|
| 86 | ! |
tmp2 <- W %*% S.yy %*% W - G %*% S.yy %*% G |
| 87 |
} else {
|
|
| 88 | ! |
tmp2 <- S.yy - G %*% S.yy %*% G |
| 89 |
} |
|
| 90 | ||
| 91 |
# Theta.f <- as.numeric(solve(tmp1) %*% P %*% lav_matrix_vec(tmp2)) |
|
| 92 |
# Note: |
|
| 93 |
# if only the 'diagonal' element of Theta are free (as usual), then we |
|
| 94 |
# can write Theta.f as |
|
| 95 | ! |
Theta.f <- solve(tmp1, diag(tmp2)) |
| 96 | ! |
Theta.f.nobounds <- Theta.f # store unbounded Theta.f values |
| 97 | ||
| 98 |
# ALWAYS apply standard bounds to proceed |
|
| 99 | ! |
too.small.idx <- which(Theta.f < 0) |
| 100 | ! |
if (length(too.small.idx) > 0L) {
|
| 101 | ! |
Theta.f[too.small.idx] <- 0 |
| 102 |
} |
|
| 103 | ! |
too.large.idx <- which(Theta.f > diag(S.yy)) |
| 104 | ! |
if (length(too.large.idx) > 0L) {
|
| 105 | ! |
Theta.f[too.large.idx] <- diag(S.yy)[too.large.idx] * 1 |
| 106 |
} |
|
| 107 | ||
| 108 |
# create diagonal matrix with Theta.f elements on diagonal |
|
| 109 | ! |
Theta.yhat <- diag(Theta.f, p) |
| 110 | ||
| 111 |
# force (S.yy - Theta.yhat) to be positive definite |
|
| 112 | ! |
lambda <- try(lav_matrix_symmetric_diff_smallest_root(S.yy, Theta.yhat), |
| 113 | ! |
silent = TRUE |
| 114 |
) |
|
| 115 | ! |
if (inherits(lambda, "try-error")) {
|
| 116 | ! |
lav_msg_warn(gettext("failed to compute lambda"))
|
| 117 | ! |
SminTheta <- S.yy - Theta.yhat # and hope for the best |
| 118 |
} else {
|
|
| 119 | ! |
cutoff <- 1 + 1 / (nobs - 1) |
| 120 | ! |
if (lambda < cutoff) {
|
| 121 | ! |
lambda.star <- lambda - 1 / (nobs - 1) |
| 122 | ! |
SminTheta <- S.yy - lambda.star * Theta.yhat |
| 123 |
} else {
|
|
| 124 | ! |
SminTheta <- S.yy - Theta.yhat |
| 125 |
} |
|
| 126 |
} |
|
| 127 | ||
| 128 |
# estimate Phi |
|
| 129 | ! |
if (GLS) {
|
| 130 | ! |
tmp1 <- xy.SWS.yx |
| 131 | ! |
tmp2 <- t(WS.yx) %*% SminTheta %*% WS.yx |
| 132 |
} else {
|
|
| 133 | ! |
tmp1 <- xy.SS.yx |
| 134 | ! |
tmp2 <- t(S.yx) %*% SminTheta %*% S.yx |
| 135 |
} |
|
| 136 | ! |
PSI <- tmp1 %*% solve(tmp2, tmp1) |
| 137 | ! |
PSI.nobounds <- PSI |
| 138 | ||
| 139 |
# ALWAYS apply bounds to proceed |
|
| 140 | ! |
lower.bounds.psi <- diag(S.xx) - (1 - min.reliability.marker) * diag(S.xx) |
| 141 | ! |
toolow.idx <- which(diag(PSI) < lower.bounds.psi) |
| 142 | ! |
if (length(toolow.idx) > 0L) {
|
| 143 | ! |
diag(PSI)[toolow.idx] <- lower.bounds.psi[toolow.idx] |
| 144 |
} |
|
| 145 | ! |
too.large.idx <- which(diag(PSI) > diag(S.xx)) |
| 146 | ! |
if (length(too.large.idx) > 0L) {
|
| 147 | ! |
diag(PSI)[too.large.idx] <- diag(S.xx)[too.large.idx] * 1 |
| 148 |
} |
|
| 149 | ||
| 150 |
# in addition, force PSI to be PD |
|
| 151 | ! |
PSI <- lav_matrix_symmetric_force_pd(PSI, tol = 1e-04) |
| 152 | ||
| 153 |
# residual variances markers |
|
| 154 | ! |
Theta.x <- diag(S.xx - PSI) |
| 155 | ||
| 156 |
# create theta vector |
|
| 157 | ! |
theta.nobounds <- numeric(nvar) |
| 158 | ! |
theta.nobounds[marker.idx] <- Theta.x |
| 159 | ! |
theta.nobounds[-marker.idx] <- Theta.f.nobounds |
| 160 | ||
| 161 |
# compute LAMBDA for non-marker items |
|
| 162 | ||
| 163 | ! |
if (quadprog) {
|
| 164 |
# only really needed if we need to impose (in)equality constraints |
|
| 165 |
# (TODO) |
|
| 166 | ! |
Dmat <- lav_matrix_bdiag(rep(list(PSI), p)) |
| 167 | ! |
dvec <- as.vector(t(S.yx)) |
| 168 | ! |
eq.idx <- which(t(B.y) != 1) # these must be zero (row-wise!) |
| 169 | ! |
Rmat <- diag(nrow(Dmat))[eq.idx, , drop = FALSE] |
| 170 | ! |
bvec <- rep(0, length(eq.idx)) # optional, 0=default |
| 171 | ! |
out <- try(quadprog::solve.QP( |
| 172 | ! |
Dmat = Dmat, dvec = dvec, Amat = t(Rmat), |
| 173 | ! |
meq = length(eq.idx), bvec = bvec |
| 174 | ! |
), silent = TRUE) |
| 175 | ! |
if (inherits(out, "try-error")) {
|
| 176 | ! |
lav_msg_warn(gettext("solve.QP failed to find a solution"))
|
| 177 | ! |
Lambda <- matrix(0, nvar, nfac) |
| 178 | ! |
Lambda[marker.idx, ] <- diag(nfac) |
| 179 | ! |
Lambda[lambda.nonzero.idx] <- as.numeric(NA) |
| 180 | ! |
Theta <- numeric(nvar) |
| 181 | ! |
Theta[marker.idx] <- Theta.x |
| 182 | ! |
Theta[-marker.idx] <- Theta.f |
| 183 | ! |
Psi <- PSI |
| 184 | ! |
return(list( |
| 185 | ! |
lambda = Lambda, theta = theta.nobounds, |
| 186 | ! |
psi = PSI.nobounds |
| 187 |
)) |
|
| 188 |
} else {
|
|
| 189 | ! |
LAMBDA.y <- matrix(out$solution, |
| 190 | ! |
nrow = p, ncol = nfac, |
| 191 | ! |
byrow = TRUE |
| 192 |
) |
|
| 193 |
# zap almost zero elements |
|
| 194 | ! |
LAMBDA.y[abs(LAMBDA.y) < sqrt(.Machine$double.eps)] <- 0 |
| 195 |
} |
|
| 196 |
} else {
|
|
| 197 |
# simple version |
|
| 198 |
#LAMBDA.y <- t(t(S.yx) / diag(PSI)) * B.y # works only if no crossloadings |
|
| 199 | ! |
LAMBDA.y <- t(solve(PSI, t(S.yx))) * B.y |
| 200 |
} |
|
| 201 | ||
| 202 | ||
| 203 |
# assemble matrices |
|
| 204 | ! |
LAMBDA <- matrix(0, nvar, nfac) |
| 205 | ! |
LAMBDA[marker.idx, ] <- diag(nfac) |
| 206 | ! |
LAMBDA[-marker.idx, ] <- LAMBDA.y |
| 207 | ||
| 208 | ! |
list(lambda = LAMBDA, theta = theta.nobounds, psi = PSI.nobounds) |
| 209 |
} |
|
| 210 | ||
| 211 |
# internal function to be used inside lav_optim_noniter |
|
| 212 |
# return 'x', the estimated vector of free parameters |
|
| 213 |
lav_cfa_bentler1982_internal <- function(lavobject = NULL, # convenience |
|
| 214 |
# internal slot |
|
| 215 |
lavmodel = NULL, |
|
| 216 |
lavsamplestats = NULL, |
|
| 217 |
lavpartable = NULL, |
|
| 218 |
lavdata = NULL, |
|
| 219 |
lavoptions = NULL, |
|
| 220 |
GLS = TRUE, |
|
| 221 |
min.reliability.marker = 0.1, |
|
| 222 |
quadprog = FALSE, |
|
| 223 |
nobs = 20L) {
|
|
| 224 | ! |
lavpta <- NULL |
| 225 | ! |
if (!is.null(lavobject)) {
|
| 226 | ! |
stopifnot(inherits(lavobject, "lavaan")) |
| 227 |
# extract slots |
|
| 228 | ! |
lavmodel <- lavobject@Model |
| 229 | ! |
lavsamplestats <- lavobject@SampleStats |
| 230 | ! |
lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta) |
| 231 | ! |
lavpta <- lavobject@pta |
| 232 | ! |
lavdata <- lavobject@Data |
| 233 | ! |
lavoptions <- lavobject@Options |
| 234 |
} |
|
| 235 | ! |
if (is.null(lavpta)) {
|
| 236 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 237 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 238 |
} |
|
| 239 |
# no structural part! |
|
| 240 | ! |
if (any(lavpartable$op == "~")) {
|
| 241 | ! |
lav_msg_stop(gettext("bentler1982 estimator only available for CFA models"))
|
| 242 |
} |
|
| 243 |
# no BETA matrix! (i.e., no higher-order factors) |
|
| 244 | ! |
if (!is.null(lavmodel@GLIST$beta)) {
|
| 245 | ! |
lav_msg_stop(gettext("bentler1982 estimator not available
|
| 246 | ! |
for models that require a BETA matrix")) |
| 247 |
} |
|
| 248 |
# no std.lv = TRUE for now |
|
| 249 | ! |
if (lavoptions$std.lv) {
|
| 250 | ! |
lav_msg_stop(gettext( |
| 251 | ! |
"bentler1982 estimator not available if std.lv = TRUE")) |
| 252 |
} |
|
| 253 | ||
| 254 | ! |
nblocks <- lav_partable_nblocks(lavpartable) |
| 255 | ! |
stopifnot(nblocks == 1L) # for now |
| 256 | ! |
b <- 1L |
| 257 | ! |
sample.cov <- lavsamplestats@cov[[b]] |
| 258 | ! |
nvar <- nrow(sample.cov) |
| 259 | ! |
lv.names <- lavpta$vnames$lv.regular[[b]] |
| 260 | ! |
nfac <- length(lv.names) |
| 261 | ! |
marker.idx <- lavpta$vidx$lv.marker[[b]] |
| 262 | ! |
lambda.idx <- which(names(lavmodel@GLIST) == "lambda") |
| 263 | ! |
lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]] |
| 264 |
# only diagonal THETA for now... |
|
| 265 |
# because if we have correlated residuals, we should remove the |
|
| 266 |
# corresponding variables as instruments before we estimate lambda... |
|
| 267 |
# (see MIIV) |
|
| 268 | ! |
theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2' |
| 269 | ! |
m.theta <- lavmodel@m.free.idx[[theta.idx]] |
| 270 | ! |
nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)] |
| 271 | ! |
if (length(nondiag.idx) > 0L) {
|
| 272 | ! |
lav_msg_warn(gettext( |
| 273 | ! |
"this implementation of FABIN does not handle correlated residuals yet!")) |
| 274 |
} |
|
| 275 | ||
| 276 | ! |
if (!missing(GLS)) {
|
| 277 | ! |
GLS.flag <- GLS |
| 278 |
} else {
|
|
| 279 | ! |
GLS.flag <- FALSE |
| 280 | ! |
if (!is.null(lavoptions$estimator.args$GLS) && |
| 281 | ! |
lavoptions$estimator.args$GLS) {
|
| 282 | ! |
GLS.flag <- TRUE |
| 283 |
} |
|
| 284 |
} |
|
| 285 | ||
| 286 | ! |
if (missing(quadprog) && |
| 287 | ! |
!is.null(lavoptions$estimator.args$quadprog)) {
|
| 288 | ! |
quadprog <- lavoptions$estimator.args$quadprog |
| 289 |
} |
|
| 290 | ||
| 291 |
# run bentler1982 non-iterative CFA algorithm |
|
| 292 | ! |
out <- lav_cfa_bentler1982( |
| 293 | ! |
S = sample.cov, marker.idx = marker.idx, |
| 294 | ! |
lambda.nonzero.idx = lambda.nonzero.idx, |
| 295 | ! |
GLS = GLS.flag, |
| 296 | ! |
min.reliability.marker = 0.1, |
| 297 | ! |
quadprog = quadprog, |
| 298 | ! |
nobs = lavsamplestats@ntotal |
| 299 |
) |
|
| 300 | ! |
LAMBDA <- out$lambda |
| 301 | ! |
THETA <- diag(out$theta, nvar) |
| 302 | ! |
PSI <- out$psi |
| 303 | ||
| 304 |
# store matrices in lavmodel@GLIST |
|
| 305 | ! |
lavmodel@GLIST$lambda <- LAMBDA |
| 306 | ! |
lavmodel@GLIST$theta <- THETA |
| 307 | ! |
lavmodel@GLIST$psi <- PSI |
| 308 | ||
| 309 |
# extract free parameters only |
|
| 310 | ! |
x <- lav_model_get_parameters(lavmodel) |
| 311 | ||
| 312 |
# apply bounds (if any) |
|
| 313 | ! |
if (!is.null(lavpartable$lower)) {
|
| 314 | ! |
lower.x <- lavpartable$lower[lavpartable$free > 0] |
| 315 | ! |
too.small.idx <- which(x < lower.x) |
| 316 | ! |
if (length(too.small.idx) > 0L) {
|
| 317 | ! |
x[too.small.idx] <- lower.x[too.small.idx] |
| 318 |
} |
|
| 319 |
} |
|
| 320 | ! |
if (!is.null(lavpartable$upper)) {
|
| 321 | ! |
upper.x <- lavpartable$upper[lavpartable$free > 0] |
| 322 | ! |
too.large.idx <- which(x > upper.x) |
| 323 | ! |
if (length(too.large.idx) > 0L) {
|
| 324 | ! |
x[too.large.idx] <- upper.x[too.large.idx] |
| 325 |
} |
|
| 326 |
} |
|
| 327 | ||
| 328 | ! |
x |
| 329 |
} |
| 1 |
# the information matrix of the unrestricted (H1) model |
|
| 2 |
# taking into account: |
|
| 3 |
# - the estimator (ML or (D)WLS/ULS) |
|
| 4 |
# - missing or not |
|
| 5 |
# - fixed.x = TRUE or FALSE |
|
| 6 |
# - conditional.x = TRUE or FALSE |
|
| 7 |
# - h1.information is "structured" or "unstructured" |
|
| 8 |
# |
|
| 9 |
# Note: this replaces the (old) lav_model_wls_v() function |
|
| 10 |
# |
|
| 11 |
# - YR 22 Okt 2017: initial version |
|
| 12 |
# - YR 03 Dec 2017: add lavh1, implied is either lavimplied or lavh1 |
|
| 13 |
# add support for clustered data: first.order |
|
| 14 |
# - YR 03 Jan 2018: add support for clustered data: expected |
|
| 15 |
# - YR 23 Aug 2018: lav_model_h1_acov (0.6-3) |
|
| 16 | ||
| 17 | ||
| 18 |
## For the lavaan.mi package, TDJ provides pooled versions of all the |
|
| 19 |
## sample moments called in these functions. If any updates to these functions |
|
| 20 |
## require NEW information (from @SampleStats or @implied or @h1), |
|
| 21 |
## PLEASE ADD A TAG @TDJorgensen |
|
| 22 |
## at the end of the commit message on GitHub, so TDJ can check whether |
|
| 23 |
## lavaan.mi::lavResiduals.mi() needs to be updated accordingly. |
|
| 24 | ||
| 25 | ||
| 26 | ||
| 27 |
lav_model_h1_information <- function(lavobject = NULL, |
|
| 28 |
lavmodel = NULL, |
|
| 29 |
lavsamplestats = NULL, |
|
| 30 |
lavdata = NULL, |
|
| 31 |
lavimplied = NULL, |
|
| 32 |
lavh1 = NULL, |
|
| 33 |
lavcache = NULL, |
|
| 34 |
lavoptions = NULL) {
|
|
| 35 | 6x |
if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
|
| 36 | ! |
lavmodel <- lavobject@Model |
| 37 | ! |
lavsamplestats <- lavobject@SampleStats |
| 38 | ! |
lavdata <- lavobject@Data |
| 39 | ! |
lavimplied <- lavobject@implied |
| 40 | ! |
lavh1 <- lavobject@h1 |
| 41 | ! |
lavcache <- lavobject@Cache |
| 42 | ! |
lavoptions <- lavobject@Options |
| 43 |
} |
|
| 44 | ||
| 45 |
# sanity check |
|
| 46 | 6x |
if (length(lavh1) == 0L) {
|
| 47 | ! |
lavh1 <- lav_h1_implied_logl( |
| 48 | ! |
lavdata = lavdata, |
| 49 | ! |
lavsamplestats = lavsamplestats, |
| 50 | ! |
lavoptions = lavoptions |
| 51 |
) |
|
| 52 |
} |
|
| 53 | 6x |
if (length(lavimplied) == 0L) {
|
| 54 | ! |
lavimplied <- lav_model_implied(lavmodel = lavmodel) |
| 55 |
} |
|
| 56 | ||
| 57 |
# information |
|
| 58 | 6x |
information <- lavoptions$information[1] # ALWAYS take the first one |
| 59 |
# the caller must control it |
|
| 60 | ||
| 61 | ||
| 62 |
# compute information matrix |
|
| 63 | 6x |
if (information == "observed") {
|
| 64 | 6x |
I1 <- lav_model_h1_information_observed( |
| 65 | 6x |
lavmodel = lavmodel, |
| 66 | 6x |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 67 | 6x |
lavimplied = lavimplied, lavh1 = lavh1, |
| 68 | 6x |
lavcache = lavcache, lavoptions = lavoptions |
| 69 |
) |
|
| 70 | ! |
} else if (information == "expected") {
|
| 71 | ! |
I1 <- lav_model_h1_information_expected( |
| 72 | ! |
lavmodel = lavmodel, |
| 73 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 74 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 75 | ! |
lavcache = lavcache, lavoptions = lavoptions |
| 76 |
) |
|
| 77 | ! |
} else if (information == "first.order") {
|
| 78 | ! |
I1 <- lav_model_h1_information_firstorder( |
| 79 | ! |
lavmodel = lavmodel, |
| 80 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 81 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 82 | ! |
lavcache = lavcache, lavoptions = lavoptions |
| 83 |
) |
|
| 84 |
} |
|
| 85 | ||
| 86 |
# I1 information, as a list per group |
|
| 87 | 6x |
I1 |
| 88 |
} |
|
| 89 | ||
| 90 |
# fisher/expected information of H1 |
|
| 91 |
lav_model_h1_information_expected <- function(lavobject = NULL, |
|
| 92 |
lavmodel = NULL, |
|
| 93 |
lavsamplestats = NULL, |
|
| 94 |
lavdata = NULL, |
|
| 95 |
lavoptions = NULL, |
|
| 96 |
lavimplied = NULL, |
|
| 97 |
lavh1 = NULL, |
|
| 98 |
lavcache = NULL) {
|
|
| 99 | 103x |
if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
|
| 100 | 39x |
lavmodel <- lavobject@Model |
| 101 | 39x |
lavsamplestats <- lavobject@SampleStats |
| 102 | 39x |
lavdata <- lavobject@Data |
| 103 | 39x |
lavimplied <- lavobject@implied |
| 104 | 39x |
lavh1 <- lavobject@h1 |
| 105 | 39x |
lavcache <- lavobject@Cache |
| 106 | 39x |
lavoptions <- lavobject@Options |
| 107 |
} |
|
| 108 | ||
| 109 |
# sanity check |
|
| 110 | 103x |
if (length(lavh1) == 0L) {
|
| 111 | ! |
lavh1 <- lav_h1_implied_logl( |
| 112 | ! |
lavdata = lavdata, |
| 113 | ! |
lavsamplestats = lavsamplestats, |
| 114 | ! |
lavoptions = lavoptions |
| 115 |
) |
|
| 116 |
} |
|
| 117 | 103x |
if (length(lavimplied) == 0L) {
|
| 118 | ! |
lavimplied <- lav_model_implied(lavmodel = lavmodel) |
| 119 |
} |
|
| 120 | ||
| 121 | 103x |
estimator <- lavmodel@estimator |
| 122 | ||
| 123 |
# structured of unstructured? (since 0.5-23) |
|
| 124 | 103x |
if (!is.null(lavoptions) && |
| 125 | 103x |
!is.null(lavoptions$h1.information[1]) && |
| 126 | 103x |
lavoptions$h1.information[1] == "unstructured") {
|
| 127 | 12x |
structured <- FALSE |
| 128 |
} else {
|
|
| 129 | 91x |
structured <- TRUE |
| 130 |
} |
|
| 131 | ||
| 132 |
# 1. WLS.V (=A1) for GLS/WLS |
|
| 133 | 103x |
if (lavmodel@estimator == "GLS" || lavmodel@estimator == "WLS") {
|
| 134 | 24x |
A1 <- lavsamplestats@WLS.V |
| 135 |
} |
|
| 136 | ||
| 137 |
# 1b. |
|
| 138 | 79x |
else if (lavmodel@estimator == "DLS") {
|
| 139 | ! |
if (lavmodel@estimator.args$dls.GammaNT == "sample") {
|
| 140 | ! |
A1 <- lavsamplestats@WLS.V |
| 141 |
} else {
|
|
| 142 | ! |
A1 <- vector("list", length = lavsamplestats@ngroups)
|
| 143 | ! |
for (g in seq_len(lavsamplestats@ngroups)) {
|
| 144 | ! |
dls.a <- lavmodel@estimator.args$dls.a |
| 145 | ! |
GammaNT <- lav_samplestats_Gamma_NT( |
| 146 | ! |
COV = lavimplied$cov[[g]], |
| 147 | ! |
MEAN = lavimplied$mean[[g]], |
| 148 | ! |
rescale = FALSE, |
| 149 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 150 | ! |
fixed.x = lavmodel@fixed.x, |
| 151 | ! |
conditional.x = lavmodel@conditional.x, |
| 152 | ! |
meanstructure = lavmodel@meanstructure, |
| 153 | ! |
slopestructure = lavmodel@conditional.x |
| 154 |
) |
|
| 155 | ! |
W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT |
| 156 | ! |
A1[[g]] <- lav_matrix_symmetric_inverse(W.DLS) |
| 157 |
} |
|
| 158 |
} |
|
| 159 |
} |
|
| 160 | ||
| 161 |
# 2. DWLS/ULS diagonal @WLS.VD slot |
|
| 162 | 79x |
else if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
|
| 163 |
# diagonal only!! |
|
| 164 | 6x |
A1 <- lavsamplestats@WLS.VD |
| 165 |
} |
|
| 166 | ||
| 167 |
# 3a. ML single level |
|
| 168 | 73x |
else if (lavmodel@estimator %in% c("ML", "NTRLS", "DLS", "catML") &&
|
| 169 | 73x |
lavdata@nlevels == 1L) {
|
| 170 | 72x |
A1 <- vector("list", length = lavsamplestats@ngroups)
|
| 171 | ||
| 172 |
# structured? compute model-implied statistics |
|
| 173 | 72x |
if (structured && length(lavimplied) == 0L) {
|
| 174 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 175 |
} |
|
| 176 | ||
| 177 | 72x |
for (g in 1:lavsamplestats@ngroups) {
|
| 178 | 78x |
WT <- lavdata@weights[[g]] |
| 179 | ||
| 180 | 78x |
if (lavsamplestats@missing.flag) {
|
| 181 |
# mvnorm |
|
| 182 |
# FIXME: allow for meanstructure = FALSE |
|
| 183 |
# FIXME: allow for conditional.x = TRUE |
|
| 184 | 8x |
if (lavmodel@meanstructure && structured) {
|
| 185 | 8x |
MEAN <- lavimplied$mean[[g]] |
| 186 |
} else {
|
|
| 187 |
#MEAN <- lavsamplestats@missing.h1[[g]]$mu |
|
| 188 | ! |
MEAN <- lavh1$implied$mean[[g]] |
| 189 |
} |
|
| 190 | ||
| 191 | 8x |
if (structured) {
|
| 192 | 8x |
A1[[g]] <- |
| 193 | 8x |
lav_mvnorm_missing_information_expected( |
| 194 | 8x |
Y = lavdata@X[[g]], |
| 195 | 8x |
Mp = lavdata@Mp[[g]], |
| 196 | 8x |
wt = WT, |
| 197 | 8x |
Mu = MEAN, |
| 198 |
# meanstructure = lavmodel@meanstructure, |
|
| 199 | 8x |
Sigma = lavimplied$cov[[g]], |
| 200 | 8x |
x.idx = lavsamplestats@x.idx[[g]] |
| 201 |
) |
|
| 202 |
} else {
|
|
| 203 | ! |
A1[[g]] <- |
| 204 | ! |
lav_mvnorm_missing_information_expected( |
| 205 | ! |
Y = lavdata@X[[g]], |
| 206 | ! |
Mp = lavdata@Mp[[g]], |
| 207 | ! |
wt = WT, |
| 208 | ! |
Mu = MEAN, |
| 209 |
# meanstructure = lavmodel@meanstructure, |
|
| 210 |
#Sigma = lavsamplestats@missing.h1[[g]]$sigma, |
|
| 211 | ! |
Sigma = lavh1$implied$cov[[g]], |
| 212 | ! |
x.idx = lavsamplestats@x.idx[[g]] |
| 213 |
) |
|
| 214 |
} |
|
| 215 |
} else {
|
|
| 216 | 70x |
if (lavmodel@conditional.x) {
|
| 217 |
# mvreg |
|
| 218 | ! |
if (lavmodel@meanstructure && structured) {
|
| 219 | ! |
RES.INT <- lavimplied$res.int[[g]] |
| 220 | ! |
RES.SLOPES <- lavimplied$res.slopes[[g]] |
| 221 |
} else {
|
|
| 222 | ! |
RES.INT <- lavsamplestats@res.int[[g]] |
| 223 | ! |
RES.SLOPES <- lavsamplestats@res.slopes[[g]] |
| 224 |
} |
|
| 225 | ||
| 226 | ! |
if (structured) {
|
| 227 | ! |
A1[[g]] <- lav_mvreg_information_expected( |
| 228 | ! |
sample.mean.x = lavsamplestats@mean.x[[g]], |
| 229 | ! |
sample.cov.x = lavsamplestats@cov.x[[g]], |
| 230 | ! |
sample.nobs = lavsamplestats@nobs[[g]], |
| 231 | ! |
res.int = RES.INT, |
| 232 | ! |
res.slopes = RES.SLOPES, |
| 233 |
# wt = WT, |
|
| 234 |
# meanstructure = lavmodel@meanstructure, |
|
| 235 | ! |
res.cov = lavimplied$res.cov[[g]] |
| 236 |
) |
|
| 237 |
} else {
|
|
| 238 | ! |
A1[[g]] <- lav_mvreg_information_expected( |
| 239 | ! |
sample.mean.x = lavsamplestats@mean.x[[g]], |
| 240 | ! |
sample.cov.x = lavsamplestats@cov.x[[g]], |
| 241 | ! |
sample.nobs = lavsamplestats@nobs[[g]], |
| 242 | ! |
res.int = lavsamplestats@res.int[[g]], |
| 243 | ! |
res.slopes = lavsamplestats@res.slopes[[g]], |
| 244 |
# wt = WT, |
|
| 245 |
# meanstructure = lavmodel@meanstructure, |
|
| 246 | ! |
res.cov = lavsamplestats@res.cov[[g]] |
| 247 |
) |
|
| 248 |
} |
|
| 249 |
} else {
|
|
| 250 |
# conditional.x = FALSE |
|
| 251 |
# mvnorm |
|
| 252 | 70x |
if (lavmodel@meanstructure && structured) {
|
| 253 | 26x |
MEAN <- lavimplied$mean[[g]] |
| 254 |
} else {
|
|
| 255 | 44x |
MEAN <- lavsamplestats@mean[[g]] |
| 256 |
} |
|
| 257 | ||
| 258 | 70x |
correlation.flag <- lavmodel@correlation |
| 259 | ||
| 260 | 70x |
if (structured) {
|
| 261 | 70x |
A1[[g]] <- lav_mvnorm_information_expected( |
| 262 | 70x |
Sigma = lavimplied$cov[[g]], |
| 263 |
# wt = WT, # not needed |
|
| 264 | 70x |
x.idx = lavsamplestats@x.idx[[g]], |
| 265 | 70x |
meanstructure = lavmodel@meanstructure, |
| 266 | 70x |
correlation = correlation.flag |
| 267 |
) |
|
| 268 |
} else {
|
|
| 269 | ! |
A1[[g]] <- lav_mvnorm_h1_information_expected( |
| 270 | ! |
sample.cov.inv = lavsamplestats@icov[[g]], |
| 271 |
# wt = WT, not needed |
|
| 272 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 273 | ! |
meanstructure = lavmodel@meanstructure, |
| 274 | ! |
correlation = correlation.flag |
| 275 |
) |
|
| 276 |
} |
|
| 277 |
} # conditional.x |
|
| 278 |
} # missing |
|
| 279 | ||
| 280 |
# stochastic group weight |
|
| 281 | 78x |
if (lavmodel@group.w.free) {
|
| 282 |
# unweight!! (as otherwise, we would 'weight' again) |
|
| 283 | ! |
a <- exp(lavimplied$group.w[[g]]) / lavsamplestats@nobs[[g]] |
| 284 | ! |
A1[[g]] <- lav_matrix_bdiag(matrix(a, 1L, 1L), A1[[g]]) |
| 285 |
} |
|
| 286 |
} # g |
|
| 287 |
} # ML |
|
| 288 | ||
| 289 |
# 3b. ML + multilevel |
|
| 290 | 1x |
else if (lavmodel@estimator == "ML" && lavdata@nlevels > 1L) {
|
| 291 | 1x |
A1 <- vector("list", length = lavsamplestats@ngroups)
|
| 292 | ||
| 293 |
# structured? compute model-implied statistics |
|
| 294 | 1x |
if (structured && length(lavimplied) == 0L) {
|
| 295 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 296 |
} |
|
| 297 | ||
| 298 |
# structured? lavimplied vs lavh1 |
|
| 299 | 1x |
if (structured) {
|
| 300 | 1x |
implied <- lavimplied |
| 301 |
} else {
|
|
| 302 | ! |
implied <- lavh1$implied |
| 303 |
} |
|
| 304 | ||
| 305 | 1x |
for (g in 1:lavsamplestats@ngroups) {
|
| 306 | 2x |
MU.W <- implied$mean[[(g - 1) * lavdata@nlevels + 1L]] |
| 307 | 2x |
MU.B <- implied$mean[[(g - 1) * lavdata@nlevels + 2L]] |
| 308 | 2x |
SIGMA.W <- implied$cov[[(g - 1) * lavdata@nlevels + 1L]] |
| 309 | 2x |
SIGMA.B <- implied$cov[[(g - 1) * lavdata@nlevels + 2L]] |
| 310 | ||
| 311 |
# clustered data |
|
| 312 | 2x |
A1[[g]] <- lav_mvnorm_cluster_information_expected( |
| 313 | 2x |
Lp = lavdata@Lp[[g]], |
| 314 | 2x |
Mu.W = MU.W, |
| 315 | 2x |
Sigma.W = SIGMA.W, |
| 316 | 2x |
Mu.B = MU.B, |
| 317 | 2x |
Sigma.B = SIGMA.B, |
| 318 | 2x |
x.idx = lavsamplestats@x.idx[[g]] |
| 319 |
) |
|
| 320 |
} # g |
|
| 321 |
} # ML + multilevel |
|
| 322 | ||
| 323 | ||
| 324 | 103x |
A1 |
| 325 |
} |
|
| 326 | ||
| 327 |
lav_model_h1_information_observed <- function(lavobject = NULL, |
|
| 328 |
lavmodel = NULL, |
|
| 329 |
lavsamplestats = NULL, |
|
| 330 |
lavdata = NULL, |
|
| 331 |
lavimplied = NULL, |
|
| 332 |
lavh1 = NULL, |
|
| 333 |
lavcache = NULL, |
|
| 334 |
lavoptions = NULL) {
|
|
| 335 | 86x |
if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
|
| 336 | 32x |
lavmodel <- lavobject@Model |
| 337 | 32x |
lavsamplestats <- lavobject@SampleStats |
| 338 | 32x |
lavdata <- lavobject@Data |
| 339 | 32x |
lavimplied <- lavobject@implied |
| 340 | 32x |
lavh1 <- lavobject@h1 |
| 341 | 32x |
lavcache <- lavobject@Cache |
| 342 | 32x |
lavoptions <- lavobject@Options |
| 343 |
} |
|
| 344 | ||
| 345 |
# sanity check |
|
| 346 | 86x |
if (length(lavh1) == 0L) {
|
| 347 | ! |
lavh1 <- lav_h1_implied_logl( |
| 348 | ! |
lavdata = lavdata, |
| 349 | ! |
lavsamplestats = lavsamplestats, |
| 350 | ! |
lavoptions = lavoptions |
| 351 |
) |
|
| 352 |
} |
|
| 353 | 86x |
if (length(lavimplied) == 0L) {
|
| 354 | ! |
lavimplied <- lav_model_implied(lavmodel = lavmodel) |
| 355 |
} |
|
| 356 | ||
| 357 | 86x |
estimator <- lavmodel@estimator |
| 358 | ||
| 359 |
# structured? |
|
| 360 | 86x |
if (!is.null(lavoptions) && |
| 361 | 86x |
!is.null(lavoptions$h1.information[1]) && |
| 362 | 86x |
lavoptions$h1.information[1] == "unstructured") {
|
| 363 | 86x |
structured <- FALSE |
| 364 |
} else {
|
|
| 365 | ! |
structured <- TRUE |
| 366 |
} |
|
| 367 | ||
| 368 |
# 1. WLS.V (=A1) for GLS/WLS |
|
| 369 | 86x |
if (lavmodel@estimator == "GLS" || lavmodel@estimator == "WLS" || |
| 370 | 86x |
lavmodel@estimator == "DLS") {
|
| 371 | ! |
A1 <- lavsamplestats@WLS.V |
| 372 |
} |
|
| 373 | ||
| 374 |
# 1b. |
|
| 375 | 86x |
else if (lavmodel@estimator == "DLS") {
|
| 376 | ! |
if (lavmodel@estimator.args$dls.GammaNT == "sample") {
|
| 377 | ! |
A1 <- lavsamplestats@WLS.V |
| 378 |
} else {
|
|
| 379 | ! |
A1 <- vector("list", length = lavsamplestats@ngroups)
|
| 380 | ! |
for (g in seq_len(lavsamplestats@ngroups)) {
|
| 381 | ! |
dls.a <- lavmodel@estimator.args$dls.a |
| 382 | ! |
GammaNT <- lav_samplestats_Gamma_NT( |
| 383 | ! |
COV = lavimplied$cov[[g]], |
| 384 | ! |
MEAN = lavimplied$mean[[g]], |
| 385 | ! |
rescale = FALSE, |
| 386 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 387 | ! |
fixed.x = lavmodel@fixed.x, |
| 388 | ! |
conditional.x = lavmodel@conditional.x, |
| 389 | ! |
meanstructure = lavmodel@meanstructure, |
| 390 | ! |
slopestructure = lavmodel@conditional.x |
| 391 |
) |
|
| 392 | ! |
W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT |
| 393 | ! |
A1[[g]] <- lav_matrix_symmetric_inverse(W.DLS) |
| 394 |
} |
|
| 395 |
} |
|
| 396 |
} |
|
| 397 | ||
| 398 |
# 2. DWLS/ULS diagonal @WLS.VD slot |
|
| 399 | 86x |
else if (lavmodel@estimator == "DWLS" || lavmodel@estimator == "ULS") {
|
| 400 |
# diagonal only!! |
|
| 401 | ! |
A1 <- lavsamplestats@WLS.VD |
| 402 |
} |
|
| 403 | ||
| 404 |
# 3a. ML single level |
|
| 405 | 86x |
else if (lavmodel@estimator == "ML" && lavdata@nlevels == 1L) {
|
| 406 | 86x |
A1 <- vector("list", length = lavsamplestats@ngroups)
|
| 407 | ||
| 408 |
# structured? compute model-implied statistics |
|
| 409 | 86x |
if (structured && length(lavimplied) == 0L) {
|
| 410 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 411 |
} |
|
| 412 | ||
| 413 | 86x |
for (g in 1:lavsamplestats@ngroups) {
|
| 414 | 86x |
if (lavsamplestats@missing.flag) {
|
| 415 |
# mvnorm |
|
| 416 |
# FIXME: allow for meanstructure = FALSE |
|
| 417 |
# FIXME: allow for conditional.x = TRUE |
|
| 418 | 70x |
if (lavmodel@meanstructure && structured) {
|
| 419 | ! |
MEAN <- lavimplied$mean[[g]] |
| 420 |
} else {
|
|
| 421 |
#MEAN <- lavsamplestats@missing.h1[[g]]$mu |
|
| 422 | 70x |
MEAN <- lavh1$implied$mean[[g]] |
| 423 |
} |
|
| 424 | ||
| 425 | 70x |
if (structured) {
|
| 426 | ! |
A1[[g]] <- |
| 427 | ! |
lav_mvnorm_missing_information_observed_samplestats( |
| 428 | ! |
Yp = lavsamplestats@missing[[g]], |
| 429 |
# wt not needed |
|
| 430 | ! |
Mu = MEAN, |
| 431 |
# meanstructure = lavmodel@meanstructure, |
|
| 432 | ! |
Sigma = lavimplied$cov[[g]], |
| 433 | ! |
x.idx = lavsamplestats@x.idx[[g]] |
| 434 |
) |
|
| 435 |
} else {
|
|
| 436 | 70x |
A1[[g]] <- |
| 437 | 70x |
lav_mvnorm_missing_information_observed_samplestats( |
| 438 | 70x |
Yp = lavsamplestats@missing[[g]], |
| 439 |
# wt not needed |
|
| 440 | 70x |
Mu = MEAN, |
| 441 |
# meanstructure = lavmodel@meanstructure, |
|
| 442 |
#Sigma = lavsamplestats@missing.h1[[g]]$sigma, |
|
| 443 | 70x |
Sigma = lavh1$implied$cov[[g]], |
| 444 | 70x |
x.idx = lavsamplestats@x.idx[[g]] |
| 445 |
) |
|
| 446 |
} |
|
| 447 |
} else {
|
|
| 448 | 16x |
if (lavmodel@conditional.x) {
|
| 449 |
# mvreg |
|
| 450 | ! |
if (lavmodel@meanstructure && structured) {
|
| 451 | ! |
RES.INT <- lavimplied$res.int[[g]] |
| 452 | ! |
RES.SLOPES <- lavimplied$res.slopes[[g]] |
| 453 |
} else {
|
|
| 454 | ! |
RES.INT <- lavsamplestats@res.int[[g]] |
| 455 | ! |
RES.SLOPES <- lavsamplestats@res.slopes[[g]] |
| 456 |
} |
|
| 457 | ||
| 458 | ! |
if (structured) {
|
| 459 | ! |
A1[[g]] <- lav_mvreg_information_observed_samplestats( |
| 460 | ! |
sample.res.int = lavsamplestats@res.int[[g]], |
| 461 | ! |
sample.res.slopes = lavsamplestats@res.slopes[[g]], |
| 462 | ! |
sample.res.cov = lavsamplestats@res.cov[[g]], |
| 463 | ! |
sample.mean.x = lavsamplestats@mean.x[[g]], |
| 464 | ! |
sample.cov.x = lavsamplestats@cov.x[[g]], |
| 465 | ! |
res.int = RES.INT, |
| 466 | ! |
res.slopes = RES.SLOPES, |
| 467 |
# wt = WT, |
|
| 468 |
# meanstructure = lavmodel@meanstructure, |
|
| 469 | ! |
res.cov = lavimplied$res.cov[[g]] |
| 470 |
) |
|
| 471 |
} else {
|
|
| 472 | ! |
A1[[g]] <- lav_mvreg_information_observed_samplestats( |
| 473 | ! |
sample.res.int = lavsamplestats@res.int[[g]], |
| 474 | ! |
sample.res.slopes = lavsamplestats@res.slopes[[g]], |
| 475 | ! |
sample.res.cov = lavsamplestats@res.cov[[g]], |
| 476 | ! |
sample.mean.x = lavsamplestats@mean.x[[g]], |
| 477 | ! |
sample.cov.x = lavsamplestats@cov.x[[g]], |
| 478 | ! |
res.int = lavsamplestats@res.int[[g]], |
| 479 | ! |
res.slopes = lavsamplestats@res.slopes[[g]], |
| 480 |
# wt = WT, |
|
| 481 |
# meanstructure = lavmodel@meanstructure, |
|
| 482 | ! |
res.cov = lavsamplestats@res.cov[[g]] |
| 483 |
) |
|
| 484 |
} |
|
| 485 |
} else {
|
|
| 486 |
# conditional.x = FALSE |
|
| 487 |
# mvnorm |
|
| 488 | 16x |
if (lavmodel@meanstructure && structured) {
|
| 489 | ! |
MEAN <- lavimplied$mean[[g]] |
| 490 |
} else {
|
|
| 491 | 16x |
MEAN <- lavsamplestats@mean[[g]] |
| 492 |
} |
|
| 493 | ||
| 494 | 16x |
if (structured) {
|
| 495 | ! |
A1[[g]] <- lav_mvnorm_information_observed_samplestats( |
| 496 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 497 | ! |
sample.cov = lavsamplestats@cov[[g]], |
| 498 | ! |
Mu = MEAN, |
| 499 | ! |
Sigma = lavimplied$cov[[g]], |
| 500 |
# wt = WT, # not needed |
|
| 501 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 502 | ! |
meanstructure = lavmodel@meanstructure |
| 503 |
) |
|
| 504 |
} else {
|
|
| 505 | 16x |
A1[[g]] <- lav_mvnorm_h1_information_observed_samplestats( |
| 506 | 16x |
sample.mean = lavsamplestats@mean[[g]], |
| 507 | 16x |
sample.cov = lavsamplestats@cov[[g]], |
| 508 | 16x |
sample.cov.inv = lavsamplestats@icov[[g]], |
| 509 |
# wt = WT, not needed |
|
| 510 | 16x |
x.idx = lavsamplestats@x.idx[[g]], |
| 511 | 16x |
meanstructure = lavmodel@meanstructure |
| 512 |
) |
|
| 513 |
} |
|
| 514 |
} # conditional.x |
|
| 515 |
} # missing |
|
| 516 | ||
| 517 |
# stochastic group weight |
|
| 518 | 86x |
if (lavmodel@group.w.free) {
|
| 519 |
# unweight!! |
|
| 520 | ! |
a <- exp(lavimplied$group.w[[g]]) / lavsamplestats@nobs[[g]] |
| 521 | ! |
A1[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), A1[[g]]) |
| 522 |
} |
|
| 523 |
} # g |
|
| 524 |
} # ML |
|
| 525 | ||
| 526 |
# 3b. ML + multilevel |
|
| 527 | ! |
else if (lavmodel@estimator == "ML" && lavdata@nlevels > 1L) {
|
| 528 | ! |
A1 <- vector("list", length = lavsamplestats@ngroups)
|
| 529 | ||
| 530 |
# structured? compute model-implied statistics |
|
| 531 | ! |
if (structured && length(lavimplied) == 0L) {
|
| 532 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 533 |
} |
|
| 534 | ||
| 535 |
# structured? lavimplied vs lavh1 |
|
| 536 | ! |
if (structured) {
|
| 537 | ! |
implied <- lavimplied |
| 538 |
} else {
|
|
| 539 | ! |
implied <- lavh1$implied |
| 540 |
} |
|
| 541 | ||
| 542 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 543 | ! |
MU.W <- implied$mean[[(g - 1) * lavdata@nlevels + 1L]] |
| 544 | ! |
MU.B <- implied$mean[[(g - 1) * lavdata@nlevels + 2L]] |
| 545 | ! |
SIGMA.W <- implied$cov[[(g - 1) * lavdata@nlevels + 1L]] |
| 546 | ! |
SIGMA.B <- implied$cov[[(g - 1) * lavdata@nlevels + 2L]] |
| 547 | ||
| 548 | ! |
if (lavdata@missing == "ml") {
|
| 549 | ! |
A1[[g]] <- lav_mvnorm_cluster_missing_information_observed( |
| 550 | ! |
Y1 = lavdata@X[[g]], |
| 551 | ! |
Y2 = lavsamplestats@YLp[[g]][[2]]$Y2, |
| 552 | ! |
Lp = lavdata@Lp[[g]], |
| 553 | ! |
Mp = lavdata@Mp[[g]], |
| 554 | ! |
Mu.W = MU.W, |
| 555 | ! |
Sigma.W = SIGMA.W, |
| 556 | ! |
Mu.B = MU.B, |
| 557 | ! |
Sigma.B = SIGMA.B, |
| 558 | ! |
x.idx = lavsamplestats@x.idx[[g]] |
| 559 |
) |
|
| 560 |
} else {
|
|
| 561 | ! |
A1[[g]] <- lav_mvnorm_cluster_information_observed( |
| 562 | ! |
Lp = lavdata@Lp[[g]], |
| 563 | ! |
YLp = lavsamplestats@YLp[[g]], |
| 564 | ! |
Mu.W = MU.W, |
| 565 | ! |
Sigma.W = SIGMA.W, |
| 566 | ! |
Mu.B = MU.B, |
| 567 | ! |
Sigma.B = SIGMA.B, |
| 568 | ! |
x.idx = lavsamplestats@x.idx[[g]] |
| 569 |
) |
|
| 570 |
} |
|
| 571 |
} # g |
|
| 572 |
} # ML + multilevel |
|
| 573 | ||
| 574 | 86x |
A1 |
| 575 |
} |
|
| 576 | ||
| 577 |
# outer product of the case-wise scores (gradients) |
|
| 578 |
# HJ 18/10/2023: Adjust J matrix correctly using weights. Note: H matrix is |
|
| 579 |
# based on lav_model_hessian so no changes required. |
|
| 580 |
lav_model_h1_information_firstorder <- function(lavobject = NULL, |
|
| 581 |
lavmodel = NULL, |
|
| 582 |
lavsamplestats = NULL, |
|
| 583 |
lavdata = NULL, |
|
| 584 |
lavimplied = NULL, |
|
| 585 |
lavh1 = NULL, |
|
| 586 |
lavcache = NULL, |
|
| 587 |
lavoptions = NULL) {
|
|
| 588 | 19x |
if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
|
| 589 | 4x |
lavmodel <- lavobject@Model |
| 590 | 4x |
lavsamplestats <- lavobject@SampleStats |
| 591 | 4x |
lavdata <- lavobject@Data |
| 592 | 4x |
lavimplied <- lavobject@implied |
| 593 | 4x |
lavh1 <- lavobject@h1 |
| 594 | 4x |
lavcache <- lavobject@Cache |
| 595 | 4x |
lavoptions <- lavobject@Options |
| 596 |
} |
|
| 597 | ||
| 598 |
# sanity check |
|
| 599 | 19x |
if (length(lavh1) == 0L) {
|
| 600 | ! |
lavh1 <- lav_h1_implied_logl( |
| 601 | ! |
lavdata = lavdata, |
| 602 | ! |
lavsamplestats = lavsamplestats, |
| 603 | ! |
lavoptions = lavoptions |
| 604 |
) |
|
| 605 |
} |
|
| 606 | 19x |
if (length(lavimplied) == 0L) {
|
| 607 | ! |
lavimplied <- lav_model_implied(lavmodel = lavmodel) |
| 608 |
} |
|
| 609 | ||
| 610 | 19x |
estimator <- lavmodel@estimator |
| 611 | 19x |
if (!estimator %in% c("ML", "PML")) {
|
| 612 | ! |
lav_msg_stop(gettext( |
| 613 | ! |
"information = \"first.order\" not available for estimator"), |
| 614 | ! |
sQuote(estimator)) |
| 615 |
} |
|
| 616 | ||
| 617 |
# structured? |
|
| 618 | 19x |
if (!is.null(lavoptions) && |
| 619 | 19x |
!is.null(lavoptions$h1.information[1]) && |
| 620 | 19x |
lavoptions$h1.information[1] == "unstructured") {
|
| 621 | 10x |
structured <- FALSE |
| 622 |
} else {
|
|
| 623 | 9x |
structured <- TRUE |
| 624 |
} |
|
| 625 | ||
| 626 |
# clustered? |
|
| 627 | 19x |
if (!is.null(lavoptions) && |
| 628 | 19x |
!is.null(lavoptions$.clustered) && |
| 629 | 19x |
lavoptions$.clustered) {
|
| 630 | ! |
clustered <- TRUE |
| 631 | ! |
if (is.null(lavdata@Lp[[1]])) {
|
| 632 | ! |
lav_msg_stop(gettext("lavdata@Lp is empty, while clustered = TRUE"))
|
| 633 |
} |
|
| 634 |
# if (estimator == "PML") {
|
|
| 635 |
# lav_msg_stop(gettext( |
|
| 636 |
# "clustered information is not (yet) available when estimator = 'PML'")) |
|
| 637 |
# } |
|
| 638 |
# if(lavsamplestats@missing.flag) {
|
|
| 639 |
# stop("lavaan ERROR: clustered information is not (yet) available when missing = \"ML\"")
|
|
| 640 |
# } |
|
| 641 |
# if(lavmodel@conditional.x) {
|
|
| 642 |
# stop("lavaan ERROR: clustered information is not (yet) available when conditional.x = TRUE")
|
|
| 643 |
# } |
|
| 644 |
# if(!structured) {
|
|
| 645 |
# stop("lavaan ERROR: clustered information is not (yet) available when h1.information = \"unstructured\"")
|
|
| 646 |
# } |
|
| 647 |
} else {
|
|
| 648 | 19x |
clustered <- FALSE |
| 649 |
} |
|
| 650 | ||
| 651 |
# structured? compute model-implied statistics |
|
| 652 | 19x |
if (estimator == "PML" || structured) {
|
| 653 | 9x |
if (length(lavimplied) == 0L) {
|
| 654 | ! |
lavimplied <- lav_model_implied(lavmodel) |
| 655 |
} |
|
| 656 |
} |
|
| 657 | ||
| 658 |
# structured? lavimplied vs lavh1 |
|
| 659 | 19x |
if (structured) {
|
| 660 | 9x |
implied <- lavimplied |
| 661 |
} else {
|
|
| 662 | 10x |
implied <- lavh1$implied |
| 663 |
} |
|
| 664 | ||
| 665 | 19x |
B1 <- vector("list", length = lavsamplestats@ngroups)
|
| 666 | 19x |
for (g in 1:lavdata@ngroups) {
|
| 667 | 19x |
WT <- lavdata@weights[[g]] |
| 668 | ||
| 669 | 19x |
if (estimator == "PML") {
|
| 670 |
# slow approach: compute outer product of case-wise scores |
|
| 671 | ||
| 672 | ! |
if (lavmodel@conditional.x) {
|
| 673 | ! |
SIGMA <- implied$res.cov[[g]] |
| 674 | ! |
MU <- implied$res.mean[[g]] |
| 675 | ! |
TH <- implied$res.th[[g]] |
| 676 | ! |
PI <- implied$res.slopes[[g]] |
| 677 | ! |
EXO <- lavdata@eXo[[g]] |
| 678 |
} else {
|
|
| 679 | ! |
SIGMA <- implied$cov[[g]] |
| 680 | ! |
MU <- implied$mean[[g]] |
| 681 | ! |
TH <- implied$th[[g]] |
| 682 | ! |
PI <- NULL |
| 683 | ! |
EXO <- NULL |
| 684 |
} |
|
| 685 | ! |
SC <- lav_pml_dploglik_dimplied( |
| 686 | ! |
Sigma.hat = SIGMA, |
| 687 | ! |
Mu.hat = MU, |
| 688 | ! |
TH = TH, |
| 689 | ! |
th.idx = lavmodel@th.idx[[g]], |
| 690 | ! |
num.idx = lavmodel@num.idx[[g]], |
| 691 | ! |
X = lavdata@X[[g]], |
| 692 | ! |
eXo = EXO, |
| 693 | ! |
wt = NULL, |
| 694 | ! |
PI = PI, |
| 695 | ! |
lavcache = lavcache[[g]], |
| 696 | ! |
missing = lavdata@missing, |
| 697 | ! |
scores = TRUE, |
| 698 | ! |
negative = FALSE |
| 699 |
) |
|
| 700 | ||
| 701 |
# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 702 | ||
| 703 | ||
| 704 |
# information H1 |
|
| 705 | ||
| 706 | ! |
if (isTRUE(clustered)) {
|
| 707 |
# For clustered data, need to compute (centred) crossprod within each |
|
| 708 |
# cluster and sum them all up. |
|
| 709 | ! |
clusters <- lavdata@Lp[[g]]$cluster.id[[2]] # why list of 2? |
| 710 | ! |
clusters.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
| 711 | ! |
nclust <- length(clusters) |
| 712 | ! |
zb <- list() |
| 713 | ||
| 714 | ! |
if (is.null(WT)) WT <- rep(1, length(clusters.idx)) |
| 715 | ||
| 716 | ! |
for (b in seq_along(clusters)) {
|
| 717 | ! |
SC_b <- SC[clusters.idx == b, ] |
| 718 | ! |
WT_b <- WT[clusters.idx == b] |
| 719 | ! |
zb[[b]] <- apply(SC_b * WT_b, 2, sum) |
| 720 |
} |
|
| 721 | ! |
zbar <- apply(do.call(cbind, zb), 1, mean) |
| 722 | ! |
B1c <- Reduce(f = `+`, lapply(zb, function(z) tcrossprod(z - zbar))) |
| 723 | ! |
B1[[g]] <- nclust / (nclust - 1) * B1c |
| 724 | ||
| 725 |
} else {
|
|
| 726 | ! |
if (is.null(WT)) {
|
| 727 | ! |
B1[[g]] <- lav_matrix_crossprod(SC) |
| 728 |
} else {
|
|
| 729 | ! |
B1[[g]] <- crossprod(WT * SC) |
| 730 |
} |
|
| 731 |
} |
|
| 732 | 19x |
} else if (estimator == "ML" && lavdata@nlevels > 1L) {
|
| 733 |
# if not-structured, we use lavh1, and that is always |
|
| 734 |
# 'unconditional' (for now) |
|
| 735 | ! |
if (lavmodel@conditional.x && structured) {
|
| 736 | ! |
if (lavdata@missing == "ml") {
|
| 737 | ! |
lav_msg_stop(gettext("firstorder information matrix not available
|
| 738 | ! |
(yet) if conditional.x + fiml")) |
| 739 |
} |
|
| 740 | ! |
Res.Sigma.W <- implied$res.cov[[(g - 1) * lavdata@nlevels + 1L]] |
| 741 | ! |
Res.Int.W <- implied$res.int[[(g - 1) * lavdata@nlevels + 1L]] |
| 742 | ! |
Res.Pi.W <- implied$res.slopes[[(g - 1) * lavdata@nlevels + 1L]] |
| 743 | ||
| 744 | ! |
Res.Sigma.B <- implied$res.cov[[(g - 1) * lavdata@nlevels + 2L]] |
| 745 | ! |
Res.Int.B <- implied$res.int[[(g - 1) * lavdata@nlevels + 2L]] |
| 746 | ! |
Res.Pi.B <- implied$res.slopes[[(g - 1) * lavdata@nlevels + 2L]] |
| 747 | ! |
B1[[g]] <- lav_mvreg_cluster_information_firstorder( |
| 748 | ! |
Y1 = lavdata@X[[g]], |
| 749 | ! |
YLp = lavsamplestats@YLp[[g]], |
| 750 | ! |
Lp = lavdata@Lp[[g]], |
| 751 | ! |
Res.Sigma.W = Res.Sigma.W, |
| 752 | ! |
Res.Int.W = Res.Int.W, |
| 753 | ! |
Res.Pi.W = Res.Pi.W, |
| 754 | ! |
Res.Sigma.B = Res.Sigma.B, |
| 755 | ! |
Res.Int.B = Res.Int.B, |
| 756 | ! |
Res.Pi.B = Res.Pi.B, |
| 757 | ! |
divide.by.two = TRUE |
| 758 |
) |
|
| 759 |
} else {
|
|
| 760 | ! |
MU.W <- implied$mean[[(g - 1) * lavdata@nlevels + 1L]] |
| 761 | ! |
MU.B <- implied$mean[[(g - 1) * lavdata@nlevels + 2L]] |
| 762 | ! |
SIGMA.W <- implied$cov[[(g - 1) * lavdata@nlevels + 1L]] |
| 763 | ! |
SIGMA.B <- implied$cov[[(g - 1) * lavdata@nlevels + 2L]] |
| 764 | ! |
if (lavdata@missing == "ml") {
|
| 765 | ! |
B1[[g]] <- lav_mvnorm_cluster_missing_information_firstorder( |
| 766 | ! |
Y1 = lavdata@X[[g]], |
| 767 | ! |
Y2 = lavsamplestats@YLp[[g]][[2]]$Y2, |
| 768 | ! |
Lp = lavdata@Lp[[g]], |
| 769 | ! |
Mp = lavdata@Mp[[g]], |
| 770 | ! |
Mu.W = MU.W, |
| 771 | ! |
Sigma.W = SIGMA.W, |
| 772 | ! |
Mu.B = MU.B, |
| 773 | ! |
Sigma.B = SIGMA.B, |
| 774 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 775 | ! |
divide.by.two = TRUE |
| 776 |
) |
|
| 777 |
} else {
|
|
| 778 |
# no missing values |
|
| 779 | ! |
B1[[g]] <- lav_mvnorm_cluster_information_firstorder( |
| 780 | ! |
Y1 = lavdata@X[[g]], |
| 781 | ! |
YLp = lavsamplestats@YLp[[g]], |
| 782 | ! |
Lp = lavdata@Lp[[g]], |
| 783 | ! |
Mu.W = MU.W, |
| 784 | ! |
Sigma.W = SIGMA.W, |
| 785 | ! |
Mu.B = MU.B, |
| 786 | ! |
Sigma.B = SIGMA.B, |
| 787 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 788 | ! |
divide.by.two = TRUE |
| 789 |
) |
|
| 790 |
} |
|
| 791 |
} |
|
| 792 | 19x |
} else if (estimator == "ML" && lavdata@nlevels == 1L) {
|
| 793 | 19x |
if (length(lavdata@cluster) > 0L) {
|
| 794 | ! |
cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
| 795 |
} else {
|
|
| 796 | 19x |
cluster.idx <- NULL |
| 797 |
} |
|
| 798 | ||
| 799 | 19x |
if (lavsamplestats@missing.flag) {
|
| 800 |
# mvnorm |
|
| 801 |
# FIXME: allow for meanstructure = FALSE |
|
| 802 |
# FIXME: allow for conditional.x = TRUE |
|
| 803 | 18x |
if (lavmodel@meanstructure && structured) {
|
| 804 | 8x |
MEAN <- lavimplied$mean[[g]] |
| 805 |
} else {
|
|
| 806 |
#MEAN <- lavsamplestats@missing.h1[[g]]$mu |
|
| 807 | 10x |
MEAN <- lavh1$implied$mean[[g]] |
| 808 |
} |
|
| 809 | ||
| 810 | 18x |
B1[[g]] <- lav_mvnorm_missing_information_firstorder( |
| 811 | 18x |
Y = lavdata@X[[g]], |
| 812 | 18x |
Mp = lavdata@Mp[[g]], wt = WT, |
| 813 | 18x |
cluster.idx = cluster.idx, |
| 814 | 18x |
Mu = MEAN, |
| 815 |
# meanstructure = lavmodel@meanstructure, |
|
| 816 | 18x |
Sigma = implied$cov[[g]], |
| 817 | 18x |
x.idx = lavsamplestats@x.idx[[g]] |
| 818 |
) |
|
| 819 |
} else {
|
|
| 820 | 1x |
if (lavmodel@conditional.x) {
|
| 821 |
# mvreg |
|
| 822 | ! |
if (lavmodel@meanstructure && structured) {
|
| 823 | ! |
RES.INT <- lavimplied$res.int[[g]] |
| 824 | ! |
RES.SLOPES <- lavimplied$res.slopes[[g]] |
| 825 |
} else {
|
|
| 826 | ! |
RES.INT <- lavsamplestats@res.int[[g]] |
| 827 | ! |
RES.SLOPES <- lavsamplestats@res.slopes[[g]] |
| 828 |
} |
|
| 829 | ||
| 830 | ! |
B1[[g]] <- lav_mvreg_information_firstorder( |
| 831 | ! |
Y = lavdata@X[[g]], |
| 832 | ! |
eXo = lavdata@eXo[[g]], |
| 833 | ! |
res.int = RES.INT, |
| 834 | ! |
res.slopes = RES.SLOPES, |
| 835 |
# wt = WT, |
|
| 836 |
# meanstructure = lavmodel@meanstructure, |
|
| 837 | ! |
res.cov = implied$res.cov[[g]] |
| 838 |
) |
|
| 839 |
} else {
|
|
| 840 |
# conditional.x = FALSE |
|
| 841 |
# mvnorm |
|
| 842 | 1x |
if (lavmodel@meanstructure && structured) {
|
| 843 | 1x |
MEAN <- lavimplied$mean[[g]] |
| 844 |
} else {
|
|
| 845 |
# NOTE: the information matrix will be the same (minus |
|
| 846 |
# the meanstructure block), but once INVERTED, the |
|
| 847 |
# standard errors will be (slightly) smaller!!! |
|
| 848 |
# This is only visibile when estimator = "MLF" |
|
| 849 |
# (or information = "first.order") |
|
| 850 | ! |
MEAN <- lavsamplestats@mean[[g]] # saturated |
| 851 |
} |
|
| 852 | ||
| 853 | 1x |
if (structured) {
|
| 854 | 1x |
B1[[g]] <- lav_mvnorm_information_firstorder( |
| 855 | 1x |
Y = lavdata@X[[g]], |
| 856 | 1x |
Mu = MEAN, Sigma = lavimplied$cov[[g]], |
| 857 | 1x |
wt = WT, |
| 858 | 1x |
cluster.idx = cluster.idx, |
| 859 | 1x |
x.idx = lavsamplestats@x.idx[[g]], |
| 860 | 1x |
meanstructure = lavmodel@meanstructure |
| 861 |
) |
|
| 862 |
} else {
|
|
| 863 | ! |
B1[[g]] <- lav_mvnorm_h1_information_firstorder( |
| 864 | ! |
Y = lavdata@X[[g]], |
| 865 | ! |
sample.cov.inv = lavsamplestats@icov[[g]], |
| 866 | ! |
Gamma = lavsamplestats@NACOV[[g]], |
| 867 | ! |
wt = WT, |
| 868 | ! |
cluster.idx = cluster.idx, # only if wt |
| 869 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 870 | ! |
meanstructure = lavmodel@meanstructure |
| 871 |
) |
|
| 872 |
} |
|
| 873 |
} # mvnorm |
|
| 874 |
} # missing |
|
| 875 |
} # ML |
|
| 876 | ||
| 877 |
# stochastic group weight |
|
| 878 | 19x |
if (lavmodel@group.w.free) {
|
| 879 |
# unweight!! |
|
| 880 | ! |
a <- exp(lavimplied$group.w[[g]]) / lavsamplestats@nobs[[g]] |
| 881 | ! |
B1[[g]] <- lav_matrix_bdiag(matrix(a, 1, 1), B1[[g]]) |
| 882 |
} |
|
| 883 |
} # g |
|
| 884 | ||
| 885 | 19x |
B1 |
| 886 |
} |
|
| 887 | ||
| 888 | ||
| 889 |
# asymptotic variance matrix (=Gamma/N) of the unrestricted (H1) |
|
| 890 |
# sample statistics |
|
| 891 |
# |
|
| 892 |
# FIXME: make this work for categorical/GLS/WLS/... |
|
| 893 |
# |
|
| 894 |
lav_model_h1_acov <- function(lavobject = NULL, |
|
| 895 |
lavmodel = NULL, |
|
| 896 |
lavsamplestats = NULL, |
|
| 897 |
lavdata = NULL, |
|
| 898 |
lavoptions = NULL, |
|
| 899 |
lavimplied = NULL, |
|
| 900 |
lavh1 = NULL, |
|
| 901 |
lavcache = NULL, |
|
| 902 |
meanstructure = NULL, # if specified, use it |
|
| 903 |
h1.information = NULL, # if specified, use it |
|
| 904 |
se = NULL) { # if specified, use it
|
|
| 905 | ||
| 906 | ! |
if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
|
| 907 | ! |
lavmodel <- lavobject@Model |
| 908 | ! |
lavsamplestats <- lavobject@SampleStats |
| 909 | ! |
lavdata <- lavobject@Data |
| 910 | ! |
lavimplied <- lavobject@implied |
| 911 | ! |
lavh1 <- lavobject@h1 |
| 912 | ! |
lavcache <- lavobject@Cache |
| 913 | ! |
lavoptions <- lavobject@Options |
| 914 |
} |
|
| 915 | ||
| 916 |
# sanity check |
|
| 917 | ! |
if (length(lavh1) == 0L) {
|
| 918 | ! |
lavh1 <- lav_h1_implied_logl( |
| 919 | ! |
lavdata = lavdata, |
| 920 | ! |
lavsamplestats = lavsamplestats, |
| 921 | ! |
lavoptions = lavoptions |
| 922 |
) |
|
| 923 |
} |
|
| 924 | ! |
if (length(lavimplied) == 0L) {
|
| 925 | ! |
lavimplied <- lav_model_implied(lavmodel = lavmodel) |
| 926 |
} |
|
| 927 | ||
| 928 |
# override |
|
| 929 | ! |
if (!is.null(meanstructure)) {
|
| 930 | ! |
lavoptions$meanstructure <- meanstructure |
| 931 |
} |
|
| 932 | ! |
if (!is.null(h1.information)) {
|
| 933 | ! |
lavoptions$h1.information[1] <- h1.information |
| 934 |
} |
|
| 935 | ! |
if (!is.null(se)) {
|
| 936 | ! |
lavoptions$se <- se |
| 937 |
} |
|
| 938 | ||
| 939 | ||
| 940 |
# information |
|
| 941 | ! |
information <- lavoptions$information[1] # ALWAYS used the first |
| 942 | ||
| 943 |
# compute information matrix |
|
| 944 | ! |
if (information == "observed") {
|
| 945 | ! |
I1 <- lav_model_h1_information_observed( |
| 946 | ! |
lavmodel = lavmodel, |
| 947 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 948 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 949 | ! |
lavcache = lavcache, lavoptions = lavoptions |
| 950 |
) |
|
| 951 | ! |
} else if (information == "expected") {
|
| 952 | ! |
I1 <- lav_model_h1_information_expected( |
| 953 | ! |
lavmodel = lavmodel, |
| 954 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 955 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 956 | ! |
lavcache = lavcache, lavoptions = lavoptions |
| 957 |
) |
|
| 958 | ! |
} else if (information == "first.order") {
|
| 959 | ! |
I1 <- lav_model_h1_information_firstorder( |
| 960 | ! |
lavmodel = lavmodel, |
| 961 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 962 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 963 | ! |
lavcache = lavcache, lavoptions = lavoptions |
| 964 |
) |
|
| 965 |
} |
|
| 966 | ||
| 967 | ! |
if (lavoptions$se %in% c("robust.huber.white", "robust.sem")) {
|
| 968 | ! |
J1 <- lav_model_h1_information_firstorder( |
| 969 | ! |
lavmodel = lavmodel, |
| 970 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 971 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 972 | ! |
lavcache = lavcache, lavoptions = lavoptions |
| 973 |
) |
|
| 974 |
} |
|
| 975 | ||
| 976 |
# compute ACOV per group |
|
| 977 | ! |
ACOV <- vector("list", length = lavdata@ngroups)
|
| 978 | ! |
for (g in 1:lavdata@ngroups) {
|
| 979 |
# denominator |
|
| 980 | ! |
if (lavdata@nlevels == 1L) {
|
| 981 | ! |
Ng <- lavsamplestats@nobs[[g]] |
| 982 |
} else {
|
|
| 983 | ! |
Ng <- lavdata@Lp[[g]]$nclusters[[2]] |
| 984 |
} |
|
| 985 | ||
| 986 |
# invert information |
|
| 987 | ! |
I1.g.inv <- try(lav_matrix_symmetric_inverse(I1[[g]]), silent = TRUE) |
| 988 | ! |
if (inherits(I1.g.inv, "try-error")) {
|
| 989 | ! |
lav_msg_stop(gettext( |
| 990 | ! |
"could not invert h1 information matrix in group"), g) |
| 991 |
} |
|
| 992 | ||
| 993 |
# which type of se? |
|
| 994 | ! |
if (lavoptions$se %in% c("standard", "none")) {
|
| 995 | ! |
ACOV[[g]] <- 1 / Ng * I1.g.inv |
| 996 | ! |
} else if (lavoptions$se %in% c("robust.huber.white", "robust.sem")) {
|
| 997 | ! |
ACOV[[g]] <- 1 / Ng * (I1.g.inv %*% J1[[g]] %*% I1.g.inv) |
| 998 |
} |
|
| 999 |
} |
|
| 1000 | ||
| 1001 | ! |
ACOV |
| 1002 |
} |
| 1 |
# contributed by Ed Merkle (17 Jan 2013) |
|
| 2 |
# WLS version contributed by Franz Classe (March 2024) |
|
| 3 |
# (adapted for inclusion in lavaan by YR) |
|
| 4 | ||
| 5 | ||
| 6 |
# YR 12 Feb 2013: small changes to match the results of lav_model_gradient |
|
| 7 |
# in the multiple group case |
|
| 8 |
# YR 30 May 2014: handle 1-variable case (fixing apply in lines 56, 62, 108) |
|
| 9 |
# YR 05 Nov 2015: add remove.duplicated = TRUE, to cope with strucchange in |
|
| 10 |
# case of simple equality constraints |
|
| 11 |
# YR 19 Nov 2015: if constraints have been used, compute case-wise Lagrange |
|
| 12 |
# multipliers, and define the scores as: SC + (t(R) lambda) |
|
| 13 |
# YR 05 Feb 2016: catch conditional.x = TRUE: no support (for now), until |
|
| 14 |
# we can use the generic 0.6 infrastructure for scores, |
|
| 15 |
# including the missing-values case |
|
| 16 |
# YR 16 Feb 2016: adapt to changed @Mp slot elements; add remove.empty.cases= |
|
| 17 |
# argument |
|
| 18 |
# YR 12 Mar 2024: make lintr (more) happy; include WLS code from Franz Classe |
|
| 19 |
# move ML-specific code to lav_scores_ml() function |
|
| 20 |
# YR 26 Apr 2025: add lav_scores_gls() |
|
| 21 | ||
| 22 |
lav_scores <- function(object, scaling = FALSE, # nolint |
|
| 23 |
ignore.constraints = FALSE, |
|
| 24 |
remove.duplicated = TRUE, |
|
| 25 |
remove.empty.cases = TRUE) {
|
|
| 26 | 3x |
stopifnot(inherits(object, "lavaan")) |
| 27 | ||
| 28 |
# check object |
|
| 29 | 3x |
object <- lav_object_check_version(object) |
| 30 | ||
| 31 |
# what if estimator is not ML or WLS? |
|
| 32 |
# avoid hard error (using stop); throw a warning, and return an empty matrix |
|
| 33 | 3x |
if (!object@Options$estimator %in% c("ML", "WLS", "GLS", "ULS")) {
|
| 34 | ! |
lav_msg_warn(gettext("scores only availalbe if estimator is ML"))
|
| 35 | ! |
return(matrix(0, 0, 0)) |
| 36 |
} |
|
| 37 | ||
| 38 |
# check if conditional.x = TRUE |
|
| 39 | 3x |
if (object@Model@conditional.x) {
|
| 40 | ! |
lav_msg_stop(gettext("scores not available (yet) if conditional.x = TRUE"))
|
| 41 |
} |
|
| 42 | ||
| 43 |
# shortcuts |
|
| 44 | 3x |
lavdata <- object@Data |
| 45 | 3x |
lavmodel <- object@Model |
| 46 | 3x |
lavsamplestats <- object@SampleStats |
| 47 | 3x |
lavoptions <- object@Options |
| 48 | ||
| 49 |
## number variables/sample size |
|
| 50 |
# ntab <- unlist(lavsamplestats@nobs) |
|
| 51 |
## change in 0.5-17: we keep the 'empty cases' |
|
| 52 |
## and 'fill' in the scores at their 'case.idx' |
|
| 53 |
## later, we remove the 'empty rows' |
|
| 54 |
# ntot <- max( object@Data@case.idx[[ object@Data@ngroups ]] ) |
|
| 55 | 3x |
ntab <- unlist(lavdata@norig) |
| 56 | 3x |
ntot <- sum(ntab) |
| 57 | 3x |
npar <- lav_object_inspect_npar(object, ceq = FALSE) |
| 58 | ||
| 59 | 3x |
if (object@Options$estimator == "ML") {
|
| 60 | 2x |
moments <- fitted(object) |
| 61 | 2x |
score_matrix <- lav_scores_ml( |
| 62 | 2x |
ntab = ntab, ntot = ntot, npar = npar, |
| 63 | 2x |
moments = moments, lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 64 | 2x |
lavmodel = lavmodel, lavoptions = lavoptions, scaling = scaling |
| 65 |
) |
|
| 66 | 1x |
} else if (object@Options$estimator == "WLS" && lavmodel@categorical) {
|
| 67 |
# check if ALL observed variables are ordered |
|
| 68 | ! |
ov.names <- unlist(lavdata@ov.names) |
| 69 | ! |
ov.idx <- which(lavdata@ov$name %in% ov.names) |
| 70 | ! |
if (!all(lavdata@ov$type[ov.idx] == "ordered")) {
|
| 71 | ! |
lav_msg_stop(gettext( |
| 72 | ! |
"WLS scores only available if all observed variables are ordered.")) |
| 73 |
} |
|
| 74 | ||
| 75 |
# compute WLS scores |
|
| 76 | ! |
score_matrix <- lav_scores_wls( |
| 77 | ! |
ntab = ntab, ntot = ntot, npar = npar, |
| 78 | ! |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 79 | ! |
lavmodel = lavmodel, lavoptions = lavoptions |
| 80 |
) |
|
| 81 | 1x |
} else if (!lavmodel@categorical && |
| 82 | 1x |
object@Options$estimator %in% c("GLS", "ULS", "WLS")) {
|
| 83 |
# compute WLS/GLS/ULS `scores' |
|
| 84 | 1x |
score_matrix <- lav_scores_ls( |
| 85 | 1x |
ntab = ntab, ntot = ntot, npar = npar, |
| 86 | 1x |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 87 | 1x |
lavmodel = lavmodel, lavoptions = lavoptions |
| 88 |
) |
|
| 89 |
} else {
|
|
| 90 |
# should not happen |
|
| 91 | ! |
lav_msg_fixme("this should not happen")
|
| 92 |
} |
|
| 93 | ||
| 94 |
# handle empty rows |
|
| 95 | 2x |
if (remove.empty.cases) {
|
| 96 |
# empty.idx <- which( apply(score_matrix, 1L, |
|
| 97 |
# function(x) sum(is.na(x))) == ncol(score_matrix) ) |
|
| 98 | 2x |
empty.idx <- unlist(lapply(lavdata@Mp, "[[", "empty.idx")) |
| 99 | 2x |
if (length(empty.idx) > 0L) {
|
| 100 | ! |
score_matrix <- score_matrix[-empty.idx, , drop = FALSE] |
| 101 |
} |
|
| 102 |
} |
|
| 103 | ||
| 104 |
# provide column names |
|
| 105 | 2x |
colnames(score_matrix) <- names(lav_object_inspect_coef(object, |
| 106 | 2x |
type = "free", add.labels = TRUE |
| 107 |
)) |
|
| 108 | ||
| 109 |
# handle general constraints, so that the sum of the columns equals zero |
|
| 110 | 2x |
if (!ignore.constraints && |
| 111 | 2x |
sum( |
| 112 | 2x |
lavmodel@ceq.linear.idx, lavmodel@ceq.nonlinear.idx, |
| 113 | 2x |
lavmodel@cin.linear.idx, lavmodel@cin.nonlinear.idx |
| 114 | 2x |
) > 0) {
|
| 115 | 1x |
r_matrix <- object@Model@con.jac[, ] |
| 116 | 1x |
pre <- lav_constraints_lambda_pre(object) |
| 117 |
# LAMBDA <- -1 * t(pre %*% t(score_matrix)) |
|
| 118 |
# RLAMBDA <- t(t(r_matrix) %*% t(LAMBDA)) |
|
| 119 | 1x |
score_matrix <- score_matrix - t(t(r_matrix) %*% pre %*% t(score_matrix)) |
| 120 |
} |
|
| 121 | ||
| 122 |
# handle simple equality constraints |
|
| 123 | 2x |
if (remove.duplicated && lavmodel@eq.constraints) {
|
| 124 | 1x |
simple.flag <- lav_constraints_check_simple(lavmodel) |
| 125 | 1x |
if (simple.flag) {
|
| 126 | 1x |
k_matrix <- lav_constraints_R2K(lavmodel) |
| 127 | 1x |
score_matrix <- score_matrix %*% k_matrix |
| 128 |
} else {
|
|
| 129 | ! |
lav_msg_warn(gettext( |
| 130 | ! |
"remove.duplicated is TRUE, but equality constraints do not appear |
| 131 | ! |
to be simple; returning full scores")) |
| 132 |
} |
|
| 133 |
} |
|
| 134 | ||
| 135 | 2x |
score_matrix |
| 136 |
} |
|
| 137 |
lavScores <- lav_scores # synonym #nolint |
|
| 138 |
estfun.lavaan <- lav_scores # synonym |
|
| 139 | ||
| 140 |
lav_scores_ml <- function(ntab = 0L, |
|
| 141 |
ntot = 0L, |
|
| 142 |
npar = 0L, |
|
| 143 |
moments = NULL, |
|
| 144 |
lavdata = NULL, |
|
| 145 |
lavsamplestats = NULL, |
|
| 146 |
lavmodel = NULL, |
|
| 147 |
lavoptions = NULL, |
|
| 148 |
scaling = FALSE) {
|
|
| 149 | 2x |
score_matrix <- matrix(NA, ntot, npar) |
| 150 | ||
| 151 |
# Delta matrix |
|
| 152 | 2x |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 153 | ||
| 154 |
# rename moments |
|
| 155 | 2x |
moments.groups <- moments |
| 156 | ||
| 157 | 2x |
for (g in 1:lavsamplestats@ngroups) {
|
| 158 | 2x |
if (lavsamplestats@ngroups > 1) {
|
| 159 | 1x |
moments <- moments.groups[[g]] |
| 160 |
} |
|
| 161 | 2x |
sigma_hat <- moments$cov |
| 162 | ||
| 163 | 2x |
if (lavoptions$likelihood == "wishart") {
|
| 164 | ! |
nobs1 <- lavsamplestats@nobs[[g]] / (lavsamplestats@nobs[[g]] - 1) |
| 165 |
} else {
|
|
| 166 | 2x |
nobs1 <- 1 |
| 167 |
} |
|
| 168 | ||
| 169 | 2x |
if (!lavsamplestats@missing.flag) { # complete data
|
| 170 |
# if(lavmodel@meanstructure) { # mean structure
|
|
| 171 | 2x |
nvar <- ncol(lavsamplestats@cov[[g]]) |
| 172 | 2x |
mu_hat <- moments$mean |
| 173 | 2x |
X <- lavdata@X[[g]] |
| 174 | 2x |
sigma_inv <- chol2inv(chol(sigma_hat)) # FIXME: check for pd? |
| 175 | 2x |
group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal) |
| 176 | ||
| 177 | 2x |
J <- matrix(1, 1L, ntab[g]) ## FIXME: needed? better maybe rowSums/colSums? |
| 178 | 2x |
J2 <- matrix(1, nvar, nvar) |
| 179 | 2x |
diag(J2) <- 0.5 |
| 180 | ||
| 181 | 2x |
if (lavmodel@meanstructure) {
|
| 182 |
## scores_h1 (H1 = saturated model) |
|
| 183 | 2x |
mean.diff <- t(t(X) - mu_hat %*% J) |
| 184 | 2x |
dx_mu <- -1 * mean.diff %*% sigma_inv |
| 185 | 2x |
dx_sigma <- t(matrix(apply( |
| 186 | 2x |
mean.diff, 1L, |
| 187 | 2x |
function(x) {
|
| 188 | 1204x |
lav_matrix_vech(-J2 * |
| 189 | 1204x |
(sigma_inv %*% (tcrossprod(x) * nobs1 - sigma_hat) %*% sigma_inv)) |
| 190 |
} |
|
| 191 | 2x |
), ncol = nrow(mean.diff))) |
| 192 | ||
| 193 | 2x |
scores_h1 <- cbind(dx_mu, dx_sigma) |
| 194 |
} else {
|
|
| 195 | ! |
mean.diff <- t(t(X) - lavsamplestats@mean[[g]] %*% J) |
| 196 | ! |
dx_sigma <- t(matrix(apply( |
| 197 | ! |
mean.diff, 1L, |
| 198 | ! |
function(x) {
|
| 199 | ! |
lav_matrix_vech(-J2 * |
| 200 | ! |
(sigma_inv %*% (tcrossprod(x) * nobs1 - sigma_hat) %*% sigma_inv)) |
| 201 |
} |
|
| 202 | ! |
), ncol = nrow(mean.diff))) |
| 203 | ! |
scores_h1 <- dx_sigma |
| 204 |
} |
|
| 205 |
## FIXME? Seems like we would need group.w even in the |
|
| 206 |
## complete-data case: |
|
| 207 |
## if(scaling){
|
|
| 208 |
## scores_h1 <- group.w[g] * scores_h1 |
|
| 209 |
## } |
|
| 210 | ||
| 211 |
# } else {
|
|
| 212 |
# ## no mean structure |
|
| 213 |
# stop("Score calculation with no mean structure is not implemented.")
|
|
| 214 |
# } |
|
| 215 |
} else { # incomplete data
|
|
| 216 | ! |
nsub <- ntab[g] |
| 217 | ! |
M <- lavsamplestats@missing[[g]] |
| 218 | ! |
Mp <- lavdata@Mp[[g]] |
| 219 |
# pat.idx <- match(MP1$id, MP1$order) |
|
| 220 | ! |
group.w <- (unlist(lavsamplestats@nobs) / lavsamplestats@ntotal) |
| 221 | ||
| 222 | ! |
mu_hat <- moments$mean |
| 223 | ! |
nvar <- ncol(lavsamplestats@cov[[g]]) |
| 224 | ! |
score.sigma <- matrix(0, nsub, nvar * (nvar + 1) / 2) |
| 225 | ! |
score.mu <- matrix(0, nsub, nvar) |
| 226 | ||
| 227 | ! |
for (p in seq_len(length(M))) {
|
| 228 |
## Data |
|
| 229 |
# X <- M[[p]][["X"]] |
|
| 230 | ! |
case.idx <- Mp$case.idx[[p]] |
| 231 | ! |
var.idx <- M[[p]][["var.idx"]] |
| 232 | ! |
X <- lavdata@X[[g]][case.idx, var.idx, drop = FALSE] |
| 233 | ! |
nobs <- M[[p]][["freq"]] |
| 234 |
## Which unique entries of covariance matrix are estimated? |
|
| 235 |
## (Used to keep track of scores in score.sigma) |
|
| 236 | ! |
var.idx.mat <- tcrossprod(var.idx) |
| 237 | ! |
sigma.idx <- |
| 238 | ! |
which(var.idx.mat[lower.tri(var.idx.mat, diag = TRUE)] == 1) |
| 239 | ||
| 240 | ! |
J <- matrix(1, 1L, nobs) # [var.idx] |
| 241 | ! |
J2 <- matrix(1, nvar, nvar)[var.idx, var.idx, drop = FALSE] |
| 242 | ! |
diag(J2) <- 0.5 |
| 243 |
# FIXME: check for pd? |
|
| 244 | ! |
sigma_inv <- chol2inv(chol(sigma_hat[var.idx, var.idx, drop = FALSE])) |
| 245 | ! |
Mu <- mu_hat[var.idx] |
| 246 | ! |
mean.diff <- t(t(X) - Mu %*% J) |
| 247 | ||
| 248 |
## Scores for missing pattern p within group g |
|
| 249 | ! |
score.mu[case.idx, var.idx] <- -1 * mean.diff %*% sigma_inv |
| 250 | ! |
score.sigma[case.idx, sigma.idx] <- t(matrix(apply( |
| 251 | ! |
mean.diff, 1L, |
| 252 | ! |
function(x) {
|
| 253 | ! |
lav_matrix_vech(-J2 * |
| 254 | ! |
(sigma_inv %*% (tcrossprod(x) - |
| 255 | ! |
sigma_hat[var.idx, var.idx, drop = FALSE]) %*% sigma_inv)) |
| 256 |
} |
|
| 257 | ! |
), ncol = nrow(mean.diff))) |
| 258 |
} |
|
| 259 | ||
| 260 | ! |
scores_h1 <- cbind(score.mu, score.sigma) |
| 261 | ! |
if (scaling) {
|
| 262 | ! |
scores_h1 <- group.w[g] * scores_h1 |
| 263 |
} |
|
| 264 |
} # missing |
|
| 265 | ||
| 266 |
# if(lavmodel@eq.constraints) {
|
|
| 267 |
# Delta <- Delta %*% lavmodel@eq.constraints.K |
|
| 268 |
# #x <- as.numeric(lavmodel@eq.constraints.K %*% x) + |
|
| 269 |
# # lavmodel@eq.constraints.k0 |
|
| 270 |
# } |
|
| 271 | 2x |
wi <- lavdata@case.idx[[g]] |
| 272 | 2x |
score_matrix[wi, ] <- -scores_h1 %*% Delta[[g]] |
| 273 | 1x |
if (scaling) {
|
| 274 | ! |
score_matrix[wi, ] <- (-1 / ntot) * score_matrix[wi, ] |
| 275 |
} |
|
| 276 |
} # g |
|
| 277 | ||
| 278 | 1x |
score_matrix |
| 279 |
} |
|
| 280 | ||
| 281 |
# this function is based on code originally written by Franz Classe (Munich) |
|
| 282 |
# for categorical data only! |
|
| 283 |
lav_scores_wls <- function(ntab = 0L, |
|
| 284 |
ntot = 0L, |
|
| 285 |
npar = 0L, |
|
| 286 |
lavdata = NULL, |
|
| 287 |
lavsamplestats = NULL, |
|
| 288 |
lavmodel = NULL, |
|
| 289 |
lavoptions = NULL) {
|
|
| 290 |
# internal function |
|
| 291 | ! |
doDummySingleVar <- function(X, lv, ntot, num) {
|
| 292 | ! |
Xd <- matrix(NA, nrow = ntot, ncol = lv[num] - 1) |
| 293 | ! |
x <- X[, num] |
| 294 | ! |
minx <- min(x) |
| 295 | ! |
categ <- minx - 1 |
| 296 | ! |
v <- 1 |
| 297 | ! |
while (categ < lv[num] - 1) {
|
| 298 | ! |
categ <- categ + 1 |
| 299 | ! |
Xd[, v] <- ifelse(x > categ, 1, 0) |
| 300 | ! |
v <- v + 1 |
| 301 |
} |
|
| 302 | ||
| 303 | ! |
Xd |
| 304 |
} |
|
| 305 | ||
| 306 |
# containere for scores |
|
| 307 | ! |
score_matrix <- matrix(NA, ntot, npar) |
| 308 | ||
| 309 |
# Delta matrix |
|
| 310 | ! |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 311 | ||
| 312 |
# shortcuts |
|
| 313 | ! |
lv <- lavdata@ov[["nlev"]] |
| 314 | ||
| 315 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 316 | ! |
nvar <- ncol(lavsamplestats@cov[[g]]) |
| 317 | ! |
X <- lavdata@X[[g]] |
| 318 | ||
| 319 |
# convert categorical data to dummy variables |
|
| 320 |
# FIXME: skip continuous variables |
|
| 321 | ! |
Xd <- do.call( |
| 322 | ! |
cbind, |
| 323 | ! |
lapply( |
| 324 | ! |
1:nvar, |
| 325 | ! |
function(i) doDummySingleVar(X, lv, ntot, i) |
| 326 |
) |
|
| 327 |
) |
|
| 328 | ||
| 329 |
# e1 |
|
| 330 | ! |
musd <- colMeans(Xd) |
| 331 | ! |
e1 <- t(t(Xd) - musd) |
| 332 | ||
| 333 |
# e2 |
|
| 334 | ! |
mus <- colMeans(X) |
| 335 | ! |
y_minus_mu <- t(apply(X, 1L, function(x) x - mus)) |
| 336 | ! |
s_vech <- t(apply(y_minus_mu, 1L, function(i) {
|
| 337 | ! |
lavaan::lav_matrix_vech(tcrossprod(i), diagonal = FALSE) |
| 338 | ! |
})) # s=c( (y1-mu1)(y2-mu2).... |
| 339 | ! |
sigma <- colMeans(s_vech) |
| 340 | ! |
e2 <- t(apply(s_vech, 1L, function(x) x - sigma)) |
| 341 | ||
| 342 |
# e |
|
| 343 | ! |
e <- cbind(e1, e2) |
| 344 | ||
| 345 |
# weight matrix |
|
| 346 | ! |
W <- lavsamplestats@WLS.V[[g]] |
| 347 | ||
| 348 |
# combine matrices |
|
| 349 | ! |
wi <- lavdata@case.idx[[g]] |
| 350 | ! |
score_matrix[wi, ] <- t(t(Delta[[g]]) %*% W %*% t(e)) |
| 351 |
} # g |
|
| 352 | ||
| 353 | ! |
score_matrix |
| 354 |
} |
|
| 355 | ||
| 356 | ||
| 357 |
# wls/gls/uls (continuous data only) |
|
| 358 |
lav_scores_ls <- function(ntab = 0L, |
|
| 359 |
ntot = 0L, |
|
| 360 |
npar = 0L, |
|
| 361 |
lavdata = NULL, |
|
| 362 |
lavsamplestats = NULL, |
|
| 363 |
lavmodel = NULL, |
|
| 364 |
lavoptions = NULL) {
|
|
| 365 | ||
| 366 |
# containere for scores |
|
| 367 | 1x |
score_matrix <- matrix(NA, ntot, npar) |
| 368 | ||
| 369 |
# estimator |
|
| 370 | 1x |
estimator <- lavoptions$estimator |
| 371 | ||
| 372 |
# Delta matrix |
|
| 373 | 1x |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 374 | ||
| 375 |
# implied stats |
|
| 376 | 1x |
implied <- lav_model_implied(lavmodel) |
| 377 | ||
| 378 | 1x |
for (g in 1:lavsamplestats@ngroups) {
|
| 379 | 1x |
nvar <- ncol(lavsamplestats@cov[[g]]) |
| 380 | 1x |
nobs <- lavsamplestats@nobs[[g]] |
| 381 | 1x |
Y <- lavdata@X[[g]] |
| 382 | ||
| 383 |
# center (not using model-implied!) |
|
| 384 | 1x |
Yc <- t(t(Y) - colMeans(Y, na.rm = TRUE)) |
| 385 | ||
| 386 |
# create Z where the rows_i contain the following elements: |
|
| 387 |
# - Y_i (if meanstructure is TRUE) |
|
| 388 |
# - vech(Yc_i' %*% Yc_i) where Yc_i are the residuals |
|
| 389 | 1x |
idx1 <- lav_matrix_vech_col_idx(nvar) |
| 390 | 1x |
idx2 <- lav_matrix_vech_row_idx(nvar) |
| 391 | 1x |
if (lavmodel@meanstructure) {
|
| 392 | 1x |
Z <- cbind(Y, Yc[, idx1, drop = FALSE] * Yc[, idx2, drop = FALSE]) |
| 393 |
} else {
|
|
| 394 | ! |
Z <- (Yc[, idx1, drop = FALSE] * Yc[, idx2, drop = FALSE]) |
| 395 |
} |
|
| 396 | ||
| 397 |
# model-based sample statistics |
|
| 398 | 1x |
if (lavmodel@meanstructure) {
|
| 399 | 1x |
sigma <- c(as.numeric(implied$mean[[g]]), |
| 400 | 1x |
lav_matrix_vech(implied$cov[[g]])) |
| 401 |
} else {
|
|
| 402 | ! |
sigma <- lav_matrix_vech(implied$cov[[g]]) |
| 403 |
} |
|
| 404 | ||
| 405 |
# adjust sigma for N-1, so that colMeans(scores) == gradient |
|
| 406 |
# (not for the means) |
|
| 407 | 1x |
if (lavmodel@meanstructure) {
|
| 408 | 1x |
Z[,-seq_len(nvar)] <- Z[,-seq_len(nvar), drop = FALSE] * nobs / (nobs - 1) |
| 409 |
} else {
|
|
| 410 | ! |
Z <- Z * nobs / (nobs - 1) |
| 411 |
} |
|
| 412 | ||
| 413 |
# compute Zc |
|
| 414 | 1x |
Zc <- t(t(Z) - sigma) |
| 415 | ||
| 416 |
# weight matrix |
|
| 417 | 1x |
if (estimator == "ULS") {
|
| 418 | ! |
W <- diag(ncol(Z)) |
| 419 |
} else {
|
|
| 420 | 1x |
W <- lavsamplestats@WLS.V[[g]] |
| 421 |
} |
|
| 422 | ||
| 423 |
# combine matrices |
|
| 424 | 1x |
wi <- lavdata@case.idx[[g]] |
| 425 | 1x |
score_matrix[wi, ] <- Zc %*% W %*% Delta[[g]] |
| 426 |
} # g |
|
| 427 | ||
| 428 | 1x |
score_matrix |
| 429 |
} |
| 1 |
# chi-square test statistic: |
|
| 2 |
# comparing the current model versus the saturated/unrestricted model |
|
| 3 |
# TDJ 9 April 2024: Add a (hidden) function to update the @test slot |
|
| 4 |
# when the user provides a custom h1 model. Called by |
|
| 5 |
# lav_object_summary and lav_fit_measures(_check_baseline) |
|
| 6 | ||
| 7 |
lavTest <- function(lavobject, test = "standard", |
|
| 8 |
scaled.test = "standard", |
|
| 9 |
output = "list", drop.list.single = TRUE) {
|
|
| 10 | ||
| 11 |
# check object |
|
| 12 | ! |
lavobject <- lav_object_check_version(lavobject) |
| 13 | ||
| 14 |
# check output |
|
| 15 | ! |
output.valid <- c("list", "text")
|
| 16 | ! |
if (!any(output == output.valid)) {
|
| 17 | ! |
lav_msg_stop(gettextf( |
| 18 | ! |
"%1$s argument must be either %2$s", |
| 19 | ! |
"output", lav_msg_view(output.valid, "or") |
| 20 |
)) |
|
| 21 |
} |
|
| 22 |
# extract 'test' slot |
|
| 23 | ! |
TEST <- lavobject@test |
| 24 | ||
| 25 |
# backwards compatibility: |
|
| 26 |
# if (length(TEST) > 0L && is.null(names(TEST))) {
|
|
| 27 |
# names(TEST) <- sapply(TEST, "[[", "test") |
|
| 28 |
# } |
|
| 29 | ||
| 30 |
# which test? |
|
| 31 | ! |
if (!missing(test)) {
|
| 32 |
# check 'test' |
|
| 33 | ! |
if (!is.character(test)) {
|
| 34 | ! |
lav_msg_stop( |
| 35 | ! |
gettextf("%s should be a character string.", "test"))
|
| 36 |
} else {
|
|
| 37 | ! |
test <- lav_test_rename(test, check = TRUE) |
| 38 |
} |
|
| 39 | ||
| 40 |
# check scaled.test |
|
| 41 | ! |
if (!missing(scaled.test)) {
|
| 42 | ! |
if (!is.character(scaled.test)) {
|
| 43 | ! |
lav_msg_stop( |
| 44 | ! |
gettextf("%s should be a character string.", "scaled.test"))
|
| 45 |
} else {
|
|
| 46 | ! |
scaled.test <- lav_test_rename(scaled.test, check = TRUE) |
| 47 |
} |
|
| 48 | ||
| 49 |
# merge |
|
| 50 | ! |
test <- unique(c(test, scaled.test)) |
| 51 | ||
| 52 |
# but "standard" must always be first |
|
| 53 | ! |
standard.idx <- which(test == "standard") |
| 54 | ! |
if (length(standard.idx) > 0L && standard.idx != 1L) {
|
| 55 | ! |
test <- c("standard", test[-standard.idx])
|
| 56 |
} |
|
| 57 |
} |
|
| 58 | ||
| 59 | ! |
if (test[1] == "none") {
|
| 60 | ! |
return(list()) |
| 61 | ! |
} else if (any(test %in% c("bootstrap", "bollen.stine"))) {
|
| 62 | ! |
lav_msg_stop(gettext( |
| 63 | ! |
"please use lavBootstrap() to obtain a bootstrap based test statistic." |
| 64 |
)) |
|
| 65 |
} |
|
| 66 | ||
| 67 |
# check if we already have it: |
|
| 68 | ! |
if (all(test %in% names(TEST))) {
|
| 69 | ! |
info.attr <- attr(TEST, "info") |
| 70 | ! |
test.idx <- which(names(TEST) %in% test) |
| 71 | ! |
TEST <- TEST[test.idx] |
| 72 | ! |
attr(TEST, "info") <- info.attr |
| 73 |
} else {
|
|
| 74 |
# redo ALL of them, even if already have some in TEST |
|
| 75 |
# later, we will allow to also change the options (like information) |
|
| 76 |
# and this should be reflected in the 'info' attribute |
|
| 77 | ||
| 78 |
# fill-in test in Options slot |
|
| 79 | ! |
lavobject@Options$test <- test |
| 80 | ||
| 81 |
# fill-in scaled.test in Options slot |
|
| 82 | ! |
lavobject@Options$scaled.test <- scaled.test |
| 83 | ||
| 84 |
# get requested test statistics |
|
| 85 | ! |
TEST <- lav_model_test(lavobject = lavobject) |
| 86 |
} |
|
| 87 |
} |
|
| 88 | ||
| 89 | ! |
if (output == "list") {
|
| 90 |
# remove 'info' attribute |
|
| 91 | ! |
attr(TEST, "info") <- NULL |
| 92 | ||
| 93 |
# select only those that were requested (eg remove standard) |
|
| 94 | ! |
test.idx <- which(names(TEST) %in% test) |
| 95 | ! |
TEST <- TEST[test.idx] |
| 96 | ||
| 97 |
# if only 1 test, drop outer list |
|
| 98 | ! |
if (length(TEST) == 1L && drop.list.single) {
|
| 99 | ! |
TEST <- TEST[[1]] |
| 100 |
} |
|
| 101 | ||
| 102 | ! |
return(TEST) |
| 103 |
} else {
|
|
| 104 | ! |
lav_test_print(TEST) |
| 105 |
} |
|
| 106 | ||
| 107 | ! |
invisible(TEST) |
| 108 |
} |
|
| 109 | ||
| 110 |
# allow for 'flexible' names for the test statistics |
|
| 111 |
# 0.6-13: if multiple names, order them in such a way |
|
| 112 |
# that the 'scaled' variants appear after the others |
|
| 113 |
lav_test_rename <- function(test, check = FALSE) {
|
|
| 114 | 301x |
test <- tolower(test) |
| 115 | ||
| 116 | 301x |
if (length(target.idx <- which(test %in% |
| 117 | 301x |
c("standard", "chisq", "chi", "chi-square", "chi.square"))) > 0L) {
|
| 118 | 254x |
test[target.idx] <- "standard" |
| 119 |
} |
|
| 120 | 301x |
if (length(target.idx <- which(test %in% |
| 121 | 301x |
c( |
| 122 | 301x |
"satorra", "sb", "satorra.bentler", "satorra-bentler", |
| 123 | 301x |
"m.adjusted", "m", "mean.adjusted", "mean-adjusted" |
| 124 | 301x |
))) > 0L) {
|
| 125 | ! |
test[target.idx] <- "satorra.bentler" |
| 126 |
} |
|
| 127 | 301x |
if (length(target.idx <- which(test %in% |
| 128 | 301x |
c("yuan", "yb", "yuan.bentler", "yuan-bentler"))) > 0L) {
|
| 129 | ! |
test[target.idx] <- "yuan.bentler" |
| 130 |
} |
|
| 131 | 301x |
if (length(target.idx <- which(test %in% |
| 132 | 301x |
c( |
| 133 | 301x |
"yuan.bentler.mplus", "yuan-bentler.mplus", |
| 134 | 301x |
"yuan-bentler-mplus" |
| 135 | 301x |
))) > 0L) {
|
| 136 | 2x |
test[target.idx] <- "yuan.bentler.mplus" |
| 137 |
} |
|
| 138 | 301x |
if (length(target.idx <- which(test %in% |
| 139 | 301x |
c( |
| 140 | 301x |
"mean.var.adjusted", "mean-var-adjusted", "mv", "second.order", |
| 141 | 301x |
"satterthwaite", "mv.adjusted" |
| 142 | 301x |
))) > 0L) {
|
| 143 | ! |
test[target.idx] <- "mean.var.adjusted" |
| 144 |
} |
|
| 145 | 301x |
if (length(target.idx <- which(test %in% |
| 146 | 301x |
c( |
| 147 | 301x |
"mplus6", "scale.shift", "scaled.shifted", |
| 148 | 301x |
"scaled-shifted" |
| 149 | 301x |
))) > 0L) {
|
| 150 | ! |
test[target.idx] <- "scaled.shifted" |
| 151 |
} |
|
| 152 | 301x |
if (length(target.idx <- which(test %in% |
| 153 | 301x |
c("bootstrap", "boot", "bollen.stine", "bollen-stine"))) > 0L) {
|
| 154 | ! |
test[target.idx] <- "bollen.stine" |
| 155 |
} |
|
| 156 | 301x |
if (length(target.idx <- which(test %in% |
| 157 | 301x |
c( |
| 158 | 301x |
"browne", "residual", "residuals", "browne.residual", |
| 159 | 301x |
"browne.residuals", "residual-based", "residual.based", |
| 160 | 301x |
"browne.residuals.adf", "browne.residual.adf" |
| 161 | 301x |
))) > 0L) {
|
| 162 | ! |
test[target.idx] <- "browne.residual.adf" |
| 163 |
} |
|
| 164 | 301x |
if (length(target.idx <- which(test %in% |
| 165 | 301x |
c("browne.residuals.nt", "browne.residual.nt"))) > 0L) {
|
| 166 | ! |
test[target.idx] <- "browne.residual.nt" |
| 167 |
} |
|
| 168 | 301x |
if (length(target.idx <- which(test %in% |
| 169 | 301x |
c("browne.residual.adf.model"))) > 0L) {
|
| 170 | ! |
test[target.idx] <- "browne.residual.adf.model" |
| 171 |
} |
|
| 172 | 301x |
if (length(target.idx <- which(test %in% |
| 173 | 301x |
c( |
| 174 | 301x |
"browne.residuals.nt.model", "browne.residual.nt.model", |
| 175 | 301x |
"rls", "browne.rls", "nt.rls", "nt-rls", "ntrls" |
| 176 | 301x |
))) > 0L) {
|
| 177 | ! |
test[target.idx] <- "browne.residual.nt.model" |
| 178 |
} |
|
| 179 | ||
| 180 | ||
| 181 |
# check? |
|
| 182 | 301x |
if (check) {
|
| 183 |
# report unknown values |
|
| 184 | 301x |
bad.idx <- which(!test %in% c( |
| 185 | 301x |
"standard", "none", "default", |
| 186 | 301x |
"satorra.bentler", |
| 187 | 301x |
"yuan.bentler", |
| 188 | 301x |
"yuan.bentler.mplus", |
| 189 | 301x |
"mean.adjusted", |
| 190 | 301x |
"mean.var.adjusted", |
| 191 | 301x |
"scaled.shifted", |
| 192 | 301x |
"bollen.stine", |
| 193 | 301x |
"browne.residual.nt", |
| 194 | 301x |
"browne.residual.nt.model", |
| 195 | 301x |
"browne.residual.adf", |
| 196 | 301x |
"browne.residual.adf.model" |
| 197 |
)) |
|
| 198 | 301x |
if (length(bad.idx) > 0L) {
|
| 199 | ! |
lav_msg_stop(sprintf( |
| 200 | ! |
ngettext( |
| 201 | ! |
length(test[bad.idx]), |
| 202 | ! |
"invalid value in %1$s argument: %2$s.", |
| 203 | ! |
"invalid values in %1$s argument: %2$s." |
| 204 |
), |
|
| 205 | ! |
"test", lav_msg_view(test[bad.idx], log.sep = "none") |
| 206 |
)) |
|
| 207 |
} |
|
| 208 | ||
| 209 |
# if 'default' is included, length(test) must be 1 |
|
| 210 | 301x |
if (length(test) > 1L && any("default" == test)) {
|
| 211 | ! |
lav_msg_stop( |
| 212 | ! |
gettextf("if test= argument contains \"%s\", it cannot contain
|
| 213 | ! |
additional elements", "default")) |
| 214 |
} |
|
| 215 | ||
| 216 |
# if 'none' is included, length(test) must be 1 |
|
| 217 | 301x |
if (length(test) > 1L && any("none" == test)) {
|
| 218 | ! |
lav_msg_stop( |
| 219 | ! |
gettextf("if test= argument contains \"%s\" it cannot contain
|
| 220 | ! |
additional elements", "none")) |
| 221 |
} |
|
| 222 |
} |
|
| 223 | ||
| 224 |
# reorder: first nonscaled, then scaled |
|
| 225 | 301x |
nonscaled.idx <- which(test %in% c( |
| 226 | 301x |
"standard", "none", "default", |
| 227 | 301x |
"bollen.stine", |
| 228 | 301x |
"browne.residual.nt", |
| 229 | 301x |
"browne.residual.nt.model", |
| 230 | 301x |
"browne.residual.adf", |
| 231 | 301x |
"browne.residual.adf.model" |
| 232 |
)) |
|
| 233 | 301x |
scaled.idx <- which(test %in% c( |
| 234 | 301x |
"satorra.bentler", |
| 235 | 301x |
"yuan.bentler", |
| 236 | 301x |
"yuan.bentler.mplus", |
| 237 | 301x |
"mean.adjusted", |
| 238 | 301x |
"mean.var.adjusted", |
| 239 | 301x |
"scaled.shifted" |
| 240 |
)) |
|
| 241 | 301x |
test <- c(test[nonscaled.idx], test[scaled.idx]) |
| 242 | ||
| 243 | 301x |
test |
| 244 |
} |
|
| 245 | ||
| 246 |
lav_model_test <- function(lavobject = NULL, |
|
| 247 |
lavmodel = NULL, |
|
| 248 |
lavpartable = NULL, |
|
| 249 |
lavsamplestats = NULL, |
|
| 250 |
lavimplied = NULL, |
|
| 251 |
lavh1 = list(), |
|
| 252 |
lavoptions = NULL, |
|
| 253 |
x = NULL, |
|
| 254 |
VCOV = NULL, |
|
| 255 |
lavcache = NULL, |
|
| 256 |
lavdata = NULL, |
|
| 257 |
lavloglik = NULL, |
|
| 258 |
test.UGamma.eigvals = FALSE) {
|
|
| 259 |
# lavobject? |
|
| 260 | 138x |
if (!is.null(lavobject)) {
|
| 261 | ! |
lavmodel <- lavobject@Model |
| 262 | ! |
lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta) |
| 263 | ! |
lavsamplestats <- lavobject@SampleStats |
| 264 | ! |
lavimplied <- lavobject@implied |
| 265 | ! |
lavh1 <- lavobject@h1 |
| 266 | ! |
lavoptions <- lavobject@Options |
| 267 | ! |
x <- lavobject@optim$x |
| 268 | ! |
fx <- lavobject@optim[["fx"]] |
| 269 | ! |
fx.group <- lavobject@optim[["fx.group"]] |
| 270 | ! |
attr(fx, "fx.group") <- fx.group |
| 271 | ! |
attr(x, "fx") <- fx |
| 272 | ! |
VCOV <- lavobject@vcov$vcov |
| 273 | ! |
lavcache <- lavobject@Cache |
| 274 | ! |
lavdata <- lavobject@Data |
| 275 | ! |
lavloglik <- lavobject@loglik |
| 276 |
} |
|
| 277 | ||
| 278 |
# backwards compatibility |
|
| 279 | 138x |
if (is.null(lavoptions$scaled.test)) {
|
| 280 | ! |
lavoptions$scaled.test <- "standard" |
| 281 |
} |
|
| 282 | ||
| 283 | 138x |
test <- test.orig <- lavoptions$test |
| 284 | ||
| 285 | 138x |
TEST <- list() |
| 286 | ||
| 287 |
# degrees of freedom (ignoring constraints) |
|
| 288 | 138x |
df <- lav_partable_df(lavpartable) |
| 289 | ||
| 290 |
# handle equality constraints (note: we ignore inequality constraints, |
|
| 291 |
# active or not!) |
|
| 292 |
# we use the rank of con.jac (even if the constraints are nonlinear) |
|
| 293 | 138x |
if (!lavmodel@cin.simple.only && nrow(lavmodel@con.jac) > 0L) {
|
| 294 | 12x |
ceq.idx <- attr(lavmodel@con.jac, "ceq.idx") |
| 295 | 12x |
if (length(ceq.idx) > 0L) {
|
| 296 | 10x |
neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank |
| 297 | 10x |
df <- df + neq |
| 298 |
} |
|
| 299 | 126x |
} else if (lavmodel@ceq.simple.only) {
|
| 300 |
# needed?? |
|
| 301 | ! |
ndat <- lav_partable_ndat(lavpartable) |
| 302 | ! |
npar <- max(lavpartable$free) |
| 303 | ! |
df <- ndat - npar |
| 304 |
} |
|
| 305 | ||
| 306 |
# shortcut: return empty list if one of the conditions below is true: |
|
| 307 |
# - test == "none" |
|
| 308 |
# - df < 0 |
|
| 309 |
# - estimator == "MML" |
|
| 310 | 138x |
if (test[1] == "none" || df < 0L || lavoptions$estimator == "MML") {
|
| 311 | ! |
TEST[[1]] <- list( |
| 312 | ! |
test = test[1], |
| 313 | ! |
stat = as.numeric(NA), |
| 314 | ! |
stat.group = as.numeric(NA), |
| 315 | ! |
df = df, |
| 316 | ! |
refdistr = "unknown", |
| 317 | ! |
pvalue = as.numeric(NA) |
| 318 |
) |
|
| 319 | ||
| 320 | ! |
if (length(test) > 1L) {
|
| 321 | ! |
TEST[[2]] <- list( |
| 322 | ! |
test = test[2], |
| 323 | ! |
stat = as.numeric(NA), |
| 324 | ! |
stat.group = as.numeric(NA), |
| 325 | ! |
df = df, |
| 326 | ! |
refdistr = "unknown", |
| 327 | ! |
pvalue = as.numeric(NA) |
| 328 |
) |
|
| 329 |
} |
|
| 330 | ||
| 331 | ! |
attr(TEST, "info") <- |
| 332 | ! |
list( |
| 333 | ! |
ngroups = lavdata@ngroups, group.label = lavdata@group.label, |
| 334 | ! |
information = lavoptions$information, |
| 335 | ! |
h1.information = lavoptions$h1.information, |
| 336 | ! |
observed.information = lavoptions$observed.information |
| 337 |
) |
|
| 338 | ||
| 339 | ! |
return(TEST) |
| 340 |
} |
|
| 341 | ||
| 342 | ||
| 343 |
###################### |
|
| 344 |
## TEST == STANDARD ## |
|
| 345 |
###################### |
|
| 346 | ||
| 347 |
# get chisq value, per group |
|
| 348 | ||
| 349 |
# PML |
|
| 350 | 138x |
if (lavoptions$estimator == "PML" && test[1] != "none") {
|
| 351 |
# attention! |
|
| 352 |
# if the thresholds are saturated (ie, nuisance parameters) |
|
| 353 |
# we should use the lav_pml_plrt() function. |
|
| 354 |
# |
|
| 355 |
# BUT, if the thresholds are structured (eg equality constraints) |
|
| 356 |
# then we MUST use the lav_pml_plrt2() function. |
|
| 357 |
# |
|
| 358 |
# This was not done automatically < 0.6-6 |
|
| 359 |
# |
|
| 360 | ||
| 361 | ||
| 362 | ! |
thresholds.structured <- FALSE |
| 363 |
# check |
|
| 364 | ! |
th.idx <- which(lavpartable$op == "|") |
| 365 | ! |
if (any(lavpartable$free[th.idx] == 0L)) {
|
| 366 | ! |
thresholds.structured <- TRUE |
| 367 |
} |
|
| 368 | ||
| 369 | ! |
eq.idx <- which(lavpartable$op == "==") |
| 370 | ! |
if (length(eq.idx) > 0L) {
|
| 371 | ! |
th.labels <- lavpartable$plabel[th.idx] |
| 372 | ! |
eq.labels <- unique(c( |
| 373 | ! |
lavpartable$lhs[eq.idx], |
| 374 | ! |
lavpartable$rhs[eq.idx] |
| 375 |
)) |
|
| 376 | ! |
if (any(th.labels %in% eq.labels)) {
|
| 377 | ! |
thresholds.structured <- TRUE |
| 378 |
} |
|
| 379 |
} |
|
| 380 | ||
| 381 |
# switch between lav_pml_plrt() and lav_pml_plrt2() |
|
| 382 | ! |
if (thresholds.structured) {
|
| 383 | ! |
pml_plrt <- lav_pml_plrt2 |
| 384 |
} else {
|
|
| 385 | ! |
pml_plrt <- lav_pml_plrt |
| 386 |
} |
|
| 387 | ||
| 388 | ! |
PML <- pml_plrt( |
| 389 | ! |
lavobject = NULL, |
| 390 | ! |
lavmodel = lavmodel, |
| 391 | ! |
lavdata = lavdata, |
| 392 | ! |
lavoptions = lavoptions, |
| 393 | ! |
x = x, |
| 394 | ! |
VCOV = VCOV, |
| 395 | ! |
lavcache = lavcache, |
| 396 | ! |
lavsamplestats = lavsamplestats, |
| 397 | ! |
lavpartable = lavpartable |
| 398 |
) |
|
| 399 |
# get chi.group from PML, since we compare to `unrestricted' model, |
|
| 400 |
# NOT observed data |
|
| 401 | ! |
chisq.group <- PML$PLRTH0Sat.group |
| 402 | ||
| 403 |
# twolevel |
|
| 404 | 138x |
} else if (lavdata@nlevels > 1L) {
|
| 405 | 4x |
if (length(lavh1) > 0L) {
|
| 406 |
# LRT |
|
| 407 | 4x |
chisq.group <- -2 * (lavloglik$loglik.group - lavh1$logl$loglik.group) |
| 408 |
} else {
|
|
| 409 | ! |
chisq.group <- rep(as.numeric(NA), lavdata@ngroups) |
| 410 |
} |
|
| 411 | 134x |
} else if (lavdata@missing == "ml" && any(lavdata@Mp[[1]]$coverage == 0)) {
|
| 412 | ! |
if (length(lavh1) > 0L) {
|
| 413 | ! |
chisq.group <- -2 * (lavloglik$loglik.group - lavh1$logl$loglik.group) |
| 414 |
} else {
|
|
| 415 | ! |
chisq.group <- rep(as.numeric(NA), lavdata@ngroups) |
| 416 |
} |
|
| 417 | 134x |
} else if (lavoptions$estimator %in% c("IV")) {
|
| 418 |
# no 'standard' chi-square statistic |
|
| 419 | ! |
chisq.group <- rep(as.numeric(NA), lavdata@ngroups) |
| 420 |
} else {
|
|
| 421 |
# get fx.group |
|
| 422 | 134x |
fx <- attr(x, "fx") |
| 423 | 134x |
fx.group <- attr(fx, "fx.group") |
| 424 | ||
| 425 |
# always compute `standard' test statistic |
|
| 426 |
## FIXME: the NFAC is now implicit in the computation of fx... |
|
| 427 | 134x |
NFAC <- 2 * unlist(lavsamplestats@nobs) |
| 428 | 134x |
if (lavoptions$estimator == "ML" && lavoptions$likelihood == "wishart") {
|
| 429 |
# first divide by two |
|
| 430 | 8x |
NFAC <- NFAC / 2 |
| 431 | 8x |
NFAC <- NFAC - 1 |
| 432 | 8x |
NFAC <- NFAC * 2 |
| 433 | 126x |
} else if (lavoptions$estimator == "DLS") {
|
| 434 | ! |
NFAC <- NFAC / 2 |
| 435 | ! |
NFAC <- NFAC - 1 |
| 436 | ! |
NFAC <- NFAC * 2 |
| 437 |
} |
|
| 438 | ||
| 439 | 134x |
chisq.group <- fx.group * NFAC |
| 440 |
} |
|
| 441 | ||
| 442 |
# check for negative values |
|
| 443 | 138x |
chisq.group[chisq.group < 0] <- 0.0 |
| 444 | ||
| 445 |
# global test statistic |
|
| 446 | 138x |
chisq <- sum(chisq.group) |
| 447 | ||
| 448 |
# reference distribution: always chi-square, except for the |
|
| 449 |
# non-robust version of ULS and PML |
|
| 450 | 138x |
if (lavoptions$estimator %in% c("ULS", "DWLS", "PML")) {
|
| 451 | 4x |
refdistr <- "unknown" |
| 452 | 4x |
pvalue <- as.numeric(NA) |
| 453 |
} else {
|
|
| 454 | 134x |
refdistr <- "chisq" |
| 455 | ||
| 456 |
# pvalue ### FIXME: what if df=0? NA? or 1? or 0? |
|
| 457 |
# this is not trivial, since |
|
| 458 |
# 1 - pchisq(0, df=0) = 1 |
|
| 459 |
# but |
|
| 460 |
# 1 - pchisq(0.00000000001, df=0) = 0 |
|
| 461 |
# and |
|
| 462 |
# 1 - pchisq(0, df=0, ncp=0) = 0 |
|
| 463 |
# |
|
| 464 |
# This is due to different definitions of limits (from the left, |
|
| 465 |
# or from the right) |
|
| 466 |
# |
|
| 467 |
# From 0.5-17 onwards, we will use NA if df=0, to be consistent |
|
| 468 | 134x |
if (df == 0) {
|
| 469 | 26x |
pvalue <- as.numeric(NA) |
| 470 |
} else {
|
|
| 471 | 108x |
pvalue <- 1 - pchisq(chisq, df) |
| 472 |
} |
|
| 473 |
} |
|
| 474 | ||
| 475 | 138x |
TEST[["standard"]] <- list( |
| 476 | 138x |
test = "standard", |
| 477 | 138x |
stat = chisq, |
| 478 | 138x |
stat.group = chisq.group, |
| 479 | 138x |
df = df, |
| 480 | 138x |
refdistr = refdistr, |
| 481 | 138x |
pvalue = pvalue |
| 482 |
) |
|
| 483 | ||
| 484 | 138x |
if (length(test) == 1L && test == "standard") {
|
| 485 |
# we are done |
|
| 486 | 126x |
attr(TEST, "info") <- |
| 487 | 126x |
list( |
| 488 | 126x |
ngroups = lavdata@ngroups, group.label = lavdata@group.label, |
| 489 | 126x |
information = lavoptions$information, |
| 490 | 126x |
h1.information = lavoptions$h1.information, |
| 491 | 126x |
observed.information = lavoptions$observed.information |
| 492 |
) |
|
| 493 | 126x |
return(TEST) |
| 494 |
} else {
|
|
| 495 |
# strip 'standard' from test list |
|
| 496 | 12x |
if (length(test) > 1L) {
|
| 497 | 12x |
standard.idx <- which(test == "standard") |
| 498 | 12x |
if (length(standard.idx) > 0L) {
|
| 499 | 12x |
test <- test[-standard.idx] |
| 500 |
} |
|
| 501 |
} |
|
| 502 |
} |
|
| 503 | ||
| 504 | ||
| 505 | ||
| 506 | ||
| 507 |
###################### |
|
| 508 |
## additional tests ## # new in 0.6-5 |
|
| 509 |
###################### |
|
| 510 | ||
| 511 | 12x |
for (this.test in test) {
|
| 512 | 12x |
if (lavoptions$estimator == "PML") {
|
| 513 | ! |
if (this.test == "mean.var.adjusted") {
|
| 514 | ! |
LABEL <- "mean+var adjusted correction (PML)" |
| 515 | ! |
TEST[[this.test]] <- |
| 516 | ! |
list( |
| 517 | ! |
test = this.test, |
| 518 | ! |
stat = PML$stat, |
| 519 | ! |
stat.group = TEST[[1]]$stat.group * PML$scaling.factor, |
| 520 | ! |
df = PML$df, |
| 521 | ! |
pvalue = PML$p.value, |
| 522 | ! |
scaling.factor = 1 / PML$scaling.factor, |
| 523 | ! |
label = LABEL, |
| 524 | ! |
shift.parameter = as.numeric(NA), |
| 525 | ! |
trace.UGamma = as.numeric(NA), |
| 526 | ! |
trace.UGamma4 = as.numeric(NA), |
| 527 | ! |
trace.UGamma2 = as.numeric(NA), |
| 528 | ! |
UGamma.eigenvalues = as.numeric(NA) |
| 529 |
) |
|
| 530 |
} else {
|
|
| 531 | ! |
lav_msg_warn(gettextf("test option %s not available for estimator PML",
|
| 532 | ! |
this.test)) |
| 533 |
} |
|
| 534 | 12x |
} else if (this.test %in% c( |
| 535 | 12x |
"browne.residual.adf", |
| 536 | 12x |
"browne.residual.adf.model", |
| 537 | 12x |
"browne.residual.nt", |
| 538 | 12x |
"browne.residual.nt.model" |
| 539 |
)) {
|
|
| 540 | ! |
ADF <- TRUE |
| 541 | ! |
if (this.test %in% c( |
| 542 | ! |
"browne.residual.nt", |
| 543 | ! |
"browne.residual.nt.model" |
| 544 |
)) {
|
|
| 545 | ! |
ADF <- FALSE |
| 546 |
} |
|
| 547 | ! |
model.based <- FALSE |
| 548 | ! |
if (this.test %in% c( |
| 549 | ! |
"browne.residual.adf.model", |
| 550 | ! |
"browne.residual.nt.model" |
| 551 |
)) {
|
|
| 552 | ! |
model.based <- TRUE |
| 553 |
} |
|
| 554 | ||
| 555 | ! |
out <- lav_test_browne( |
| 556 | ! |
lavobject = NULL, |
| 557 | ! |
lavdata = lavdata, |
| 558 | ! |
lavsamplestats = lavsamplestats, |
| 559 | ! |
lavmodel = lavmodel, |
| 560 | ! |
lavpartable = lavpartable, |
| 561 | ! |
lavoptions = lavoptions, |
| 562 | ! |
lavh1 = lavh1, |
| 563 | ! |
lavimplied = lavimplied, |
| 564 | ! |
ADF = ADF, |
| 565 | ! |
model.based = model.based |
| 566 |
) |
|
| 567 | ! |
TEST[[this.test]] <- out |
| 568 | 12x |
} else if (this.test %in% c( |
| 569 | 12x |
"satorra.bentler", |
| 570 | 12x |
"mean.var.adjusted", |
| 571 | 12x |
"scaled.shifted" |
| 572 |
)) {
|
|
| 573 |
# which test statistic shall we scale? |
|
| 574 | 4x |
unscaled.TEST <- TEST[[1]] |
| 575 | 4x |
if (lavoptions$scaled.test != "standard") {
|
| 576 | ! |
idx <- which(test.orig == lavoptions$scaled.test) |
| 577 | ! |
if (length(idx) > 0L) {
|
| 578 | ! |
unscaled.TEST <- TEST[[idx[1]]] |
| 579 |
} else {
|
|
| 580 | ! |
lav_msg_warn(gettextf( |
| 581 | ! |
"scaled.test [%1$s] not found among available (non scaled) tests: |
| 582 | ! |
%2$s. Using standard test instead.", |
| 583 | ! |
lavoptions$scaled.test, lav_msg_view(test))) |
| 584 |
} |
|
| 585 |
} |
|
| 586 | ||
| 587 | 4x |
out <- lav_test_satorra_bentler( |
| 588 | 4x |
lavobject = NULL, |
| 589 | 4x |
lavsamplestats = lavsamplestats, |
| 590 | 4x |
lavmodel = lavmodel, |
| 591 | 4x |
lavimplied = lavimplied, |
| 592 | 4x |
lavdata = lavdata, |
| 593 | 4x |
lavoptions = lavoptions, |
| 594 | 4x |
TEST.unscaled = unscaled.TEST, |
| 595 | 4x |
E.inv = attr(VCOV, "E.inv"), |
| 596 | 4x |
Delta = attr(VCOV, "Delta"), |
| 597 | 4x |
WLS.V = attr(VCOV, "WLS.V"), |
| 598 | 4x |
Gamma = attr(VCOV, "Gamma"), |
| 599 | 4x |
test = this.test, |
| 600 | 4x |
method = "original", # since 0.6-13 |
| 601 | 4x |
return.ugamma = FALSE |
| 602 |
) |
|
| 603 | 4x |
TEST[[this.test]] <- out[[this.test]] |
| 604 | 8x |
} else if (this.test %in% c( |
| 605 | 8x |
"yuan.bentler", |
| 606 | 8x |
"yuan.bentler.mplus" |
| 607 |
)) {
|
|
| 608 |
# which test statistic shall we scale? |
|
| 609 | 8x |
unscaled.TEST <- TEST[[1]] |
| 610 | 8x |
if (lavoptions$scaled.test != "standard") {
|
| 611 | ! |
idx <- which(test.orig == lavoptions$scaled.test) |
| 612 | ! |
if (length(idx) > 0L) {
|
| 613 | ! |
unscaled.TEST <- TEST[[idx[1]]] |
| 614 |
} else {
|
|
| 615 | ! |
lav_msg_warn(gettextf( |
| 616 | ! |
"scaled.test [%1$s] not found among available (non scaled) tests: |
| 617 | ! |
%2$s. Using standard test instead.", |
| 618 | ! |
lavoptions$scaled.test, lav_msg_view(test))) |
| 619 |
} |
|
| 620 |
} |
|
| 621 | ||
| 622 | 8x |
out <- lav_test_yuan_bentler( |
| 623 | 8x |
lavobject = NULL, |
| 624 | 8x |
lavsamplestats = lavsamplestats, |
| 625 | 8x |
lavmodel = lavmodel, |
| 626 | 8x |
lavdata = lavdata, |
| 627 | 8x |
lavimplied = lavimplied, |
| 628 | 8x |
lavh1 = lavh1, |
| 629 | 8x |
lavoptions = lavoptions, |
| 630 | 8x |
TEST.unscaled = unscaled.TEST, |
| 631 | 8x |
E.inv = attr(VCOV, "E.inv"), |
| 632 | 8x |
B0.group = attr(VCOV, "B0.group"), |
| 633 | 8x |
test = this.test, |
| 634 | 8x |
mimic = lavoptions$mimic, |
| 635 |
# method = "default", |
|
| 636 | 8x |
return.ugamma = FALSE |
| 637 |
) |
|
| 638 | 8x |
TEST[[this.test]] <- out[[this.test]] |
| 639 | ! |
} else if (this.test == "bollen.stine") {
|
| 640 |
# check if we have bootstrap lavdata |
|
| 641 | ! |
BOOT.TEST <- attr(VCOV, "BOOT.TEST") |
| 642 | ! |
if (is.null(BOOT.TEST)) {
|
| 643 | ! |
if (!is.null(lavoptions$bootstrap)) {
|
| 644 | ! |
R <- lavoptions$bootstrap |
| 645 |
} else {
|
|
| 646 | ! |
R <- 1000L |
| 647 |
} |
|
| 648 | ! |
boot.type <- "bollen.stine" |
| 649 | ! |
BOOT.TEST <- |
| 650 | ! |
lav_bootstrap_internal( |
| 651 | ! |
object = NULL, |
| 652 | ! |
lavmodel. = lavmodel, |
| 653 | ! |
lavsamplestats. = lavsamplestats, |
| 654 | ! |
lavpartable. = lavpartable, |
| 655 | ! |
lavoptions. = lavoptions, |
| 656 | ! |
lavdata. = lavdata, |
| 657 | ! |
R = R, |
| 658 | ! |
type = boot.type, |
| 659 | ! |
FUN = "test" |
| 660 |
) |
|
| 661 | ||
| 662 |
# new in 0.6-12: always warn for failed and nonadmissible |
|
| 663 | ! |
error.idx <- attr(BOOT.TEST, "error.idx") |
| 664 | ! |
nfailed <- length(attr(BOOT.TEST, "error.idx")) # zero if NULL |
| 665 | ! |
if (nfailed > 0L) {
|
| 666 | ! |
lav_msg_warn(gettextf( |
| 667 | ! |
"%d bootstrap runs failed or did not converge.", nfailed |
| 668 |
)) |
|
| 669 |
} |
|
| 670 | ||
| 671 | ! |
notok <- length(attr(BOOT.TEST, "nonadmissible")) # zero if NULL |
| 672 | ! |
if (notok > 0L) {
|
| 673 | ! |
lav_msg_warn(gettextf( |
| 674 | ! |
"%d bootstrap runs resulted in nonadmissible solutions.", notok |
| 675 |
)) |
|
| 676 |
} |
|
| 677 | ||
| 678 | ! |
if (length(error.idx) > 0L) {
|
| 679 |
# new in 0.6-13: we must still remove them! |
|
| 680 | ! |
BOOT.TEST <- BOOT.TEST[-error.idx, , drop = FALSE] |
| 681 |
# this also drops the attributes |
|
| 682 |
} |
|
| 683 | ||
| 684 | ! |
BOOT.TEST <- drop(BOOT.TEST) |
| 685 |
} |
|
| 686 | ||
| 687 |
# bootstrap p-value |
|
| 688 | ! |
boot.larger <- sum(BOOT.TEST > chisq) |
| 689 | ! |
boot.length <- length(BOOT.TEST) |
| 690 | ! |
pvalue.boot <- boot.larger / boot.length |
| 691 | ||
| 692 | ! |
TEST[[this.test]] <- list( |
| 693 | ! |
test = this.test, |
| 694 | ! |
stat = chisq, |
| 695 | ! |
stat.group = chisq.group, |
| 696 | ! |
df = df, |
| 697 | ! |
pvalue = pvalue.boot, |
| 698 | ! |
refdistr = "bootstrap", |
| 699 | ! |
boot.T = BOOT.TEST, |
| 700 | ! |
boot.larger = boot.larger, |
| 701 | ! |
boot.length = boot.length |
| 702 |
) |
|
| 703 |
} |
|
| 704 |
} # additional tests |
|
| 705 | ||
| 706 |
# add additional information as an attribute, needed for independent |
|
| 707 |
# printing |
|
| 708 | 12x |
attr(TEST, "info") <- |
| 709 | 12x |
list( |
| 710 | 12x |
ngroups = lavdata@ngroups, group.label = lavdata@group.label, |
| 711 | 12x |
information = lavoptions$information, |
| 712 | 12x |
h1.information = lavoptions$h1.information, |
| 713 | 12x |
observed.information = lavoptions$observed.information |
| 714 |
) |
|
| 715 | ||
| 716 | 12x |
TEST |
| 717 |
} |
|
| 718 | ||
| 719 |
lav_update_test_custom_h1 <- function(lav_obj_h0, lav_obj_h1) {
|
|
| 720 | ! |
stopifnot(inherits(lav_obj_h0, "lavaan")) |
| 721 | ! |
stopifnot(inherits(lav_obj_h1, "lavaan")) |
| 722 | ||
| 723 |
## this breaks if object not nested in (df >=) h1, so check df |
|
| 724 | ! |
stopifnot(lav_obj_h0@test[[1]]$df >= lav_obj_h1@test[[1]]$df) |
| 725 | ||
| 726 |
## remove any other (potentially hidden) h1 model from BOTH objects |
|
| 727 | ! |
lav_obj_h0@external$h1.model <- NULL |
| 728 | ! |
lav_obj_h1@external$h1.model <- NULL |
| 729 | ||
| 730 |
## save old @test slot as template |
|
| 731 |
## (so the @test[[1]]$df don't change while looping over tests to update) |
|
| 732 | ! |
newTEST <- lav_obj_h0@test |
| 733 | ||
| 734 |
## assemble a call to lavTestLRT() |
|
| 735 | ! |
lrtCallTemplate <- list(quote(lavTestLRT), object = quote(lav_obj_h0), |
| 736 | ! |
quote(lav_obj_h1)) # in ... |
| 737 | ||
| 738 |
## can only update tests available in both objects |
|
| 739 | ! |
testNames0 <- names(lav_obj_h0@test) |
| 740 | ! |
testNames1 <- names(lav_obj_h1@test) |
| 741 | ! |
testNames <- intersect(testNames0, testNames1) |
| 742 | ||
| 743 |
## loop over those tests |
|
| 744 | ! |
for (tn in testNames) {
|
| 745 | ! |
lrtCall <- lrtCallTemplate |
| 746 |
## conditional arguments: |
|
| 747 | ! |
if (tn == "standard") {
|
| 748 | ! |
lrtCall$method <- "standard" |
| 749 | ! |
} else if (tn %in% c("scaled.shifted","mean.var.adjusted")) {
|
| 750 | ! |
if (lav_obj_h0@Options$estimator == "PML") {
|
| 751 | ! |
lrtCall$method <- "mean.var.adjusted.PLRT" |
| 752 |
} else {
|
|
| 753 | ! |
lrtCall$method <- "satorra.2000" |
| 754 |
} |
|
| 755 | ! |
lrtCall$scaled.shifted <- tn == "scaled.shifted" |
| 756 | ! |
} else if (tn %in% c("satorra.bentler",
|
| 757 | ! |
"yuan.bentler","yuan.bentler.mplus")) {
|
| 758 | ! |
lrtCall$test <- tn |
| 759 | ! |
} else if (grepl(pattern = "browne", x = tn)) {
|
| 760 | ! |
lrtCall$type <- tn |
| 761 |
} else {
|
|
| 762 |
#TODO? |
|
| 763 |
# - if (tn %in% c("bootstrap", "bollen.stine")) next
|
|
| 764 |
# - any other possibilities in @test? |
|
| 765 |
} |
|
| 766 | ||
| 767 |
## get new test |
|
| 768 | ! |
if (lav_obj_h0@test[[1]]$df == lav_obj_h1@test[[1]]$df) {
|
| 769 |
## suppress warning about == df |
|
| 770 | ! |
ANOVA <- suppressWarnings(eval(as.call(lrtCall))) |
| 771 |
} else {
|
|
| 772 |
## maybe some other informative warning would be important to see |
|
| 773 | ! |
ANOVA <- eval(as.call(lrtCall)) |
| 774 |
} |
|
| 775 | ||
| 776 | ||
| 777 |
## replace old @test[[tn]] values |
|
| 778 | ! |
newTEST[[tn]]$stat.group <- NULL # avoid wrong stats in summary() header? |
| 779 | ! |
newTEST[[tn]]$stat <- ANOVA["lav_obj_h0" , "Chisq diff"] |
| 780 | ! |
newTEST[[tn]]$df <- ANOVA["lav_obj_h0" , "Df diff" ] |
| 781 | ! |
newTEST[[tn]]$pvalue <- ANOVA["lav_obj_h0" , "Pr(>Chisq)"] |
| 782 | ! |
if (!is.null(newTEST[[tn]]$scaling.factor)) {
|
| 783 | ! |
newTEST[[tn]]$scaling.factor <- attr(ANOVA, "scale")[2] # first row is NA |
| 784 |
} |
|
| 785 | ! |
if (!is.null(newTEST[[tn]]$shift.parameter)) {
|
| 786 | ! |
newTEST[[tn]]$shift.parameter <- attr(ANOVA, "shift")[2] # first row is NA |
| 787 |
} else {
|
|
| 788 |
## unless scaled.shifted, RMSEA is calculated from $standard$stat and |
|
| 789 |
## df == sum($trace.UGamma). Reverse-engineer from $scaling.factor: |
|
| 790 | ! |
newTEST[[tn]]$trace.UGamma <- newTEST[[tn]]$df * newTEST[[tn]]$scaling.factor |
| 791 |
} |
|
| 792 |
## should not be necessary to replace $trace.UGamma2 |
|
| 793 |
## nor to replace $scaling.factor.h0/h1 |
|
| 794 |
} # end loop over tests |
|
| 795 | ||
| 796 |
## assign updated @test slot and return |
|
| 797 | ! |
lav_obj_h0@test <- newTEST |
| 798 | ! |
lav_obj_h0 |
| 799 |
} |
|
| 800 | ||
| 801 |
| 1 |
# the multivariate normal distribution, unrestricted (h1) |
|
| 2 |
# - everything is evalued under the MLEs: Mu = ybar, Sigma = S |
|
| 3 | ||
| 4 |
# 1) loglikelihood h1 (from raw data, or sample statistics) |
|
| 5 |
# 4) hessian h1 around MLEs |
|
| 6 |
# 5) information h1 (restricted Sigma/mu) |
|
| 7 |
# 5a: (unit) expected information h1 (A1 = Gamma.NT^{-1})
|
|
| 8 |
# 5b: (unit) observed information h1 (A1 = Gamma.NT^{-1})
|
|
| 9 |
# 5c: (unit) first.order information h1 (B1 = A1 %*% Gamma %*% A1) |
|
| 10 |
# 6) inverted information h1 mu + vech(Sigma) |
|
| 11 |
# 6a: (unit) inverted expected information (A1.inv = Gamma.NT) |
|
| 12 |
# 6b: (unit) inverted observed information (A1.inv = Gamma.NT) |
|
| 13 |
# 6c: (unit) inverted first-order information (B1.inv) |
|
| 14 |
# 7) ACOV h1 mu + vech(Sigma) |
|
| 15 |
# 7a: 1/N * Gamma.NT |
|
| 16 |
# 7b: 1/N * Gamma.NT |
|
| 17 |
# 7c: 1/N * (Gamma.NT * Gamma^{-1} * Gamma.NT)
|
|
| 18 |
# 7d: 1/N * Gamma (sandwich) |
|
| 19 | ||
| 20 | ||
| 21 |
# YR 25 Mar 2016: first version |
|
| 22 |
# YR 19 Jan 2017: added 6) + 7) |
|
| 23 |
# YR 04 Jan 2020: adjust for sum(wt) != N |
|
| 24 |
# YR 22 Jul 2022: adding correlation= argument for information_expected |
|
| 25 |
# (only for catml; not used if correlation = TRUE!) |
|
| 26 | ||
| 27 |
# 1. log-likelihood h1 |
|
| 28 | ||
| 29 |
# 1a: input is raw data |
|
| 30 |
lav_mvnorm_h1_loglik_data <- function( |
|
| 31 |
Y = NULL, |
|
| 32 |
x.idx = integer(0L), |
|
| 33 |
casewise = FALSE, |
|
| 34 |
wt = NULL, |
|
| 35 |
Sinv.method = "eigen") {
|
|
| 36 | ||
| 37 | ! |
if (!is.null(wt)) {
|
| 38 | ! |
N <- sum(wt) |
| 39 |
} else {
|
|
| 40 | ! |
N <- NROW(Y) |
| 41 |
} |
|
| 42 | ! |
P <- NCOL(Y) |
| 43 | ||
| 44 |
# sample statistics |
|
| 45 | ! |
if (!is.null(wt)) {
|
| 46 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 47 | ! |
sample.mean <- out$center |
| 48 | ! |
sample.cov <- out$cov |
| 49 |
} else {
|
|
| 50 | ! |
sample.mean <- base::.colMeans(Y, m = N, n = P) |
| 51 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 52 |
} |
|
| 53 | ||
| 54 | ! |
if (casewise) {
|
| 55 | ! |
LOG.2PI <- log(2 * pi) |
| 56 | ||
| 57 |
# invert sample.cov |
|
| 58 | ! |
if (Sinv.method == "chol") {
|
| 59 | ! |
cS <- chol(sample.cov) |
| 60 | ! |
icS <- backsolve(cS, diag(P)) |
| 61 | ! |
Yc <- t(t(Y) - sample.mean) |
| 62 | ! |
DIST <- rowSums((Yc %*% icS)^2) |
| 63 | ! |
logdet <- -2 * sum(log(diag(icS))) |
| 64 |
} else {
|
|
| 65 | ! |
sample.cov.inv <- lav_matrix_symmetric_inverse( |
| 66 | ! |
S = sample.cov, |
| 67 | ! |
logdet = TRUE, Sinv.method = Sinv.method |
| 68 |
) |
|
| 69 | ! |
logdet <- attr(sample.cov.inv, "logdet") |
| 70 |
# mahalanobis distance |
|
| 71 | ! |
Yc <- t(t(Y) - sample.mean) |
| 72 | ! |
DIST <- rowSums(Yc %*% sample.cov.inv * Yc) |
| 73 |
} |
|
| 74 | ||
| 75 | ! |
loglik <- -(P * LOG.2PI + logdet + DIST) / 2 |
| 76 | ||
| 77 |
# weights |
|
| 78 | ! |
if (!is.null(wt)) {
|
| 79 | ! |
loglik <- loglik * wt |
| 80 |
} |
|
| 81 |
} else {
|
|
| 82 |
# invert sample.cov |
|
| 83 | ! |
sample.cov.inv <- lav_matrix_symmetric_inverse( |
| 84 | ! |
S = sample.cov, |
| 85 | ! |
logdet = TRUE, Sinv.method = Sinv.method |
| 86 |
) |
|
| 87 | ! |
logdet <- attr(sample.cov.inv, "logdet") |
| 88 | ||
| 89 | ! |
loglik <- |
| 90 | ! |
lav_mvnorm_h1_loglik_samplestats( |
| 91 | ! |
sample.cov.logdet = logdet, |
| 92 | ! |
sample.nvar = P, |
| 93 | ! |
sample.nobs = N |
| 94 |
) |
|
| 95 |
} |
|
| 96 | ||
| 97 |
# fixed.x? |
|
| 98 | ! |
if (length(x.idx) > 0L) {
|
| 99 | ! |
loglik.x <- lav_mvnorm_h1_loglik_data( |
| 100 | ! |
Y = Y[, x.idx, drop = FALSE], |
| 101 | ! |
wt = wt, x.idx = integer(0L), |
| 102 | ! |
casewise = casewise, |
| 103 | ! |
Sinv.method = Sinv.method |
| 104 |
) |
|
| 105 |
# subtract logl.X |
|
| 106 | ! |
loglik <- loglik - loglik.x |
| 107 |
} |
|
| 108 | ||
| 109 | ! |
loglik |
| 110 |
} |
|
| 111 | ||
| 112 | ||
| 113 | ||
| 114 |
# 1b: input are sample statistics only (logdet, N and P) |
|
| 115 |
lav_mvnorm_h1_loglik_samplestats <- function( |
|
| 116 |
sample.cov.logdet = NULL, |
|
| 117 |
sample.nvar = NULL, |
|
| 118 |
sample.nobs = NULL, |
|
| 119 |
# or |
|
| 120 |
sample.cov = NULL, |
|
| 121 |
x.idx = integer(0L), |
|
| 122 |
x.cov = NULL, |
|
| 123 |
Sinv.method = "eigen") {
|
|
| 124 | ||
| 125 | 119x |
if (is.null(sample.nvar)) {
|
| 126 | 60x |
P <- NCOL(sample.cov) |
| 127 |
} else {
|
|
| 128 | 59x |
P <- sample.nvar # number of variables |
| 129 |
} |
|
| 130 | ||
| 131 | 119x |
N <- sample.nobs |
| 132 | 119x |
stopifnot(!is.null(P), !is.null(N)) |
| 133 | ||
| 134 | 119x |
LOG.2PI <- log(2 * pi) |
| 135 | ||
| 136 |
# all we need is the logdet |
|
| 137 | 119x |
if (is.null(sample.cov.logdet)) {
|
| 138 | 60x |
sample.cov.inv <- lav_matrix_symmetric_inverse( |
| 139 | 60x |
S = sample.cov, |
| 140 | 60x |
logdet = TRUE, Sinv.method = Sinv.method |
| 141 |
) |
|
| 142 | 60x |
logdet <- attr(sample.cov.inv, "logdet") |
| 143 |
} else {
|
|
| 144 | 59x |
logdet <- sample.cov.logdet |
| 145 |
} |
|
| 146 | ||
| 147 | 119x |
loglik <- -N / 2 * (P * LOG.2PI + logdet + P) |
| 148 | ||
| 149 |
# fixed.x? |
|
| 150 | 119x |
if (length(x.idx) > 0L) {
|
| 151 | 30x |
if (is.null(sample.cov)) {
|
| 152 | 30x |
if (is.null(x.cov)) {
|
| 153 | ! |
lav_msg_stop(gettext( |
| 154 | ! |
"when x.idx is not empty, we need sample.cov or x.cov" |
| 155 |
)) |
|
| 156 |
} else {
|
|
| 157 | 30x |
sample.cov.x <- x.cov |
| 158 |
} |
|
| 159 |
} else {
|
|
| 160 | ! |
sample.cov.x <- sample.cov[x.idx, x.idx, drop = FALSE] |
| 161 |
} |
|
| 162 | ||
| 163 | 30x |
loglik.x <- |
| 164 | 30x |
lav_mvnorm_h1_loglik_samplestats( |
| 165 | 30x |
sample.cov = sample.cov.x, |
| 166 | 30x |
sample.nobs = sample.nobs, |
| 167 | 30x |
x.idx = integer(0L), |
| 168 | 30x |
Sinv.method = Sinv.method |
| 169 |
) |
|
| 170 |
# subtract logl.X |
|
| 171 | 30x |
loglik <- loglik - loglik.x |
| 172 |
} |
|
| 173 | ||
| 174 | 119x |
loglik |
| 175 |
} |
|
| 176 | ||
| 177 | ||
| 178 |
# 4. hessian of logl (around MLEs of Mu and Sigma) |
|
| 179 | ||
| 180 |
# 4a: hessian logl Mu and vech(Sigma) from raw data |
|
| 181 |
lav_mvnorm_h1_logl_hessian_data <- function( |
|
| 182 |
Y = NULL, |
|
| 183 |
wt = NULL, |
|
| 184 |
x.idx = integer(0L), |
|
| 185 |
Sinv.method = "eigen", |
|
| 186 |
sample.cov.inv = NULL, |
|
| 187 |
meanstructure = TRUE) {
|
|
| 188 | ||
| 189 | ! |
if (!is.null(wt)) {
|
| 190 | ! |
N <- sum(wt) |
| 191 |
} else {
|
|
| 192 | ! |
N <- NROW(Y) |
| 193 |
} |
|
| 194 | ||
| 195 |
# observed information |
|
| 196 | ! |
observed <- lav_mvnorm_h1_information_observed_data( |
| 197 | ! |
Y = Y, wt = wt, |
| 198 | ! |
x.idx = x.idx, |
| 199 | ! |
Sinv.method = Sinv.method, |
| 200 | ! |
sample.cov.inv = sample.cov.inv, |
| 201 | ! |
meanstructure = meanstructure |
| 202 |
) |
|
| 203 | ||
| 204 | ! |
-N * observed |
| 205 |
} |
|
| 206 | ||
| 207 |
# 4b: hessian Mu and vech(Sigma) from samplestats |
|
| 208 |
lav_mvnorm_h1_logl_hessian_samplestats <- function( |
|
| 209 |
sample.mean = NULL, # unused! |
|
| 210 |
sample.cov = NULL, |
|
| 211 |
sample.nobs = NULL, |
|
| 212 |
x.idx = integer(0L), |
|
| 213 |
Sinv.method = "eigen", |
|
| 214 |
sample.cov.inv = NULL, |
|
| 215 |
meanstructure = TRUE) {
|
|
| 216 | ||
| 217 | ! |
N <- sample.nobs |
| 218 | ||
| 219 |
# observed information |
|
| 220 | ! |
observed <- lav_mvnorm_h1_information_observed_samplestats( |
| 221 | ! |
sample.mean = sample.mean, sample.cov = sample.cov, |
| 222 | ! |
x.idx = x.idx, |
| 223 | ! |
Sinv.method = Sinv.method, sample.cov.inv = sample.cov.inv, |
| 224 | ! |
meanstructure = meanstructure |
| 225 |
) |
|
| 226 | ||
| 227 | ! |
-N * observed |
| 228 |
} |
|
| 229 | ||
| 230 | ||
| 231 | ||
| 232 |
# 5) Information h1 (note: expected == observed if data is complete!) |
|
| 233 | ||
| 234 |
# 5a: unit expected information h1 |
|
| 235 |
lav_mvnorm_h1_information_expected <- function( |
|
| 236 |
Y = NULL, |
|
| 237 |
wt = NULL, |
|
| 238 |
sample.cov = NULL, |
|
| 239 |
x.idx = integer(0L), |
|
| 240 |
Sinv.method = "eigen", |
|
| 241 |
sample.cov.inv = NULL, |
|
| 242 |
meanstructure = TRUE, |
|
| 243 |
correlation = FALSE) {
|
|
| 244 | ||
| 245 | ! |
if (is.null(sample.cov.inv)) {
|
| 246 | ! |
if (is.null(sample.cov)) {
|
| 247 | ! |
if (is.null(wt)) {
|
| 248 | ! |
sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y)) |
| 249 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 250 |
} else {
|
|
| 251 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 252 | ! |
sample.cov <- out$cov |
| 253 |
} |
|
| 254 |
} |
|
| 255 | ||
| 256 |
# invert sample.cov |
|
| 257 | ! |
sample.cov.inv <- lav_matrix_symmetric_inverse( |
| 258 | ! |
S = sample.cov, |
| 259 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 260 |
) |
|
| 261 |
} |
|
| 262 | ||
| 263 | ! |
I11 <- sample.cov.inv |
| 264 | ! |
if(correlation) {
|
| 265 |
# if (lav_use_lavaanC()) {
|
|
| 266 |
# I22 <- lavaanC::m_kronecker_dup_cor_pre_post(sample.cov.inv, |
|
| 267 |
# multiplicator = 0.5) |
|
| 268 |
# } else {
|
|
| 269 | ! |
I22 <- 0.5 * lav_matrix_duplication_cor_pre_post(sample.cov.inv %x% |
| 270 | ! |
sample.cov.inv) |
| 271 |
# } |
|
| 272 |
} else {
|
|
| 273 |
# if (lav_use_lavaanC()) {
|
|
| 274 |
# I22 <- lavaanC::m_kronecker_dup_pre_post(sample.cov.inv, |
|
| 275 |
# multiplicator = 0.5) |
|
| 276 |
# } else {
|
|
| 277 | ! |
I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x% |
| 278 | ! |
sample.cov.inv) |
| 279 |
# } |
|
| 280 |
} |
|
| 281 | ||
| 282 |
# fixed.x? |
|
| 283 | ! |
if (length(x.idx) > 0L) {
|
| 284 | ! |
pstar.x <- lav_matrix_vech_which_idx( |
| 285 | ! |
n = NCOL(sample.cov.inv), idx = x.idx |
| 286 |
) |
|
| 287 | ! |
I22[pstar.x, ] <- 0 |
| 288 | ! |
I22[, pstar.x] <- 0 |
| 289 |
} |
|
| 290 | ||
| 291 | ! |
if (meanstructure) {
|
| 292 |
# fixed.x? |
|
| 293 | ! |
if (length(x.idx) > 0L) {
|
| 294 | ! |
I11[x.idx, ] <- 0 |
| 295 | ! |
I11[, x.idx] <- 0 |
| 296 |
} |
|
| 297 | ! |
out <- lav_matrix_bdiag(I11, I22) |
| 298 |
} else {
|
|
| 299 | ! |
out <- I22 |
| 300 |
} |
|
| 301 | ||
| 302 | ! |
out |
| 303 |
} |
|
| 304 | ||
| 305 |
# 5b: unit observed information h1 |
|
| 306 |
lav_mvnorm_h1_information_observed_data <- function( |
|
| 307 |
Y = NULL, |
|
| 308 |
wt = NULL, |
|
| 309 |
x.idx = integer(0L), |
|
| 310 |
Sinv.method = "eigen", |
|
| 311 |
sample.cov.inv = NULL, |
|
| 312 |
meanstructure = TRUE) {
|
|
| 313 | ||
| 314 | ! |
lav_mvnorm_h1_information_expected( |
| 315 | ! |
Y = Y, Sinv.method = Sinv.method, |
| 316 | ! |
wt = wt, x.idx = x.idx, |
| 317 | ! |
sample.cov.inv = sample.cov.inv, |
| 318 | ! |
meanstructure = meanstructure |
| 319 |
) |
|
| 320 |
} |
|
| 321 | ||
| 322 |
# 5b-bis: observed information h1 from sample statistics |
|
| 323 |
lav_mvnorm_h1_information_observed_samplestats <- function( |
|
| 324 |
sample.mean = NULL, # unused! |
|
| 325 |
sample.cov = NULL, |
|
| 326 |
x.idx = integer(0L), |
|
| 327 |
Sinv.method = "eigen", |
|
| 328 |
sample.cov.inv = NULL, |
|
| 329 |
meanstructure = TRUE) {
|
|
| 330 | ||
| 331 | 16x |
if (is.null(sample.cov.inv)) {
|
| 332 |
# invert sample.cov |
|
| 333 | ! |
sample.cov.inv <- lav_matrix_symmetric_inverse( |
| 334 | ! |
S = sample.cov, |
| 335 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 336 |
) |
|
| 337 |
} |
|
| 338 | ||
| 339 | 16x |
I11 <- sample.cov.inv |
| 340 |
# fixed.x? |
|
| 341 | 16x |
if (length(x.idx) > 0L) {
|
| 342 | 12x |
I11[x.idx, ] <- 0 |
| 343 | 12x |
I11[, x.idx] <- 0 |
| 344 |
} |
|
| 345 | ||
| 346 |
# if (lav_use_lavaanC()) {
|
|
| 347 |
# I22 <- lavaanC::m_kronecker_dup_pre_post(sample.cov.inv, |
|
| 348 |
# multiplicator = 0.5) |
|
| 349 |
# } else {
|
|
| 350 | 16x |
I22 <- 0.5 * lav_matrix_duplication_pre_post(sample.cov.inv %x% |
| 351 | 16x |
sample.cov.inv) |
| 352 |
# } |
|
| 353 | ||
| 354 |
# fixed.x? |
|
| 355 | 16x |
if (length(x.idx) > 0L) {
|
| 356 | 12x |
pstar.x <- lav_matrix_vech_which_idx( |
| 357 | 12x |
n = NCOL(sample.cov.inv), idx = x.idx |
| 358 |
) |
|
| 359 | 12x |
I22[pstar.x, ] <- 0 |
| 360 | 12x |
I22[, pstar.x] <- 0 |
| 361 |
} |
|
| 362 | ||
| 363 | 16x |
if (meanstructure) {
|
| 364 | 16x |
out <- lav_matrix_bdiag(I11, I22) |
| 365 |
} else {
|
|
| 366 | ! |
out <- I22 |
| 367 |
} |
|
| 368 | ||
| 369 | 16x |
out |
| 370 |
} |
|
| 371 | ||
| 372 |
# 5c: unit first-order information h1 |
|
| 373 |
# note: first order information h1 == A1 %*% Gamma %*% A1 |
|
| 374 |
# (where A1 = obs/exp information h1) |
|
| 375 |
lav_mvnorm_h1_information_firstorder <- function( |
|
| 376 |
Y = NULL, |
|
| 377 |
wt = NULL, |
|
| 378 |
sample.cov = NULL, |
|
| 379 |
x.idx = integer(0L), |
|
| 380 |
cluster.idx = NULL, |
|
| 381 |
Sinv.method = "eigen", |
|
| 382 |
sample.cov.inv = NULL, |
|
| 383 |
Gamma = NULL, |
|
| 384 |
meanstructure = TRUE) {
|
|
| 385 | ||
| 386 | ! |
if (!is.null(wt)) {
|
| 387 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 388 | ! |
res <- lav_mvnorm_information_firstorder( |
| 389 | ! |
Y = Y, wt = wt, |
| 390 | ! |
cluster.idx = cluster.idx, |
| 391 | ! |
Mu = out$center, Sigma = out$cov, x.idx = x.idx, |
| 392 | ! |
meanstructure = meanstructure |
| 393 |
) |
|
| 394 | ! |
return(res) |
| 395 |
} |
|
| 396 | ||
| 397 |
# sample.cov.inv |
|
| 398 | ! |
if (is.null(sample.cov.inv)) {
|
| 399 |
# invert sample.cov |
|
| 400 | ! |
if (is.null(sample.cov)) {
|
| 401 | ! |
sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y)) |
| 402 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 403 |
} |
|
| 404 | ! |
sample.cov.inv <- lav_matrix_symmetric_inverse( |
| 405 | ! |
S = sample.cov, |
| 406 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 407 |
) |
|
| 408 |
} |
|
| 409 | ||
| 410 |
# question: is there any benefit computing Gamma/A1 instead of just |
|
| 411 |
# calling lav_mvnorm_information_firstorder()? |
|
| 412 |
# answer (2014): probably not; it is just reassuring that the expression |
|
| 413 |
# J = A1 %*% Gamma %*% A1 seems to hold |
|
| 414 | ||
| 415 |
# Gamma |
|
| 416 |
# FIXME: what about the 'unbiased = TRUE' option? |
|
| 417 | ! |
if (is.null(Gamma)) {
|
| 418 | ! |
if (length(x.idx) > 0L) {
|
| 419 | ! |
Gamma <- lav_samplestats_Gamma(Y, |
| 420 | ! |
x.idx = x.idx, fixed.x = TRUE, |
| 421 | ! |
cluster.idx = cluster.idx, |
| 422 | ! |
meanstructure = meanstructure |
| 423 |
) |
|
| 424 |
} else {
|
|
| 425 | ! |
Gamma <- lav_samplestats_Gamma(Y, |
| 426 | ! |
meanstructure = meanstructure, |
| 427 | ! |
cluster.idx = cluster.idx |
| 428 |
) |
|
| 429 |
} |
|
| 430 |
} |
|
| 431 | ||
| 432 |
# sample.cov.inv |
|
| 433 | ! |
if (is.null(sample.cov.inv)) {
|
| 434 |
# invert sample.cov |
|
| 435 | ! |
if (is.null(sample.cov)) {
|
| 436 | ! |
sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y)) |
| 437 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 438 |
} |
|
| 439 | ! |
sample.cov.inv <- lav_matrix_symmetric_inverse( |
| 440 | ! |
S = sample.cov, |
| 441 | ! |
logdet = FALSE, Sinv.method = Sinv.method |
| 442 |
) |
|
| 443 |
} |
|
| 444 | ||
| 445 |
# A1 |
|
| 446 | ! |
A1 <- lav_mvnorm_h1_information_expected( |
| 447 | ! |
Y = Y, Sinv.method = Sinv.method, |
| 448 | ! |
sample.cov.inv = sample.cov.inv, |
| 449 | ! |
x.idx = x.idx, |
| 450 | ! |
meanstructure = meanstructure |
| 451 |
) |
|
| 452 | ||
| 453 | ! |
A1 %*% Gamma %*% A1 |
| 454 |
} |
|
| 455 | ||
| 456 |
# 6) inverted information h1 mu + vech(Sigma) (not used?) |
|
| 457 | ||
| 458 |
# 6a: (unit) inverted expected information (A1.inv = Gamma.NT) |
|
| 459 |
# 6b: (unit) inverted observed information (A1.inv = Gamma.NT) |
|
| 460 | ||
| 461 |
lav_mvnorm_h1_inverted_information_expected <- |
|
| 462 |
lav_mvnorm_h1_inverted_information_observed <- function( |
|
| 463 |
Y = NULL, |
|
| 464 |
wt = NULL, |
|
| 465 |
sample.cov = NULL, |
|
| 466 |
x.idx = integer(0L)) {
|
|
| 467 | ||
| 468 |
# sample.cov |
|
| 469 | ! |
if (is.null(sample.cov)) {
|
| 470 | ! |
if (is.null(wt)) {
|
| 471 | ! |
sample.mean <- base::.colMeans(Y, m = NROW(Y), n = NCOL(Y)) |
| 472 | ! |
sample.cov <- lav_matrix_cov(Y) |
| 473 |
} else {
|
|
| 474 | ! |
out <- stats::cov.wt(Y, wt = wt, method = "ML") |
| 475 | ! |
sample.cov <- out$cov |
| 476 |
} |
|
| 477 |
} |
|
| 478 | ||
| 479 | ! |
if (length(x.idx) > 0L) {
|
| 480 | ! |
Gamma.NT <- lav_samplestats_Gamma_NT( |
| 481 | ! |
Y = Y, wt = wt, x.idx = x.idx, |
| 482 | ! |
COV = sample.cov, |
| 483 | ! |
meanstructure = TRUE, |
| 484 | ! |
fixed.x = TRUE |
| 485 |
) |
|
| 486 |
} else {
|
|
| 487 | ! |
I11 <- sample.cov |
| 488 |
# if (lav_use_lavaanC()) {
|
|
| 489 |
# I22 <- lavaanC::m_kronecker_dup_ginv_pre_post(sample.cov, |
|
| 490 |
# multiplicator = 2.0) |
|
| 491 |
# } else {
|
|
| 492 | ! |
I22 <- 2 * lav_matrix_duplication_ginv_pre_post(sample.cov %x% sample.cov) |
| 493 |
# } |
|
| 494 | ! |
Gamma.NT <- lav_matrix_bdiag(I11, I22) |
| 495 |
} |
|
| 496 | ||
| 497 | ! |
Gamma.NT |
| 498 |
} |
|
| 499 | ||
| 500 |
# 6c: (unit) inverted first-order information (B1.inv) (not used?) |
|
| 501 |
# J1.inv = Gamma.NT %*% solve(Gamma) %*% Gamma.NT |
|
| 502 |
# |
|
| 503 |
lav_mvnorm_h1_inverted_information_firstorder <- function( |
|
| 504 |
Y = NULL, |
|
| 505 |
wt = NULL, |
|
| 506 |
sample.cov = NULL, |
|
| 507 |
x.idx = integer(0L), |
|
| 508 |
Sinv.method = "eigen", |
|
| 509 |
sample.cov.inv = NULL, |
|
| 510 |
Gamma = NULL) {
|
|
| 511 | ||
| 512 |
# lav_samplestats_Gamma() has no wt argument (yet) |
|
| 513 | ! |
if (!is.null(wt)) {
|
| 514 | ! |
lav_msg_stop(gettext("function not supported if wt is not NULL"))
|
| 515 |
} |
|
| 516 | ||
| 517 |
# Gamma |
|
| 518 |
# what about the 'unbiased = TRUE' option? |
|
| 519 | ! |
if (is.null(Gamma)) {
|
| 520 | ! |
if (length(x.idx) > 0L) {
|
| 521 | ! |
Gamma <- lav_samplestats_Gamma(Y, |
| 522 | ! |
x.idx = x.idx, fixed.x = TRUE, |
| 523 | ! |
meanstructure = TRUE |
| 524 |
) |
|
| 525 |
} else {
|
|
| 526 | ! |
Gamma <- lav_samplestats_Gamma(Y, meanstructure = TRUE) |
| 527 |
} |
|
| 528 |
} |
|
| 529 | ||
| 530 |
# Gamma.NT |
|
| 531 | ! |
Gamma.NT <- |
| 532 | ! |
lav_mvnorm_h1_inverted_information_expected( |
| 533 | ! |
Y = Y, |
| 534 | ! |
sample.cov = sample.cov, |
| 535 | ! |
x.idx = x.idx |
| 536 |
) |
|
| 537 | ! |
if (length(x.idx) > 0L) {
|
| 538 |
# FIXME: surely there is better way |
|
| 539 | ! |
out <- Gamma.NT %*% MASS::ginv(Gamma) %*% Gamma.NT |
| 540 |
} else {
|
|
| 541 | ! |
out <- Gamma.NT %*% solve(Gamma, Gamma.NT) |
| 542 |
} |
|
| 543 | ||
| 544 | ! |
out |
| 545 |
} |
|
| 546 | ||
| 547 | ||
| 548 |
# 7) ACOV h1 mu + vech(Sigma) (not used?) |
|
| 549 | ||
| 550 |
# 7a: 1/N * Gamma.NT |
|
| 551 |
# 7b: 1/N * Gamma.NT |
|
| 552 |
lav_mvnorm_h1_acov_expected <- |
|
| 553 |
lav_mvnorm_h1_acov_observed <- function( |
|
| 554 |
Y = NULL, |
|
| 555 |
wt = NULL, |
|
| 556 |
sample.cov = NULL, |
|
| 557 |
x.idx = integer(0L)) {
|
|
| 558 | ||
| 559 | ! |
if (!is.null(wt)) {
|
| 560 | ! |
N <- sum(wt) |
| 561 |
} else {
|
|
| 562 | ! |
N <- NROW(Y) |
| 563 |
} |
|
| 564 | ||
| 565 | ! |
Gamma.NT <- |
| 566 | ! |
lav_mvnorm_h1_inverted_information_expected( |
| 567 | ! |
Y = Y, |
| 568 | ! |
wt = wt, |
| 569 | ! |
sample.cov = sample.cov, |
| 570 | ! |
x.idx = x.idx |
| 571 |
) |
|
| 572 | ||
| 573 | ! |
(1 / N) * Gamma.NT |
| 574 |
} |
|
| 575 | ||
| 576 |
# 7c: 1/N * (Gamma.NT * Gamma^{-1} * Gamma.NT)
|
|
| 577 |
lav_mvnorm_h1_acov_firstorder <- function( |
|
| 578 |
Y = NULL, |
|
| 579 |
wt = NULL, |
|
| 580 |
sample.cov = NULL, |
|
| 581 |
Sinv.method = "eigen", |
|
| 582 |
x.idx = integer(0L), |
|
| 583 |
sample.cov.inv = NULL, |
|
| 584 |
Gamma = NULL) {
|
|
| 585 | ||
| 586 | ! |
if (!is.null(wt)) {
|
| 587 | ! |
N <- sum(wt) |
| 588 |
} else {
|
|
| 589 | ! |
N <- NROW(Y) |
| 590 |
} |
|
| 591 | ||
| 592 | ! |
J1.inv <- lav_mvnorm_h1_inverted_information_firstorder( |
| 593 | ! |
Y = Y, wt = wt, |
| 594 | ! |
sample.cov = sample.cov, |
| 595 | ! |
x.idx = x.idx, Sinv.method = Sinv.method, |
| 596 | ! |
sample.cov.inv = sample.cov.inv, Gamma = Gamma |
| 597 |
) |
|
| 598 | ||
| 599 | ! |
(1 / N) * J1.inv |
| 600 |
} |
|
| 601 | ||
| 602 |
# 7d: 1/N * Gamma (sandwich) |
|
| 603 |
lav_mvnorm_h1_acov_sandwich <- function( |
|
| 604 |
Y = NULL, |
|
| 605 |
wt = NULL, |
|
| 606 |
sample.cov = NULL, |
|
| 607 |
x.idx = integer(0L), |
|
| 608 |
Gamma = NULL) {
|
|
| 609 | ||
| 610 |
# lav_samplestats_Gamma() has no wt argument (yet) |
|
| 611 | ! |
if (!is.null(wt)) {
|
| 612 | ! |
lav_msg_stop(gettext("function not supported if wt is not NULL"))
|
| 613 |
} |
|
| 614 | ||
| 615 |
# if(!is.null(wt)) {
|
|
| 616 |
# N <- sum(wt) |
|
| 617 |
# } else {
|
|
| 618 | ! |
N <- NROW(Y) |
| 619 |
# } |
|
| 620 | ||
| 621 |
# Gamma |
|
| 622 | ! |
if (is.null(Gamma)) {
|
| 623 | ! |
if (length(x.idx) > 0L) {
|
| 624 | ! |
Gamma <- lav_samplestats_Gamma(Y, |
| 625 | ! |
x.idx = x.idx, fixed.x = TRUE, |
| 626 | ! |
meanstructure = TRUE |
| 627 |
) |
|
| 628 |
} else {
|
|
| 629 | ! |
Gamma <- lav_samplestats_Gamma(Y, meanstructure = TRUE) |
| 630 |
} |
|
| 631 |
} |
|
| 632 | ||
| 633 | ! |
(1 / N) * Gamma |
| 634 |
} |
| 1 |
# All code below is written by Myrsini Katsikatsou (Feb 2015) |
|
| 2 | ||
| 3 |
# The following function refers to PLRT for nested models and equality constraints. |
|
| 4 |
# Namely, it is developed to test either of the following hypotheses: |
|
| 5 |
# a) H0 states that some parameters are equal to 0 |
|
| 6 |
# b) H0 states that some parameters are equal to some others. |
|
| 7 |
# Note that for the latter I haven't checked if it is ok when equality constraints |
|
| 8 |
# are imposed on parameters that refer to different groups in a multi-group |
|
| 9 |
# analysis. All the code below has been developed for a single-group analysis. |
|
| 10 | ||
| 11 |
# Let fit_objH0 and fit_objH1 be the outputs of lavaan() function when we fit |
|
| 12 |
# a model under the null hypothesis and under the alternative, respectively. |
|
| 13 |
# The argument equalConstr is logical (T/F) and it is TRUE if equality constraints |
|
| 14 |
# are imposed on subsets of the parameters. |
|
| 15 | ||
| 16 |
# The main idea of the code below is that we consider the parameter vector |
|
| 17 |
# under the alternative H1 evaluated at the values derived under H0 and for these |
|
| 18 |
# values we should evaluate the Hessian, the variability matrix (denoted by J) |
|
| 19 |
# and Godambe matrix. |
|
| 20 | ||
| 21 |
lav_pml_test_plrt <- function(fit_objH0, fit_objH1) {
|
|
| 22 |
# sanity check, perhaps we misordered H0 and H1 in the function call?? |
|
| 23 | ! |
if (fit_objH1@test[[1]]$df > fit_objH0@test[[1]]$df) {
|
| 24 | ! |
tmp <- fit_objH0 |
| 25 | ! |
fit_objH0 <- fit_objH1 |
| 26 | ! |
fit_objH1 <- tmp |
| 27 |
} |
|
| 28 | ||
| 29 |
# check if we have equality constraints |
|
| 30 | ! |
if (fit_objH0@Model@eq.constraints) {
|
| 31 | ! |
equalConstr <- TRUE |
| 32 |
} else {
|
|
| 33 | ! |
equalConstr <- FALSE |
| 34 |
} |
|
| 35 | ||
| 36 | ! |
nsize <- fit_objH0@SampleStats@ntotal |
| 37 | ! |
PLRT <- 2 * (fit_objH1@optim$logl - fit_objH0@optim$logl) |
| 38 | ||
| 39 |
# create a new object 'objH1_h0': the object 'H1', but where |
|
| 40 |
# the parameter values are from H0 |
|
| 41 | ! |
objH1_h0 <- lav_test_diff_m10(m1 = fit_objH1, m0 = fit_objH0, test = FALSE) |
| 42 | ||
| 43 |
# EqMat # YR: from 0.6-2, use lav_test_diff_A() (again) |
|
| 44 |
# this should allow us to test models that are |
|
| 45 |
# nested in the covariance matrix sense, but not |
|
| 46 |
# in the parameter (table) sense |
|
| 47 | ! |
EqMat <- lav_test_diff_A(m1 = fit_objH1, m0 = fit_objH0) |
| 48 | ! |
if (objH1_h0@Model@eq.constraints) {
|
| 49 | ! |
EqMat <- EqMat %*% t(objH1_h0@Model@eq.constraints.K) |
| 50 |
} |
|
| 51 |
# if (equalConstr == TRUE) {
|
|
| 52 |
# EqMat <- fit_objH0@Model@ceq.JAC |
|
| 53 |
# } else {
|
|
| 54 |
# PT0 <- fit_objH0@ParTable |
|
| 55 |
# PT1 <- fit_objH1@ParTable |
|
| 56 |
# h0.par.idx <- which(PT1$free > 0 & !(PT0$free > 0)) |
|
| 57 |
# tmp.ind <- PT1$free[ h0.par.idx ] |
|
| 58 |
# |
|
| 59 |
# no.par0 <- length(tmp.ind) |
|
| 60 |
# tmp.ind2 <- cbind(1:no.par0, tmp.ind ) # matrix indices |
|
| 61 |
# EqMat <- matrix(0, nrow=no.par0, ncol=fit_objH1@Model@nx.free) |
|
| 62 |
# EqMat[tmp.ind2] <- 1 |
|
| 63 |
# } |
|
| 64 | ||
| 65 |
# DEBUG YR -- eliminate the constraints also present in H1 |
|
| 66 |
# -- if we do this, there is no need to use MASS::ginv later |
|
| 67 |
# JAC0 <- fit_objH0@Model@ceq.JAC |
|
| 68 |
# JAC1 <- fit_objH1@Model@ceq.JAC |
|
| 69 |
# unique.idx <- which(apply(JAC0, 1, function(x) {
|
|
| 70 |
# !any(apply(JAC1, 1, function(y) { all(x == y) })) }))
|
|
| 71 |
# if(length(unique.idx) > 0L) {
|
|
| 72 |
# EqMat <- EqMat[unique.idx,,drop = FALSE] |
|
| 73 |
# } |
|
| 74 | ||
| 75 |
# Observed information (= for PML, this is Hessian / N) |
|
| 76 | ! |
Hes.theta0 <- lavTech(objH1_h0, "information.observed") |
| 77 | ||
| 78 |
# handle possible constraints in H1 (and therefore also in objH1_h0) |
|
| 79 | ! |
Inv.Hes.theta0 <- |
| 80 | ! |
lav_model_information_augment_invert( |
| 81 | ! |
lavmodel = objH1_h0@Model, |
| 82 | ! |
information = Hes.theta0, |
| 83 | ! |
inverted = TRUE |
| 84 |
) |
|
| 85 | ||
| 86 |
# the estimated variability matrix is given (=unit information first order) |
|
| 87 | ! |
J.theta0 <- lavTech(objH1_h0, "first.order") |
| 88 | ||
| 89 |
# the Inverse of the G matrix |
|
| 90 | ! |
Inv.G <- Inv.Hes.theta0 %*% J.theta0 %*% Inv.Hes.theta0 |
| 91 | ||
| 92 | ! |
MInvGtM <- EqMat %*% Inv.G %*% t(EqMat) |
| 93 | ! |
MinvHtM <- EqMat %*% Inv.Hes.theta0 %*% t(EqMat) |
| 94 |
# Inv_MinvHtM <- solve(MinvHtM) |
|
| 95 | ! |
Inv_MinvHtM <- MASS::ginv(MinvHtM) |
| 96 | ! |
tmp.prod <- MInvGtM %*% Inv_MinvHtM |
| 97 | ! |
tmp.prod2 <- tmp.prod %*% tmp.prod |
| 98 | ! |
sum.eig <- sum(diag(tmp.prod)) |
| 99 | ! |
sum.eigsq <- sum(diag(tmp.prod2)) |
| 100 | ||
| 101 | ! |
FSMA.PLRT <- (sum.eig / sum.eigsq) * PLRT |
| 102 | ! |
adj.df <- (sum.eig * sum.eig) / sum.eigsq |
| 103 | ! |
pvalue <- 1 - pchisq(FSMA.PLRT, df = adj.df) |
| 104 | ||
| 105 | ! |
list(FSMA.PLRT = FSMA.PLRT, adj.df = adj.df, pvalue = pvalue) |
| 106 |
} |
|
| 107 | ||
| 108 | ||
| 109 |
# for testing: this is the 'original' (using m.el.idx and x.el.idx) |
|
| 110 |
lav_pml_test_plrt2 <- function(fit_objH0, fit_objH1) {
|
|
| 111 | ! |
if (fit_objH1@test[[1]]$df > fit_objH0@test[[1]]$df) {
|
| 112 | ! |
tmp <- fit_objH0 |
| 113 | ! |
fit_objH0 <- fit_objH1 |
| 114 | ! |
fit_objH1 <- tmp |
| 115 |
} |
|
| 116 | ||
| 117 | ! |
if (fit_objH0@Model@eq.constraints) {
|
| 118 | ! |
equalConstr <- TRUE |
| 119 |
} else {
|
|
| 120 | ! |
equalConstr <- FALSE |
| 121 |
} |
|
| 122 | ||
| 123 | ! |
nsize <- fit_objH0@SampleStats@ntotal |
| 124 | ! |
PLRT <- 2 * nsize * (fit_objH0@optim$fx - fit_objH1@optim$fx) |
| 125 | ! |
Npar <- fit_objH1@optim$npar |
| 126 | ! |
MY.m.el.idx2 <- fit_objH1@Model@m.free.idx |
| 127 | ! |
MY.x.el.idx2 <- fit_objH1@Model@x.free.idx |
| 128 | ! |
MY.m.el.idx <- MY.m.el.idx2 |
| 129 | ! |
MY.x.el.idx <- MY.x.el.idx2 |
| 130 | ||
| 131 |
# MY.m.el.idx2 <- fit_objH1@Model@m.free.idx |
|
| 132 |
# MY.m.el.idx2 gives the POSITION index of the free parameters within each |
|
| 133 |
# parameter matrix under H1 model. |
|
| 134 |
# The index numbering restarts from 1 when we move to a new parameter matrix. |
|
| 135 |
# Within each matrix the index numbering "moves" columnwise. |
|
| 136 | ||
| 137 |
# MY.x.el.idx2 <- fit_objH1@Model@x.free.idx |
|
| 138 |
# MY.x.el.idx2 ENUMERATES the free parameters within each parameter matrix. |
|
| 139 |
# The numbering continues as we move from one parameter matrix to the next one. |
|
| 140 | ||
| 141 |
# In the case of the symmetric matrices, Theta and Psi,in some functions below |
|
| 142 |
# we need to give as input MY.m.el.idx2 and MY.x.el.idx2 after |
|
| 143 |
# we have eliminated the information about the redundant parameters |
|
| 144 |
# (those placed above the main diagonal). |
|
| 145 |
# That's why I do the following: |
|
| 146 | ||
| 147 |
# MY.m.el.idx <- MY.m.el.idx2 |
|
| 148 |
# MY.x.el.idx <- MY.x.el.idx2 |
|
| 149 |
# Psi, the variance - covariance matrix of factors |
|
| 150 |
# if( length(MY.x.el.idx2[[3]])!=0 & any(table(MY.x.el.idx2[[3]])>1)) {
|
|
| 151 |
# nfac <- ncol(fit_objH1@Model@GLIST$lambda) #number of factors |
|
| 152 |
# tmp <- matrix(c(1:(nfac^2)), nrow= nfac, ncol= nfac ) |
|
| 153 |
# tmp_keep <- tmp[lower.tri(tmp, diag=TRUE)] |
|
| 154 |
# MY.m.el.idx[[3]] <- MY.m.el.idx[[3]][MY.m.el.idx[[3]] %in% tmp_keep] |
|
| 155 |
# MY.x.el.idx[[3]] <- unique( MY.x.el.idx2[[3]] ) |
|
| 156 |
# } |
|
| 157 | ||
| 158 |
# for Theta, the variance-covariance matrix of measurement errors |
|
| 159 |
# if( length(MY.x.el.idx2[[2]])!=0 & any(table(MY.x.el.idx2[[2]])>1)) {
|
|
| 160 |
# nvar <- fit_objH1@Model@nvar #number of indicators |
|
| 161 |
# tmp <- matrix(c(1:(nvar^2)), nrow= nvar, ncol= nvar ) |
|
| 162 |
# tmp_keep <- tmp[lower.tri(tmp, diag=TRUE)] |
|
| 163 |
# MY.m.el.idx[[2]] <- MY.m.el.idx[[2]][MY.m.el.idx[[2]] %in% tmp_keep] |
|
| 164 |
# MY.x.el.idx[[2]] <- unique( MY.x.el.idx2[[2]] ) |
|
| 165 |
# } |
|
| 166 | ||
| 167 |
# below the commands to find the row-column indices of the Hessian that correspond to |
|
| 168 |
# the parameters to be tested equal to 0 |
|
| 169 |
# tmp.ind contains these indices |
|
| 170 |
# MY.m.el.idx2.H0 <- fit_objH0@Model@m.free.idx |
|
| 171 |
# tmp.ind <- c() |
|
| 172 |
# for(i in 1:6) {
|
|
| 173 |
# tmp.ind <- c(tmp.ind , |
|
| 174 |
# MY.x.el.idx2[[i]] [!(MY.m.el.idx2[[i]] %in% |
|
| 175 |
# MY.m.el.idx2.H0[[i]] ) ] ) |
|
| 176 |
# } |
|
| 177 |
# next line added by YR |
|
| 178 |
# tmp.ind <- unique(tmp.ind) |
|
| 179 | ||
| 180 |
# YR: use partable to find which parameters are restricted in H0 |
|
| 181 |
# (this should work in multiple groups too) |
|
| 182 |
# h0.par.idx <- which( PT.H1.extended$free[PT.H1.extended$user < 2] > 0 & |
|
| 183 |
# !(PT.H0.extended$free[PT.H0.extended$user < 2] > 0) ) |
|
| 184 |
# tmp.ind <- PT.H1.extended$free[ h0.par.idx ] |
|
| 185 |
# print(tmp.ind) |
|
| 186 | ! |
if (length(MY.x.el.idx2[[3]]) != 0 & any(table(MY.x.el.idx2[[3]]) > 1)) {
|
| 187 | ! |
nfac <- ncol(fit_objH1@Model@GLIST$lambda) |
| 188 | ! |
tmp <- matrix(c(1:(nfac * nfac)), nrow = nfac, ncol = nfac) |
| 189 | ! |
tmp_keep <- tmp[lower.tri(tmp, diag = TRUE)] |
| 190 | ! |
MY.m.el.idx[[3]] <- MY.m.el.idx[[3]][MY.m.el.idx[[3]] %in% tmp_keep] |
| 191 | ! |
MY.x.el.idx[[3]] <- unique(MY.x.el.idx2[[3]]) |
| 192 |
} |
|
| 193 | ||
| 194 | ! |
if (length(MY.x.el.idx2[[2]]) != 0 & any(table(MY.x.el.idx2[[2]]) > 1)) {
|
| 195 | ! |
nvar <- fit_objH1@Model@nvar |
| 196 | ! |
tmp <- matrix(c(1:(nvar * nvar)), nrow = nvar, ncol = nvar) |
| 197 | ! |
tmp_keep <- tmp[lower.tri(tmp, diag = TRUE)] |
| 198 | ! |
MY.m.el.idx[[2]] <- MY.m.el.idx[[2]][MY.m.el.idx[[2]] %in% tmp_keep] |
| 199 | ! |
MY.x.el.idx[[2]] <- unique(MY.x.el.idx2[[2]]) |
| 200 |
} |
|
| 201 | ! |
MY.m.el.idx2.H0 <- fit_objH0@Model@m.free.idx |
| 202 | ||
| 203 | ! |
tmp.ind <- c() |
| 204 | ! |
for (i in 1:6) {
|
| 205 | ! |
tmp.ind <- c(tmp.ind, MY.x.el.idx2[[i]][!(MY.m.el.idx2[[i]] %in% |
| 206 | ! |
MY.m.el.idx2.H0[[i]])]) |
| 207 |
} |
|
| 208 | ! |
tmp.ind <- unique(tmp.ind) |
| 209 | ||
| 210 |
# if the models are nested because of equality constraints among the parameters, we need |
|
| 211 |
# to construct the matrix of derivatives of function g(theta) with respect to theta |
|
| 212 |
# where g(theta) is the function that represents the equality constraints. g(theta) is |
|
| 213 |
# an rx1 vector where r are the equality constraints. In the null hypothesis |
|
| 214 |
# we test H0: g(theta)=0. The matrix of derivatives is of dimension: |
|
| 215 |
# nrows= number of free non-redundant parameters under H0, namely |
|
| 216 |
# NparH0 <- fit_objH0[[1]]@optim$npar , and ncols= number of free non-redundant |
|
| 217 |
# parameters under H1, namely NparH1 <- fit_objH0[[1]]@optim$npar. |
|
| 218 |
# The matrix of derivatives of g(theta) is composed of 0's, 1's, -1's, and |
|
| 219 |
# in the rows that refer to odd number of parameters that are equal there is one -2. |
|
| 220 |
# The 1's, -1's (and possibly -2) are the contrast coefficients of the parameters. |
|
| 221 |
# The sum of the rows should be equal to 0. |
|
| 222 |
# if(equalConstr==TRUE) {
|
|
| 223 |
# EqMat <- fit_objH0@Model@ceq.JAC |
|
| 224 |
# } else {
|
|
| 225 |
# no.par0 <- length(tmp.ind) |
|
| 226 |
# tmp.ind2 <- cbind(1:no.par0, tmp.ind) |
|
| 227 |
# EqMat <- matrix(0, nrow = no.par0, ncol = Npar) |
|
| 228 |
# EqMat[tmp.ind2] <- 1 |
|
| 229 |
# } |
|
| 230 | ||
| 231 | ! |
if (equalConstr == TRUE) {
|
| 232 | ! |
EqMat <- fit_objH0@Model@ceq.JAC |
| 233 |
} else {
|
|
| 234 | ! |
no.par0 <- length(tmp.ind) |
| 235 | ! |
tmp.ind2 <- cbind(1:no.par0, tmp.ind) |
| 236 | ! |
EqMat <- matrix(0, nrow = no.par0, ncol = Npar) |
| 237 | ! |
EqMat[tmp.ind2] <- 1 |
| 238 |
} |
|
| 239 | ||
| 240 | ! |
obj <- fit_objH0 |
| 241 | ||
| 242 |
# Compute the sum of the eigenvalues and the sum of the squared eigenvalues |
|
| 243 |
# so that the adjustment to PLRT can be applied. |
|
| 244 |
# Here a couple of functions (e.g. lav_pml_object_inspect_hessian) which are modifications of |
|
| 245 |
# lavaan functions (e.g. getHessian) are needed. These are defined in the end of the file. |
|
| 246 | ||
| 247 |
# the quantity below follows the same logic as getHessian of lavaan 0.5-18 |
|
| 248 |
# and it actually gives N*Hessian. That's why the command following the command below. |
|
| 249 |
# NHes.theta0 <- lav_pml_object_inspect_hessian (object = obj@Model, |
|
| 250 |
# samplestats = obj@SampleStats , |
|
| 251 |
# X = obj@Data@X , |
|
| 252 |
# estimator = "PML", |
|
| 253 |
# lavcache = obj@Cache, |
|
| 254 |
# MY.m.el.idx = MY.m.el.idx, |
|
| 255 |
# MY.x.el.idx = MY.x.el.idx, |
|
| 256 |
# MY.m.el.idx2 = MY.m.el.idx2, # input for lav_pml_object_x2glist |
|
| 257 |
# MY.x.el.idx2 = MY.x.el.idx2, # input for lav_pml_object_x2glist |
|
| 258 |
# Npar = Npar, |
|
| 259 |
# equalConstr=equalConstr) |
|
| 260 | ! |
NHes.theta0 <- lav_pml_object_inspect_hessian( |
| 261 | ! |
object = obj@Model, samplestats = obj@SampleStats, |
| 262 | ! |
X = obj@Data@X, estimator = "PML", lavcache = obj@Cache, |
| 263 | ! |
MY.m.el.idx = MY.m.el.idx, MY.x.el.idx = MY.x.el.idx, |
| 264 | ! |
MY.m.el.idx2 = MY.m.el.idx2, MY.x.el.idx2 = MY.x.el.idx2, |
| 265 | ! |
Npar = Npar, equalConstr = equalConstr |
| 266 |
) |
|
| 267 | ! |
Hes.theta0 <- NHes.theta0 / nsize |
| 268 |
# Inv.Hes.theta0 <- solve(Hes.theta0) |
|
| 269 | ! |
Inv.Hes.theta0 <- MASS::ginv(Hes.theta0) |
| 270 | ||
| 271 | ! |
NJ.theta0 <- lav_pml_object_information_firstorder( |
| 272 | ! |
object = obj, MY.m.el.idx = MY.m.el.idx, |
| 273 | ! |
MY.x.el.idx = MY.x.el.idx, equalConstr = equalConstr |
| 274 |
) |
|
| 275 | ! |
J.theta0 <- NJ.theta0 / (nsize * nsize) |
| 276 | ||
| 277 | ||
| 278 | ! |
Inv.G <- Inv.Hes.theta0 %*% J.theta0 %*% Inv.Hes.theta0 |
| 279 | ! |
MInvGtM <- EqMat %*% Inv.G %*% t(EqMat) |
| 280 | ! |
MinvHtM <- EqMat %*% Inv.Hes.theta0 %*% t(EqMat) |
| 281 |
# Inv_MinvHtM <- solve(MinvHtM) #!!! change names |
|
| 282 | ! |
Inv_MinvHtM <- MASS::ginv(MinvHtM) |
| 283 | ! |
tmp.prod <- MInvGtM %*% Inv_MinvHtM # !!! change names |
| 284 | ! |
tmp.prod2 <- tmp.prod %*% tmp.prod |
| 285 | ! |
sum.eig <- sum(diag(tmp.prod)) |
| 286 | ! |
sum.eigsq <- sum(diag(tmp.prod2)) |
| 287 | ||
| 288 | ||
| 289 | ! |
FSMA.PLRT <- (sum.eig / sum.eigsq) * PLRT |
| 290 | ! |
adj.df <- (sum.eig * sum.eig) / sum.eigsq |
| 291 | ! |
pvalue <- 1 - pchisq(FSMA.PLRT, df = adj.df) |
| 292 | ! |
list(FSMA.PLRT = FSMA.PLRT, adj.df = adj.df, pvalue = pvalue) |
| 293 |
} |
|
| 294 | ||
| 295 | ||
| 296 | ||
| 297 | ||
| 298 |
################################################################################### |
|
| 299 |
# auxiliary functions used above, they are all copy from the corresponding functions |
|
| 300 |
# of lavaan where parts no needed were deleted and some parts were modified. |
|
| 301 |
# I mark the modifications with comments. |
|
| 302 | ||
| 303 | ||
| 304 |
# library(lavaan) |
|
| 305 | ||
| 306 |
# To run an example for the functions below the following input is needed. |
|
| 307 |
# obj <- fit.objH0[[i]] |
|
| 308 |
# object <- obj@Model |
|
| 309 |
# samplestats = obj@SampleStats |
|
| 310 |
# X = obj@Data@X |
|
| 311 |
# estimator = "PML" |
|
| 312 |
# lavcache = obj@Cache |
|
| 313 |
# MY.m.el.idx = MY.m.el.idx |
|
| 314 |
# MY.x.el.idx = MY.x.el.idx |
|
| 315 |
# MY.m.el.idx2 = MY.m.el.idx2 # input for lav_pml_object_x2glist |
|
| 316 |
# MY.x.el.idx2 = MY.x.el.idx2 # input for lav_pml_object_x2glist |
|
| 317 |
# Npar = Npar |
|
| 318 |
# equalConstr =TRUE |
|
| 319 | ||
| 320 |
lav_pml_object_inspect_hessian <- function(object, samplestats, X, |
|
| 321 |
estimator = "PML", lavcache, |
|
| 322 |
MY.m.el.idx, MY.x.el.idx, |
|
| 323 |
MY.m.el.idx2, MY.x.el.idx2, # input for lav_pml_object_x2glist |
|
| 324 |
Npar, # Npar is the number of parameters under H1 |
|
| 325 |
equalConstr) { # takes TRUE/ FALSE
|
|
| 326 | ! |
if (equalConstr) { # !!! added line
|
| 327 |
} |
|
| 328 | ! |
Hessian <- matrix(0, Npar, Npar) # |
| 329 | ||
| 330 |
# !!!! MYfunction below |
|
| 331 | ! |
x <- lav_pml_object_inspect_parameters( |
| 332 | ! |
object = object, |
| 333 | ! |
GLIST = NULL, N = Npar, # N the number of parameters to consider |
| 334 | ! |
MY.m.el.idx = MY.m.el.idx, |
| 335 | ! |
MY.x.el.idx = MY.x.el.idx |
| 336 |
) |
|
| 337 | ||
| 338 | ! |
for (j in 1:Npar) {
|
| 339 | ! |
h.j <- 1e-05 |
| 340 | ! |
x.left <- x.left2 <- x.right <- x.right2 <- x |
| 341 | ! |
x.left[j] <- x[j] - h.j |
| 342 | ! |
x.left2[j] <- x[j] - 2 * h.j |
| 343 | ! |
x.right[j] <- x[j] + h.j |
| 344 | ! |
x.right2[j] <- x[j] + 2 * h.j |
| 345 |
# !!!! MYfunction below : lav_pml_object_inspect_gradient and lav_pml_object_x2glist |
|
| 346 | ! |
g.left <- lav_pml_object_inspect_gradient( |
| 347 | ! |
object = object, |
| 348 | ! |
GLIST = lav_pml_object_x2glist( |
| 349 | ! |
object = object, x = x.left, |
| 350 | ! |
MY.m.el.idx = MY.m.el.idx2, |
| 351 | ! |
MY.x.el.idx = MY.x.el.idx2 |
| 352 |
), |
|
| 353 | ! |
samplestats = samplestats, X = X, |
| 354 | ! |
lavcache = lavcache, estimator = "PML", |
| 355 | ! |
MY.m.el.idx = MY.m.el.idx, |
| 356 | ! |
MY.x.el.idx = MY.x.el.idx, |
| 357 | ! |
equalConstr = equalConstr |
| 358 |
) |
|
| 359 | ||
| 360 | ! |
g.left2 <- lav_pml_object_inspect_gradient( |
| 361 | ! |
object = object, |
| 362 | ! |
GLIST = lav_pml_object_x2glist( |
| 363 | ! |
object = object, x = x.left2, |
| 364 | ! |
MY.m.el.idx = MY.m.el.idx2, |
| 365 | ! |
MY.x.el.idx = MY.x.el.idx2 |
| 366 |
), |
|
| 367 | ! |
samplestats = samplestats, X = X, |
| 368 | ! |
lavcache = lavcache, estimator = "PML", |
| 369 | ! |
MY.m.el.idx = MY.m.el.idx, |
| 370 | ! |
MY.x.el.idx = MY.x.el.idx, |
| 371 | ! |
equalConstr = equalConstr |
| 372 |
) |
|
| 373 | ||
| 374 | ! |
g.right <- lav_pml_object_inspect_gradient( |
| 375 | ! |
object = object, |
| 376 | ! |
GLIST = lav_pml_object_x2glist( |
| 377 | ! |
object = object, x = x.right, |
| 378 | ! |
MY.m.el.idx = MY.m.el.idx2, |
| 379 | ! |
MY.x.el.idx = MY.x.el.idx2 |
| 380 |
), |
|
| 381 | ! |
samplestats = samplestats, X = X, |
| 382 | ! |
lavcache = lavcache, estimator = "PML", |
| 383 | ! |
MY.m.el.idx = MY.m.el.idx, |
| 384 | ! |
MY.x.el.idx = MY.x.el.idx, |
| 385 | ! |
equalConstr = equalConstr |
| 386 |
) |
|
| 387 | ||
| 388 | ! |
g.right2 <- lav_pml_object_inspect_gradient( |
| 389 | ! |
object = object, |
| 390 | ! |
GLIST = lav_pml_object_x2glist( |
| 391 | ! |
object = object, x = x.right2, |
| 392 | ! |
MY.m.el.idx = MY.m.el.idx2, |
| 393 | ! |
MY.x.el.idx = MY.x.el.idx2 |
| 394 |
), |
|
| 395 | ! |
samplestats = samplestats, X = X, |
| 396 | ! |
lavcache = lavcache, estimator = "PML", |
| 397 | ! |
MY.m.el.idx = MY.m.el.idx, |
| 398 | ! |
MY.x.el.idx = MY.x.el.idx, |
| 399 | ! |
equalConstr = equalConstr |
| 400 |
) |
|
| 401 | ||
| 402 | ! |
Hessian[, j] <- (g.left2 - 8 * g.left + 8 * g.right - g.right2) / (12 * h.j) |
| 403 |
} |
|
| 404 | ! |
Hessian <- (Hessian + t(Hessian)) / 2 |
| 405 |
# (-1) * Hessian |
|
| 406 | ! |
Hessian |
| 407 |
} |
|
| 408 |
############################################################################# |
|
| 409 | ||
| 410 | ||
| 411 | ||
| 412 | ||
| 413 |
################################## lav_pml_object_inspect_parameters |
|
| 414 |
# different input arguments: MY.m.el.idx, MY.x.el.idx |
|
| 415 |
lav_pml_object_inspect_parameters <- function(object, GLIST = NULL, N, # N the number of parameters to consider |
|
| 416 |
MY.m.el.idx, MY.x.el.idx) {
|
|
| 417 | ! |
if (is.null(GLIST)) {
|
| 418 | ! |
GLIST <- object@GLIST |
| 419 |
} |
|
| 420 | ||
| 421 | ! |
x <- numeric(N) |
| 422 | ||
| 423 | ! |
for (mm in 1:length(object@GLIST)) { # mm<-1
|
| 424 | ! |
m.idx <- MY.m.el.idx[[mm]] # !!!!! different here and below |
| 425 | ! |
x.idx <- MY.x.el.idx[[mm]] |
| 426 | ! |
x[x.idx] <- GLIST[[mm]][m.idx] |
| 427 |
} |
|
| 428 | ! |
x |
| 429 |
} |
|
| 430 |
############################################################################# |
|
| 431 | ||
| 432 | ||
| 433 | ||
| 434 | ||
| 435 |
############################# lav_pml_object_inspect_gradient |
|
| 436 |
# the difference are the input arguments MY.m.el.idx, MY.x.el.idx |
|
| 437 |
# used in lavaan:::lav_model_delta |
|
| 438 |
lav_pml_object_inspect_gradient <- function(object, GLIST, samplestats = NULL, X = NULL, |
|
| 439 |
lavcache = NULL, estimator = "PML", |
|
| 440 |
MY.m.el.idx, MY.x.el.idx, equalConstr) {
|
|
| 441 | ! |
if (equalConstr) { # added line
|
| 442 |
} |
|
| 443 | ! |
num.idx <- object@num.idx |
| 444 | ! |
th.idx <- object@th.idx |
| 445 | ! |
if (is.null(GLIST)) {
|
| 446 | ! |
GLIST <- object@GLIST |
| 447 |
} |
|
| 448 | ! |
Sigma.hat <- lav_model_sigma(object, GLIST = GLIST, extra = (estimator == "ML")) |
| 449 | ! |
Mu.hat <- lav_model_mu(object, GLIST = GLIST) |
| 450 | ! |
TH <- lav_model_th(object, GLIST = GLIST) |
| 451 | ! |
g <- 1 |
| 452 | ! |
d1 <- lav_pml_dploglik_dimplied( |
| 453 | ! |
Sigma.hat = Sigma.hat[[g]], Mu.hat = Mu.hat[[g]], |
| 454 | ! |
TH = TH[[g]], th.idx = th.idx[[g]], num.idx = num.idx[[g]], |
| 455 | ! |
X = X[[g]], lavcache = lavcache[[g]] |
| 456 |
) |
|
| 457 | ||
| 458 |
# !? if(equalConstr) { #delete the following three commented lines, wrong
|
|
| 459 |
# Delta <- lavaan:::lav_model_delta (lavmodel= object, GLIST. = GLIST) |
|
| 460 |
# } else {
|
|
| 461 | ! |
Delta <- lav_model_delta( |
| 462 | ! |
lavmodel = object, GLIST. = GLIST, |
| 463 | ! |
m.el.idx. = MY.m.el.idx, |
| 464 | ! |
x.el.idx. = MY.x.el.idx |
| 465 |
) |
|
| 466 |
# } |
|
| 467 | ||
| 468 |
# !!!!! that was before: as.numeric(t(d1) %*% Delta[[g]])/samplestats@nobs[[g]] |
|
| 469 | ! |
as.numeric(t(d1) %*% Delta[[g]]) # !!! modified to follow current computeGradient() function of lavaan |
| 470 |
# !!! which gives minus the gradient of PL-loglik |
|
| 471 |
} |
|
| 472 | ||
| 473 |
############################################################################### |
|
| 474 | ||
| 475 | ||
| 476 |
################################## lav_pml_object_x2glist |
|
| 477 |
# difference in input arguments MY.m.el.idx, MY.x.el.idx |
|
| 478 | ||
| 479 |
lav_pml_object_x2glist <- function(object, x = NULL, MY.m.el.idx, MY.x.el.idx) {
|
|
| 480 | ! |
GLIST <- object@GLIST |
| 481 | ! |
for (mm in 1:length(GLIST)) {
|
| 482 | ! |
m.el.idx <- MY.m.el.idx[[mm]] |
| 483 | ! |
x.el.idx <- MY.x.el.idx[[mm]] |
| 484 | ! |
GLIST[[mm]][m.el.idx] <- x[x.el.idx] |
| 485 |
} |
|
| 486 | ! |
GLIST |
| 487 |
} |
|
| 488 |
############################################################################ |
|
| 489 | ||
| 490 | ||
| 491 |
##### lav_pml_object_information_firstorder function |
|
| 492 |
# difference from corresponding of lavaan: I use lav_pml_model_vcov_firstorder |
|
| 493 |
lav_pml_object_information_firstorder <- function(object, MY.m.el.idx, MY.x.el.idx, equalConstr) {
|
|
| 494 | ! |
NACOV <- lav_pml_model_vcov_firstorder( |
| 495 | ! |
lavmodel = object@Model, |
| 496 | ! |
lavsamplestats = object@SampleStats, |
| 497 | ! |
lavdata = object@Data, |
| 498 | ! |
estimator = "PML", |
| 499 | ! |
MY.m.el.idx = MY.m.el.idx, |
| 500 | ! |
MY.x.el.idx = MY.x.el.idx, |
| 501 | ! |
equalConstr = equalConstr |
| 502 |
) |
|
| 503 | ! |
if (equalConstr) { # added lines
|
| 504 |
} |
|
| 505 | ! |
B0 <- attr(NACOV, "B0") |
| 506 |
# !!!! Note below that I don't multiply with nsize |
|
| 507 |
# !!! so what I get is J matrix divided by n |
|
| 508 |
# if (object@Options$estimator == "PML") {
|
|
| 509 |
# B0 <- B0 * object@SampleStats@ntotal |
|
| 510 |
# } |
|
| 511 |
# !!!!!!!!!!!!!!!!!!! added the following lines so that the output of |
|
| 512 |
# !!!!! lav_pml_object_information_firstorder is in line with that of lavaan 0.5-18 getVariability |
|
| 513 |
# !! what's the purpose of the following lines? |
|
| 514 | ! |
if (object@Options$estimator == "PML") {
|
| 515 | ! |
B0 <- B0 * object@SampleStats@ntotal |
| 516 |
} |
|
| 517 | ||
| 518 | ! |
B0 |
| 519 |
} |
|
| 520 | ||
| 521 |
############################################################################## |
|
| 522 |
# example |
|
| 523 |
# obj <- fit.objH0[[i]] |
|
| 524 |
# object <- obj@Model |
|
| 525 |
# samplestats = obj@SampleStats |
|
| 526 |
# X = obj@Data@X |
|
| 527 |
# estimator = "PML" |
|
| 528 |
# lavcache = obj@Cache |
|
| 529 |
# MY.m.el.idx = MY.m.el.idx |
|
| 530 |
# MY.x.el.idx = MY.x.el.idx |
|
| 531 |
# MY.m.el.idx2 = MY.m.el.idx2 # input for lav_pml_object_x2glist |
|
| 532 |
# MY.x.el.idx2 = MY.x.el.idx2 # input for lav_pml_object_x2glist |
|
| 533 |
# Npar = Npar |
|
| 534 |
# equalConstr =TRUE |
|
| 535 | ||
| 536 | ||
| 537 |
lav_pml_model_vcov_firstorder <- function(lavmodel, lavsamplestats = NULL, |
|
| 538 |
lavdata = NULL, lavcache = NULL, |
|
| 539 |
estimator = "PML", |
|
| 540 |
MY.m.el.idx, MY.x.el.idx, |
|
| 541 |
equalConstr) { # equalConstr takes TRUE/FALSE
|
|
| 542 | ! |
if (equalConstr) { # added lines
|
| 543 |
} |
|
| 544 | ! |
B0.group <- vector("list", lavsamplestats@ngroups) # in my case list of length 1
|
| 545 | ||
| 546 |
# !? if (equalConstr) { ###the following three lines are commented because they are wrong
|
|
| 547 |
# Delta <- lavaan:::lav_model_delta(lavmodel, GLIST. = NULL) |
|
| 548 |
# } else {
|
|
| 549 | ! |
Delta <- lav_model_delta(lavmodel, |
| 550 | ! |
GLIST. = NULL, |
| 551 | ! |
m.el.idx. = MY.m.el.idx, # !!!!! different here and below |
| 552 | ! |
x.el.idx. = MY.x.el.idx |
| 553 |
) |
|
| 554 |
# } |
|
| 555 | ! |
Sigma.hat <- lav_model_sigma(lavmodel) |
| 556 | ! |
Mu.hat <- lav_model_mu(lavmodel) |
| 557 | ! |
TH <- lav_model_th(lavmodel) |
| 558 | ! |
g <- 1 |
| 559 | ||
| 560 | ! |
SC <- lav_pml_dploglik_dimplied( |
| 561 | ! |
Sigma.hat = Sigma.hat[[g]], TH = TH[[g]], |
| 562 | ! |
Mu.hat = Mu.hat[[g]], th.idx = lavmodel@th.idx[[g]], |
| 563 | ! |
num.idx = lavmodel@num.idx[[g]], |
| 564 | ! |
X = lavdata@X[[g]], lavcache = lavcache, |
| 565 | ! |
scores = TRUE, negative = FALSE |
| 566 |
) |
|
| 567 | ! |
group.SC <- SC %*% Delta[[g]] |
| 568 | ! |
B0.group[[g]] <- lav_matrix_crossprod(group.SC) |
| 569 |
# !!!! B0.group[[g]] <- B0.group[[g]]/lavsamplestats@ntotal !!! skip so that the result |
|
| 570 |
# is in line with the 0.5-18 version of lavaan |
|
| 571 | ||
| 572 | ! |
B0 <- B0.group[[1]] |
| 573 | ||
| 574 | ! |
E <- B0 |
| 575 | ||
| 576 | ! |
eigvals <- eigen(E, symmetric = TRUE, only.values = TRUE)$values |
| 577 | ! |
if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
|
| 578 | ! |
lav_msg_warn(gettext( |
| 579 | ! |
"matrix based on first order outer product of the derivatives is not |
| 580 | ! |
positive definite; the standard errors may not be thrustworthy")) |
| 581 |
} |
|
| 582 | ! |
NVarCov <- MASS::ginv(E) |
| 583 | ||
| 584 | ! |
attr(NVarCov, "B0") <- B0 |
| 585 | ! |
attr(NVarCov, "B0.group") <- B0.group |
| 586 | ! |
NVarCov |
| 587 |
} |
| 1 |
# functions related to the SRMR fit measures (single level only) |
|
| 2 | ||
| 3 |
# lower-level functions: |
|
| 4 |
# - lav_fit_srmr_mplus |
|
| 5 |
# - lav_fit_srmr_twolevel |
|
| 6 | ||
| 7 |
# higher-level functions: |
|
| 8 |
# - lav_fit_srmr_lavobject |
|
| 9 | ||
| 10 |
# Y.R. 22 July 2022 |
|
| 11 | ||
| 12 |
# Note: for rmrm/srmr/crmr, we use lav_residuals_summmary() |
|
| 13 | ||
| 14 |
# SRMR for continuous data only |
|
| 15 |
# see https://www.statmodel.com/download/SRMR.pdf |
|
| 16 |
lav_fit_srmr_mplus <- function(lavobject) {
|
|
| 17 | ||
| 18 | 23x |
lavsamplestats <- lavobject@SampleStats |
| 19 | 23x |
lavh1 <- lavobject@h1 |
| 20 | ||
| 21 |
# ngroups |
|
| 22 | 23x |
G <- lavobject@Data@ngroups |
| 23 | ||
| 24 |
# container per group |
|
| 25 | 23x |
srmr_mplus.group <- numeric(G) |
| 26 | 23x |
srmr_mplus_nomean.group <- numeric(G) |
| 27 | ||
| 28 |
# If you change how any of the observed/estimated moments below are retrieved, |
|
| 29 |
# please tag @TDJorgensen at the end of the commit message. |
|
| 30 | 23x |
for (g in 1:G) {
|
| 31 |
# observed |
|
| 32 | 24x |
if (!lavsamplestats@missing.flag) {
|
| 33 | 20x |
if (lavobject@Model@conditional.x) {
|
| 34 | 1x |
S <- lavsamplestats@res.cov[[g]] |
| 35 | 1x |
M <- lavsamplestats@res.int[[g]] |
| 36 |
} else {
|
|
| 37 | 19x |
S <- lavsamplestats@cov[[g]] |
| 38 | 19x |
M <- lavsamplestats@mean[[g]] |
| 39 |
} |
|
| 40 |
} else {
|
|
| 41 |
# EM estimates |
|
| 42 | 4x |
if (!is.null(lavh1$implied$cov[[g]])) {
|
| 43 | 4x |
S <- lavh1$implied$cov[[g]] |
| 44 |
} else {
|
|
| 45 | ! |
S <- lavsamplestats@missing.h1[[g]]$sigma |
| 46 |
} |
|
| 47 | 4x |
if (!is.null(lavh1$implied$mean[[g]])) {
|
| 48 | 4x |
M <- lavh1$implied$mean[[g]] |
| 49 |
} else {
|
|
| 50 | ! |
M <- lavsamplestats@missing.h1[[g]]$mu |
| 51 |
} |
|
| 52 |
} |
|
| 53 | 24x |
nvar <- ncol(S) |
| 54 | ||
| 55 |
# estimated |
|
| 56 | 24x |
implied <- lavobject@implied |
| 57 | 24x |
lavmodel <- lavobject@Model |
| 58 | 24x |
Sigma.hat <- if (lavmodel@conditional.x) {
|
| 59 | 1x |
implied$res.cov[[g]] |
| 60 |
} else {
|
|
| 61 | 23x |
implied$cov[[g]] |
| 62 |
} |
|
| 63 | 24x |
Mu.hat <- if (lavmodel@conditional.x) {
|
| 64 | 1x |
implied$res.int[[g]] |
| 65 |
} else {
|
|
| 66 | 23x |
implied$mean[[g]] |
| 67 |
} |
|
| 68 | ||
| 69 |
# Bollen approach: simply using cov2cor ('correlation residuals')
|
|
| 70 | 24x |
S.cor <- cov2cor(S) |
| 71 | 24x |
Sigma.cor <- cov2cor(Sigma.hat) |
| 72 | 24x |
R.cor <- (S.cor - Sigma.cor) |
| 73 | ||
| 74 |
# meanstructure |
|
| 75 | 24x |
if (lavobject@Model@meanstructure) {
|
| 76 |
# standardized residual mean vector |
|
| 77 | 11x |
R.cor.mean <- M / sqrt(diag(S)) - Mu.hat / sqrt(diag(Sigma.hat)) |
| 78 | ||
| 79 | 11x |
e <- nvar * (nvar + 1) / 2 + nvar |
| 80 | 11x |
srmr_mplus.group[g] <- |
| 81 | 11x |
sqrt((sum(R.cor[lower.tri(R.cor, diag = FALSE)]^2) + |
| 82 | 11x |
sum(R.cor.mean^2) + |
| 83 | 11x |
sum(((diag(S) - diag(Sigma.hat)) / diag(S))^2)) / e) |
| 84 | ||
| 85 | 11x |
e <- nvar * (nvar + 1) / 2 |
| 86 | 11x |
srmr_mplus_nomean.group[g] <- |
| 87 | 11x |
sqrt((sum(R.cor[lower.tri(R.cor, diag = FALSE)]^2) + |
| 88 | 11x |
sum(((diag(S) - diag(Sigma.hat)) / diag(S))^2)) / e) |
| 89 |
} else {
|
|
| 90 | 13x |
e <- nvar * (nvar + 1) / 2 |
| 91 | 13x |
srmr_mplus_nomean.group[g] <- srmr_mplus.group[g] <- |
| 92 | 13x |
sqrt((sum(R.cor[lower.tri(R.cor, diag = FALSE)]^2) + |
| 93 | 13x |
sum(((diag(S) - diag(Sigma.hat)) / diag(S))^2)) / e) |
| 94 |
} |
|
| 95 |
} # G |
|
| 96 | ||
| 97 | 23x |
attr(srmr_mplus.group, "nomean") <- srmr_mplus_nomean.group |
| 98 | 23x |
srmr_mplus.group |
| 99 |
} |
|
| 100 | ||
| 101 |
lav_fit_srmr_twolevel <- function(lavobject = NULL) {
|
|
| 102 | 1x |
nlevels <- lavobject@Data@nlevels |
| 103 | 1x |
G <- lavobject@Data@ngroups |
| 104 | ||
| 105 | 1x |
SRMR.within <- numeric(G) |
| 106 | 1x |
SRMR.between <- numeric(G) |
| 107 | 1x |
for (g in 1:G) {
|
| 108 | 2x |
b.within <- (g - 1L) * nlevels + 1L |
| 109 | 2x |
b.between <- (g - 1L) * nlevels + 2L |
| 110 | ||
| 111 |
# OBSERVED # if these change, tag @TDJorgensen in commit message |
|
| 112 | 2x |
S.within <- lavobject@h1$implied$cov[[b.within]] |
| 113 | 2x |
M.within <- lavobject@h1$implied$mean[[b.within]] |
| 114 | 2x |
S.between <- lavobject@h1$implied$cov[[b.between]] |
| 115 | 2x |
M.between <- lavobject@h1$implied$mean[[b.between]] |
| 116 | ||
| 117 |
# ESTIMATED # if these change, tag @TDJorgensen in commit message |
|
| 118 | 2x |
implied <- lav_model_implied_cond2uncond(lavobject@implied) |
| 119 | 2x |
Sigma.within <- implied$cov[[b.within]] |
| 120 | 2x |
Mu.within <- implied$mean[[b.within]] |
| 121 | 2x |
Sigma.between <- implied$cov[[b.between]] |
| 122 | 2x |
Mu.between <- implied$mean[[b.between]] |
| 123 | ||
| 124 |
# force pd for between |
|
| 125 |
# S.between <- lav_matrix_symmetric_force_pd(S.between) |
|
| 126 | 2x |
Sigma.between <- lav_matrix_symmetric_force_pd(Sigma.between) |
| 127 | ||
| 128 |
# Bollen approach: simply using cov2cor ('residual correlations')
|
|
| 129 | 2x |
S.within.cor <- cov2cor(S.within) |
| 130 | 2x |
S.between.cor <- cov2cor(S.between) |
| 131 | 2x |
Sigma.within.cor <- cov2cor(Sigma.within) |
| 132 | 2x |
if (all(diag(Sigma.between) > 0)) {
|
| 133 | 2x |
Sigma.between.cor <- cov2cor(Sigma.between) |
| 134 |
} else {
|
|
| 135 | ! |
Sigma.between.cor <- matrix(as.numeric(NA), |
| 136 | ! |
nrow = nrow(Sigma.between), |
| 137 | ! |
ncol = ncol(Sigma.between) |
| 138 |
) |
|
| 139 |
} |
|
| 140 | 2x |
R.within.cor <- (S.within.cor - Sigma.within.cor) |
| 141 | 2x |
R.between.cor <- (S.between.cor - Sigma.between.cor) |
| 142 | ||
| 143 | 2x |
nvar.within <- NCOL(S.within) |
| 144 | 2x |
nvar.between <- NCOL(S.between) |
| 145 | 2x |
pstar.within <- nvar.within * (nvar.within + 1) / 2 |
| 146 | 2x |
pstar.between <- nvar.between * (nvar.between + 1) / 2 |
| 147 | ||
| 148 |
# SRMR |
|
| 149 | 2x |
SRMR.within[g] <- sqrt(sum(lav_matrix_vech(R.within.cor)^2) / |
| 150 | 2x |
pstar.within) |
| 151 | 2x |
SRMR.between[g] <- sqrt(sum(lav_matrix_vech(R.between.cor)^2) / |
| 152 | 2x |
pstar.between) |
| 153 |
} |
|
| 154 | ||
| 155 |
# adjust for group sizes |
|
| 156 | 1x |
ng <- unlist(lavobject@SampleStats@nobs) # if this changes, tag @TDJorgensen in commit message |
| 157 | 1x |
ntotal <- lavobject@SampleStats@ntotal # if this changes, tag @TDJorgensen in commit message |
| 158 | 1x |
SRMR_WITHIN <- sum(ng / ntotal * SRMR.within) |
| 159 | 1x |
SRMR_BETWEEN <- sum(ng / ntotal * SRMR.between) |
| 160 | 1x |
SRMR_TOTAL <- SRMR_WITHIN + SRMR_BETWEEN |
| 161 | ||
| 162 | 1x |
c(SRMR_TOTAL, SRMR_WITHIN, SRMR_BETWEEN) |
| 163 |
} |
|
| 164 | ||
| 165 |
lav_fit_srmr_lavobject <- function(lavobject = NULL, fit.measures = "rmsea") {
|
|
| 166 |
# check lavobject |
|
| 167 | 24x |
stopifnot(inherits(lavobject, "lavaan")) |
| 168 | ||
| 169 |
# categorical? |
|
| 170 | 24x |
categorical <- lavobject@Model@categorical |
| 171 | ||
| 172 |
# supported fit measures in this function |
|
| 173 | 24x |
if (categorical) {
|
| 174 | 1x |
fit.srmr <- c("srmr")
|
| 175 | 1x |
fit.srmr2 <- c( |
| 176 | 1x |
"rmr", "rmr_nomean", |
| 177 | 1x |
"srmr", # per default equal to srmr_bentler_nomean |
| 178 | 1x |
"srmr_bentler", "srmr_bentler_nomean", |
| 179 | 1x |
"crmr", "crmr_nomean", |
| 180 | 1x |
"srmr_mplus", "srmr_mplus_nomean" |
| 181 |
) |
|
| 182 |
} else {
|
|
| 183 | 23x |
if (lavobject@Data@nlevels > 1L) {
|
| 184 | 1x |
fit.srmr <- c("srmr", "srmr_within", "srmr_between")
|
| 185 | 1x |
fit.srmr2 <- c("srmr", "srmr_within", "srmr_between")
|
| 186 |
} else {
|
|
| 187 | 22x |
fit.srmr <- c("srmr")
|
| 188 | 22x |
fit.srmr2 <- c( |
| 189 | 22x |
"rmr", "rmr_nomean", |
| 190 | 22x |
"srmr", # the default |
| 191 | 22x |
"srmr_bentler", "srmr_bentler_nomean", |
| 192 | 22x |
"crmr", "crmr_nomean", |
| 193 | 22x |
"srmr_mplus", "srmr_mplus_nomean" |
| 194 |
) |
|
| 195 |
} |
|
| 196 |
} |
|
| 197 | ||
| 198 |
# which one do we need? |
|
| 199 | 24x |
if (missing(fit.measures)) {
|
| 200 |
# default set |
|
| 201 | ! |
fit.measures <- fit.srmr |
| 202 |
} else {
|
|
| 203 |
# remove any not-SRMR related index from fit.measures |
|
| 204 | 24x |
rm.idx <- which(!fit.measures %in% fit.srmr2) |
| 205 | 24x |
if (length(rm.idx) > 0L) {
|
| 206 | 24x |
fit.measures <- fit.measures[-rm.idx] |
| 207 |
} |
|
| 208 | 24x |
if (length(fit.measures) == 0L) {
|
| 209 | ! |
return(list()) |
| 210 |
} |
|
| 211 |
} |
|
| 212 | ||
| 213 |
# output container |
|
| 214 | 24x |
indices <- list() |
| 215 | ||
| 216 |
# 1. single level |
|
| 217 | 24x |
if (lavobject@Data@nlevels == 1L) {
|
| 218 |
# RMR/SRMR/CRMR: we get it from lav_residuals_summary() |
|
| 219 | 23x |
out <- lav_residuals_summary(lavobject, se = FALSE, unbiased = FALSE) |
| 220 | ||
| 221 | 23x |
cov.cor <- "cov" |
| 222 | 23x |
if (categorical) {
|
| 223 | 1x |
cov.cor <- "cor" |
| 224 |
} |
|
| 225 | ||
| 226 |
# only cov |
|
| 227 | 23x |
rmr_nomean.group <- sapply(lapply(out, "[[", "rmr"), "[[", cov.cor) |
| 228 | 23x |
srmr_nomean.group <- sapply(lapply(out, "[[", "srmr"), "[[", cov.cor) |
| 229 | 23x |
crmr_nomean.group <- sapply(lapply(out, "[[", "crmr"), "[[", cov.cor) |
| 230 | ||
| 231 |
# total |
|
| 232 | 23x |
if (lavobject@Model@meanstructure) {
|
| 233 | 10x |
rmr.group <- sapply(lapply(out, "[[", "rmr"), "[[", "total") |
| 234 | 10x |
srmr.group <- sapply(lapply(out, "[[", "srmr"), "[[", "total") |
| 235 | 10x |
crmr.group <- sapply(lapply(out, "[[", "crmr"), "[[", "total") |
| 236 |
} else {
|
|
| 237 |
# no 'total', only 'cov' |
|
| 238 | 13x |
rmr.group <- rmr_nomean.group |
| 239 | 13x |
srmr.group <- srmr_nomean.group |
| 240 | 13x |
crmr.group <- crmr_nomean.group |
| 241 |
} |
|
| 242 | ||
| 243 |
# the Mplus versions |
|
| 244 | 23x |
srmr_mplus.group <- lav_fit_srmr_mplus(lavobject = lavobject) |
| 245 | 23x |
srmr_mplus_nomean.group <- attr(srmr_mplus.group, "nomean") |
| 246 | 23x |
attr(srmr_mplus.group, "nomean") <- NULL |
| 247 | ||
| 248 |
# adjust for group sizes |
|
| 249 | 23x |
ng <- unlist(lavobject@SampleStats@nobs) # if this changes, tag @TDJorgensen in commit message |
| 250 | 23x |
ntotal <- lavobject@SampleStats@ntotal # if this changes, tag @TDJorgensen in commit message |
| 251 | 23x |
RMR <- sum(ng / ntotal * rmr.group) |
| 252 | 23x |
RMR_NOMEAN <- sum(ng / ntotal * rmr_nomean.group) |
| 253 | 23x |
SRMR_BENTLER <- sum(ng / ntotal * srmr.group) |
| 254 | 23x |
SRMR_BENTLER_NOMEAN <- sum(ng / ntotal * srmr_nomean.group) |
| 255 | 23x |
CRMR <- sum(ng / ntotal * crmr.group) |
| 256 | 23x |
CRMR_NOMEAN <- sum(ng / ntotal * crmr_nomean.group) |
| 257 | 23x |
SRMR_MPLUS <- sum(ng / ntotal * srmr_mplus.group) |
| 258 | 23x |
SRMR_MPLUS_NOMEAN <- sum(ng / ntotal * srmr_mplus_nomean.group) |
| 259 | ||
| 260 |
# srmr |
|
| 261 | 23x |
if (lavobject@Options$mimic %in% c("lavaan", "EQS")) {
|
| 262 | 23x |
if (categorical) {
|
| 263 | 1x |
indices["srmr"] <- SRMR_BENTLER_NOMEAN |
| 264 |
} else {
|
|
| 265 | 22x |
indices["srmr"] <- SRMR_BENTLER |
| 266 |
} |
|
| 267 | ! |
} else if (lavobject@Options$mimic == "Mplus") {
|
| 268 | ! |
if (lavobject@Options$information[1] == "expected") {
|
| 269 | ! |
if (categorical) {
|
| 270 | ! |
indices["srmr"] <- SRMR_BENTLER_NOMEAN |
| 271 |
} else {
|
|
| 272 | ! |
indices["srmr"] <- SRMR_BENTLER |
| 273 |
} |
|
| 274 |
} else {
|
|
| 275 | ! |
if (categorical) {
|
| 276 | ! |
indices["srmr"] <- SRMR_MPLUS_NOMEAN |
| 277 |
} else {
|
|
| 278 | ! |
indices["srmr"] <- SRMR_MPLUS |
| 279 |
} |
|
| 280 |
} |
|
| 281 |
} # Mplus only |
|
| 282 | ||
| 283 |
# the others |
|
| 284 | 23x |
indices["srmr_bentler"] <- SRMR_BENTLER |
| 285 | 23x |
indices["srmr_bentler_nomean"] <- SRMR_BENTLER_NOMEAN |
| 286 | 23x |
indices["crmr"] <- CRMR |
| 287 | 23x |
indices["crmr_nomean"] <- CRMR_NOMEAN |
| 288 | ||
| 289 |
# only correct for non-categorical: |
|
| 290 | 23x |
if (lavobject@Model@categorical) {
|
| 291 |
# FIXME! Compute Mplus 8.1 way to compute SRMR in the |
|
| 292 |
# categorical setting |
|
| 293 |
# See 'SRMR in Mplus (2018)' document on Mplus website |
|
| 294 | 1x |
indices["srmr_mplus"] <- as.numeric(NA) |
| 295 | 1x |
indices["srmr_mplus_nomean"] <- as.numeric(NA) |
| 296 |
} else {
|
|
| 297 | 22x |
indices["srmr_mplus"] <- SRMR_MPLUS |
| 298 | 22x |
indices["srmr_mplus_nomean"] <- SRMR_MPLUS_NOMEAN |
| 299 |
} |
|
| 300 | 23x |
indices["rmr"] <- RMR |
| 301 | 23x |
indices["rmr_nomean"] <- RMR_NOMEAN |
| 302 |
} else {
|
|
| 303 |
# 2. twolevel setting |
|
| 304 | 1x |
out <- lav_fit_srmr_twolevel(lavobject = lavobject) |
| 305 | 1x |
indices["srmr"] <- out[1] |
| 306 | 1x |
indices["srmr_within"] <- out[2] |
| 307 | 1x |
indices["srmr_between"] <- out[3] |
| 308 |
} # twolevel |
|
| 309 | ||
| 310 |
# return only those that were requested |
|
| 311 | 24x |
indices[fit.measures] |
| 312 |
} |
| 1 |
# merge two parameter tables |
|
| 2 |
# - but allow different number of columns |
|
| 3 |
lav_partable_merge <- function(pt1 = NULL, pt2 = NULL, |
|
| 4 |
remove.duplicated = FALSE, |
|
| 5 |
fromLast = FALSE, |
|
| 6 |
warn = TRUE) {
|
|
| 7 | ! |
if (!missing(warn)) {
|
| 8 | ! |
current.warn <- lav_warn() |
| 9 | ! |
if (lav_warn(warn)) |
| 10 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 11 |
} |
|
| 12 |
# check for empty pt2 |
|
| 13 | ! |
if (is.null(pt2) || length(pt2) == 0L) {
|
| 14 | ! |
return(pt1) |
| 15 |
} |
|
| 16 | ||
| 17 | ! |
pt1 <- as.data.frame(pt1, stringsAsFactors = FALSE) |
| 18 | ! |
pt2 <- as.data.frame(pt2, stringsAsFactors = FALSE) |
| 19 | ||
| 20 |
# check minimum requirements: lhs, op, rhs |
|
| 21 | ! |
stopifnot( |
| 22 | ! |
!is.null(pt1$lhs), !is.null(pt1$op), !is.null(pt1$rhs), |
| 23 | ! |
!is.null(pt2$lhs), !is.null(pt2$op), !is.null(pt2$rhs) |
| 24 |
) |
|
| 25 | ||
| 26 |
# both should have block (or not) |
|
| 27 | ! |
if (is.null(pt1$block) && is.null(pt2$block)) {
|
| 28 | ! |
pt1$block <- rep(1L, length(pt1$lhs)) |
| 29 | ! |
pt2$block <- rep(1L, length(pt2$lhs)) |
| 30 | ! |
TMP <- rbind( |
| 31 | ! |
pt1[, c("lhs", "op", "rhs", "block")],
|
| 32 | ! |
pt2[, c("lhs", "op", "rhs", "block")]
|
| 33 |
) |
|
| 34 |
} else {
|
|
| 35 | ! |
if (is.null(pt1$block) && !is.null(pt2$block)) {
|
| 36 | ! |
pt1$block <- rep(1L, length(pt1$lhs)) |
| 37 | ! |
} else if (is.null(pt2$block) && !is.null(pt1$block)) {
|
| 38 | ! |
pt2$block <- rep(1L, length(pt2$lhs)) |
| 39 |
} |
|
| 40 | ! |
TMP <- rbind( |
| 41 | ! |
pt1[, c("lhs", "op", "rhs", "block")],
|
| 42 | ! |
pt2[, c("lhs", "op", "rhs", "block")]
|
| 43 |
) |
|
| 44 |
} |
|
| 45 | ||
| 46 |
# if missing columns, provide default values of the right type |
|
| 47 |
# (numeric/integer/character) |
|
| 48 | ||
| 49 |
# group |
|
| 50 | ! |
if (is.null(pt1$group) && !is.null(pt2$group)) {
|
| 51 | ! |
pt1$group <- rep(1L, length(pt1$lhs)) |
| 52 | ! |
} else if (is.null(pt2$group) && !is.null(pt1$group)) {
|
| 53 | ! |
pt2$group <- rep(1L, length(pt2$lhs)) |
| 54 |
} |
|
| 55 | ||
| 56 |
# level |
|
| 57 | ! |
if (is.null(pt1$level) && !is.null(pt2$level)) {
|
| 58 | ! |
pt1$level <- rep(1L, length(pt1$lhs)) |
| 59 | ! |
} else if (is.null(pt2$level) && !is.null(pt1$level)) {
|
| 60 | ! |
pt2$level <- rep(1L, length(pt2$lhs)) |
| 61 |
} |
|
| 62 | ||
| 63 |
# user |
|
| 64 | ! |
if (is.null(pt1$user) && !is.null(pt2$user)) {
|
| 65 | ! |
pt1$user <- rep(0L, length(pt1$lhs)) |
| 66 | ! |
} else if (is.null(pt2$user) && !is.null(pt1$user)) {
|
| 67 | ! |
pt2$user <- rep(0L, length(pt2$lhs)) |
| 68 |
} |
|
| 69 | ||
| 70 |
# free |
|
| 71 | ! |
if (is.null(pt1$free) && !is.null(pt2$free)) {
|
| 72 | ! |
pt1$free <- rep(0L, length(pt1$lhs)) |
| 73 | ! |
} else if (is.null(pt2$free) && !is.null(pt1$free)) {
|
| 74 | ! |
pt2$free <- rep(0L, length(pt2$lhs)) |
| 75 |
} |
|
| 76 | ||
| 77 |
# ustart -- set to zero!! |
|
| 78 | ! |
if (is.null(pt1$ustart) && !is.null(pt2$ustart)) {
|
| 79 | ! |
pt1$ustart <- rep(0, length(pt1$lhs)) |
| 80 | ! |
} else if (is.null(pt2$ustart) && !is.null(pt1$ustart)) {
|
| 81 | ! |
pt2$ustart <- rep(0, length(pt2$lhs)) |
| 82 |
} |
|
| 83 | ||
| 84 |
# exo |
|
| 85 | ! |
if (is.null(pt1$exo) && !is.null(pt2$exo)) {
|
| 86 | ! |
pt1$exo <- rep(0L, length(pt1$lhs)) |
| 87 | ! |
} else if (is.null(pt2$exo) && !is.null(pt1$exo)) {
|
| 88 | ! |
pt2$exo <- rep(0L, length(pt2$lhs)) |
| 89 |
} |
|
| 90 | ||
| 91 |
# label |
|
| 92 | ! |
if (is.null(pt1$label) && !is.null(pt2$label)) {
|
| 93 | ! |
pt1$label <- rep("", length(pt1$lhs))
|
| 94 | ! |
} else if (is.null(pt2$label) && !is.null(pt1$label)) {
|
| 95 | ! |
pt2$label <- rep("", length(pt2$lhs))
|
| 96 |
} |
|
| 97 | ||
| 98 |
# plabel |
|
| 99 | ! |
if (is.null(pt1$plabel) && !is.null(pt2$plabel)) {
|
| 100 | ! |
pt1$plabel <- rep("", length(pt1$lhs))
|
| 101 | ! |
} else if (is.null(pt2$plabel) && !is.null(pt1$plabel)) {
|
| 102 | ! |
pt2$plabel <- rep("", length(pt2$lhs))
|
| 103 |
} |
|
| 104 | ||
| 105 |
# efa |
|
| 106 | ! |
if (is.null(pt1$efa) && !is.null(pt2$efa)) {
|
| 107 | ! |
pt1$efa <- rep("", length(pt1$lhs))
|
| 108 | ! |
} else if (is.null(pt2$efa) && !is.null(pt1$efa)) {
|
| 109 | ! |
pt2$efa <- rep("", length(pt2$lhs))
|
| 110 |
} |
|
| 111 | ||
| 112 |
# start |
|
| 113 | ! |
if (is.null(pt1$start) && !is.null(pt2$start)) {
|
| 114 | ! |
pt1$start <- rep(as.numeric(NA), length(pt1$lhs)) |
| 115 | ! |
} else if (is.null(pt2$start) && !is.null(pt1$start)) {
|
| 116 | ! |
pt2$start <- rep(as.numeric(NA), length(pt2$lhs)) |
| 117 |
} |
|
| 118 | ||
| 119 |
# est |
|
| 120 | ! |
if (is.null(pt1$est) && !is.null(pt2$est)) {
|
| 121 | ! |
pt1$est <- rep(0, length(pt1$lhs)) |
| 122 | ! |
} else if (is.null(pt2$est) && !is.null(pt1$est)) {
|
| 123 | ! |
pt2$est <- rep(0, length(pt2$lhs)) |
| 124 |
} |
|
| 125 | ||
| 126 | ||
| 127 |
# check for duplicated elements |
|
| 128 | ! |
if (remove.duplicated) {
|
| 129 |
# if fromLast = TRUE, idx is in pt1 |
|
| 130 |
# if fromLast = FALSE, idx is in pt2 |
|
| 131 | ! |
idx <- which(duplicated(TMP, fromLast = fromLast)) |
| 132 | ||
| 133 | ! |
if (length(idx)) {
|
| 134 | ! |
lav_msg_warn( |
| 135 | ! |
gettext("duplicated parameters are ignored:"),
|
| 136 | ! |
paste(apply(TMP[idx, c("lhs", "op", "rhs")], 1,
|
| 137 | ! |
paste, |
| 138 | ! |
collapse = " " |
| 139 | ! |
), collapse = "\n") |
| 140 |
) |
|
| 141 | ! |
if (fromLast) {
|
| 142 | ! |
pt1 <- pt1[-idx, ] |
| 143 |
} else {
|
|
| 144 | ! |
idx <- idx - nrow(pt1) |
| 145 | ! |
pt2 <- pt2[-idx, ] |
| 146 |
} |
|
| 147 |
} |
|
| 148 | ! |
} else if (!is.null(pt1$start) && !is.null(pt2$start)) {
|
| 149 |
# copy start values from pt1 to pt2 |
|
| 150 | ! |
for (i in 1:length(pt1$lhs)) {
|
| 151 | ! |
idx <- which(pt2$lhs == pt1$lhs[i] & |
| 152 | ! |
pt2$op == pt1$op[i] & |
| 153 | ! |
pt2$rhs == pt1$rhs[i] & |
| 154 | ! |
pt2$block == pt1$block[i]) |
| 155 | ||
| 156 | ! |
pt2$start[idx] <- pt1$start[i] |
| 157 |
} |
|
| 158 |
} |
|
| 159 | ||
| 160 |
# nicely merge, using 'id' column (if it comes first) |
|
| 161 | ! |
if (is.null(pt1$id) && !is.null(pt2$id)) {
|
| 162 | ! |
nid <- max(pt2$id) |
| 163 | ! |
pt1$id <- (nid + 1L):(nid + nrow(pt1)) |
| 164 | ! |
} else if (is.null(pt2$id) && !is.null(pt1$id)) {
|
| 165 | ! |
nid <- max(pt1$id) |
| 166 | ! |
pt2$id <- (nid + 1L):(nid + nrow(pt2)) |
| 167 |
} |
|
| 168 | ||
| 169 | ! |
NEW <- base::merge(pt1, pt2, all = TRUE, sort = FALSE) |
| 170 | ||
| 171 |
# make sure group/block/level are zero (or "") if |
|
| 172 |
# op %in% c("==", "<", ">", ":=")
|
|
| 173 | ! |
op.idx <- which(NEW$op %in% c("==", "<", ">", ":="))
|
| 174 | ! |
if (length(op.idx) > 0L) {
|
| 175 | ! |
if (!is.null(NEW$block)) {
|
| 176 |
# ALWAYS integer |
|
| 177 | ! |
NEW$block[op.idx] <- 0L |
| 178 |
} |
|
| 179 | ! |
if (!is.null(NEW$group)) {
|
| 180 | ! |
if (is.character(NEW$level)) {
|
| 181 | ! |
NEW$group[op.idx] <- "" |
| 182 |
} else {
|
|
| 183 | ! |
NEW$group[op.idx] <- 0L |
| 184 |
} |
|
| 185 |
} |
|
| 186 | ! |
if (!is.null(NEW$level)) {
|
| 187 | ! |
if (is.character(NEW$level)) {
|
| 188 | ! |
NEW$level[op.idx] <- "" |
| 189 |
} else {
|
|
| 190 | ! |
NEW$level[op.idx] <- 0L |
| 191 |
} |
|
| 192 |
} |
|
| 193 |
} |
|
| 194 | ||
| 195 | ! |
NEW |
| 196 |
} |
| 1 |
# return 'attributes' of a lavaan partable -- generate a new set if necessary |
|
| 2 |
lav_partable_attributes <- function(partable, pta = NULL) {
|
|
| 3 | 914x |
if (is.null(pta)) {
|
| 4 |
# attached to partable? |
|
| 5 | 914x |
pta <- attributes(partable) |
| 6 | 914x |
if (!is.null(pta$vnames) && !is.null(pta$nvar)) {
|
| 7 |
# looks like a pta |
|
| 8 | 410x |
pta$ovda <- NULL |
| 9 | 410x |
return(pta) |
| 10 |
} else {
|
|
| 11 | 504x |
pta <- list() |
| 12 |
} |
|
| 13 |
} |
|
| 14 | ||
| 15 |
# vnames |
|
| 16 | 504x |
pta$vnames <- lav_partable_vnames(partable, type = "*") |
| 17 | ||
| 18 |
# vidx |
|
| 19 | 504x |
tmp.ov <- pta$vnames$ov |
| 20 | 504x |
tmp.lv <- pta$vnames$lv |
| 21 | 504x |
nblocks <- length(pta$vnames$ov) |
| 22 | 504x |
pta$vidx <- lapply(names(pta$vnames), function(v) {
|
| 23 | 15120x |
lapply(seq_len(nblocks), function(b) {
|
| 24 | 17340x |
if (v == "lv.marker") {
|
| 25 | 578x |
match(pta$vnames[[v]][[b]], tmp.ov[[b]]) |
| 26 | 16762x |
} else if (grepl("lv", v)) {
|
| 27 | 7514x |
match(pta$vnames[[v]][[b]], tmp.lv[[b]]) |
| 28 | 9248x |
} else if (grepl("th", v)) {
|
| 29 |
# thresholds have '|t' pattern |
|
| 30 | 1156x |
tmp.th <- sapply(strsplit(pta$vnames[[v]][[b]], |
| 31 | 1156x |
"|t", |
| 32 | 1156x |
fixed = TRUE |
| 33 | 1156x |
), "[[", 1L) |
| 34 | 1156x |
match(tmp.th, tmp.ov[[b]]) |
| 35 | 8092x |
} else if (grepl("eqs", v)) {
|
| 36 |
# mixture of tmp.ov/tmp.lv |
|
| 37 | 1156x |
integer(0L) |
| 38 |
} else {
|
|
| 39 | 6936x |
match(pta$vnames[[v]][[b]], tmp.ov[[b]]) |
| 40 |
} |
|
| 41 |
}) |
|
| 42 |
}) |
|
| 43 | 504x |
names(pta$vidx) <- names(pta$vnames) |
| 44 | ||
| 45 |
# meanstructure |
|
| 46 | 504x |
pta$meanstructure <- any(partable$op == "~1") |
| 47 | ||
| 48 |
# nblocks |
|
| 49 | 504x |
pta$nblocks <- nblocks |
| 50 | ||
| 51 |
# ngroups |
|
| 52 | 504x |
pta$ngroups <- lav_partable_ngroups(partable) |
| 53 | ||
| 54 |
# nlevels |
|
| 55 | 504x |
pta$nlevels <- lav_partable_nlevels(partable) |
| 56 | ||
| 57 |
# nvar |
|
| 58 | 504x |
pta$nvar <- lapply(pta$vnames$ov, length) |
| 59 | ||
| 60 |
# nfac |
|
| 61 | 504x |
pta$nfac <- lapply(pta$vnames$lv, length) |
| 62 | ||
| 63 |
# nfac.nonnormal - for numerical integration |
|
| 64 | 504x |
pta$nfac.nonnormal <- lapply(pta$vnames$lv.nonnormal, length) |
| 65 | ||
| 66 |
# th.idx (new in 0.6-1) |
|
| 67 | 504x |
pta$th.idx <- lapply(seq_len(pta$nblocks), function(b) {
|
| 68 | 578x |
out <- numeric(length(pta$vnames$th.mean[[b]])) |
| 69 | 578x |
idx <- (pta$vnames$th.mean[[b]] %in% |
| 70 | 578x |
pta$vnames$th[[b]]) |
| 71 | 578x |
out[idx] <- pta$vidx$th[[b]] |
| 72 | 578x |
out |
| 73 |
}) |
|
| 74 | ||
| 75 | 504x |
pta |
| 76 |
} |
| 1 |
lav_plotinfo_svgcode <- function(plotinfo, |
|
| 2 |
outfile = "", |
|
| 3 |
sloped.labels = TRUE, |
|
| 4 |
standalone = FALSE, |
|
| 5 |
stroke.width = 2L, |
|
| 6 |
font.size = 20L, |
|
| 7 |
idx.font.size = 15L, |
|
| 8 |
dy = 5L, |
|
| 9 |
mlovcolors = c("lightgreen", "lightblue"),
|
|
| 10 |
lightness = 1, |
|
| 11 |
font.family = "Latin Modern Math, arial, Aerial, sans", |
|
| 12 |
italic = TRUE, |
|
| 13 |
auto.subscript = TRUE |
|
| 14 |
) {
|
|
| 15 | ! |
textattr <- paste0('fill="black" font-size="', font.size,
|
| 16 | ! |
'" font-family="', font.family, '" ', |
| 17 | ! |
ifelse(italic, 'font-style="italic"','')) |
| 18 | ! |
tmpcol <- col2rgb(mlovcolors) |
| 19 | ! |
wovcol <- paste(as.hexmode(tmpcol[, 1L]), collapse = "") |
| 20 | ! |
bovcol <- paste(as.hexmode(tmpcol[, 2L]), collapse = "") |
| 21 | ! |
node_elements_svg <- function(nodetiepe, noderadius, waar, stroke.width) {
|
| 22 |
# define form, color and anchors for a node |
|
| 23 | ! |
localradius <- noderadius |
| 24 | ! |
if (nodetiepe == "varlv") localradius <- noderadius * .8 |
| 25 | ! |
ovxy <- localradius * sqrt(0.5) |
| 26 | ! |
cvxy <- localradius * c(0.5, sqrt(0.75)) |
| 27 | ! |
constxy <- cvxy |
| 28 | ! |
drawit <- switch(nodetiepe, |
| 29 | ! |
lv = , |
| 30 | ! |
varlv = paste0('<circle cx="', waar[1], '" cy="', waar[2],
|
| 31 | ! |
'" r="', localradius, |
| 32 | ! |
'" stroke-width="', stroke.width, |
| 33 | ! |
'" stroke="black" fill="white"/>'), |
| 34 | ! |
ov = paste0('<rect width="', 2 * ovxy, '" height="',
|
| 35 | ! |
2 * ovxy, '" x="', waar[1] - ovxy, '" y="', |
| 36 | ! |
waar[2] - ovxy, |
| 37 | ! |
'" stroke-width="', stroke.width, |
| 38 | ! |
'" stroke="black" fill="white" />'), |
| 39 | ! |
wov = paste0('<rect width="', 2 * ovxy, '" height="',
|
| 40 | ! |
2 * ovxy, '" x="', waar[1] - ovxy, '" y="', |
| 41 | ! |
waar[2] - ovxy, '" rx="', ovxy / 3, '" ry="', |
| 42 | ! |
ovxy / 3, '" stroke-width="', stroke.width, |
| 43 | ! |
'" stroke="black" fill="#', wovcol, |
| 44 |
'" />'), |
|
| 45 | ! |
bov = paste0('<rect width="', 2 * ovxy, '" height="',
|
| 46 | ! |
2 * ovxy, '" x="', waar[1] - ovxy, '" y="', |
| 47 | ! |
waar[2] - ovxy, '" rx="', ovxy / 3, '" ry="', |
| 48 | ! |
ovxy / 3, '" stroke-width="', stroke.width, |
| 49 | ! |
'" stroke="black" fill="#', bovcol, |
| 50 |
'" />'), |
|
| 51 | ! |
cv = paste0('<polygon points="',
|
| 52 | ! |
waar[1] - cvxy[1], ',', waar[2] - cvxy[2], ' ', |
| 53 | ! |
waar[1] + cvxy[1], ',', waar[2] - cvxy[2], ' ', |
| 54 | ! |
waar[1] + localradius, ',', waar[2], ' ', |
| 55 | ! |
waar[1] + cvxy[1], ',', waar[2] + cvxy[2], ' ', |
| 56 | ! |
waar[1] - cvxy[1], ',', waar[2] + cvxy[2], ' ', |
| 57 | ! |
waar[1] - localradius, ',', waar[2], |
| 58 | ! |
'" stroke-width="', stroke.width, |
| 59 | ! |
'" stroke="black" fill="none" />'), |
| 60 | ! |
const = paste0('<polygon points="',
|
| 61 | ! |
waar[1], ',', waar[2] - localradius, ' ', |
| 62 | ! |
waar[1] + constxy[2], ',', waar[2] + constxy[1], ' ', |
| 63 | ! |
waar[1] - constxy[2], ',', waar[2] + constxy[1], |
| 64 | ! |
'" stroke-width="', stroke.width, |
| 65 | ! |
'" stroke="black" fill="none" />') |
| 66 |
) |
|
| 67 | ! |
n <- c(waar[1], switch(nodetiepe, |
| 68 | ! |
lv = , varlv = , const = waar[2] - localradius, |
| 69 | ! |
ov = , wov = , bov = waar[2] - ovxy, |
| 70 | ! |
cv = waar[2] - cvxy[2])) |
| 71 | ! |
s <- c(waar[1], switch(nodetiepe, |
| 72 | ! |
lv = , varlv = waar[2] + localradius, |
| 73 | ! |
ov = , wov = , bov = waar[2] + ovxy, |
| 74 | ! |
cv = waar[2] + cvxy[2], |
| 75 | ! |
const = waar[2] + constxy[1])) |
| 76 | ! |
e <- switch(nodetiepe, |
| 77 | ! |
lv = , varlv = , cv = waar + c(localradius, 0), |
| 78 | ! |
ov = , wov = , bov = waar + c(ovxy, 0), |
| 79 | ! |
const = waar + c(constxy[2], constxy[1])) |
| 80 | ! |
w <- switch(nodetiepe, |
| 81 | ! |
lv = , varlv = , cv = waar + c(-localradius, 0), |
| 82 | ! |
ov = , wov = , bov = waar + c(-ovxy, 0), |
| 83 | ! |
const = waar + c(-constxy[2], constxy[1])) |
| 84 | ! |
ne <- switch(nodetiepe, |
| 85 | ! |
lv = , varlv = , ov = , wov = , |
| 86 | ! |
bov = waar + ovxy * c(1, -1), |
| 87 | ! |
cv = waar + c(cvxy[1], -cvxy[2]), |
| 88 | ! |
const = e) |
| 89 | ! |
nw <- switch(nodetiepe, |
| 90 | ! |
lv = , varlv = , ov = , wov = , |
| 91 | ! |
bov = waar + ovxy * c(-1, -1), |
| 92 | ! |
cv = waar + c(-cvxy[1], -cvxy[2]), |
| 93 | ! |
const = w) |
| 94 | ! |
se <- switch(nodetiepe, |
| 95 | ! |
lv = , varlv = , ov = , wov = , |
| 96 | ! |
bov = waar + ovxy * c(1, 1), |
| 97 | ! |
cv = waar + cvxy, |
| 98 | ! |
const = e) |
| 99 | ! |
sw <- switch(nodetiepe, |
| 100 | ! |
lv = , varlv = , ov = , wov = , |
| 101 | ! |
bov = waar + ovxy * c(-1, 1), |
| 102 | ! |
cv = waar + c(-cvxy[1L], cvxy[2L]), |
| 103 | ! |
const = w) |
| 104 | ! |
list(drawit = drawit, n = n, ne = ne, e = e, |
| 105 | ! |
se = se, s = s, sw = sw, w = w, nw = nw) |
| 106 |
} |
|
| 107 | ! |
get_file_extension <- function(path) {
|
| 108 | ! |
if (path == "") return("")
|
| 109 | ! |
delen <- strsplit(path, ".", fixed = TRUE)[[1]] |
| 110 | ! |
if (length(delen) > 1L) return(tolower(delen[length(delen)])) |
| 111 | ! |
return("")
|
| 112 |
} |
|
| 113 | ! |
if (is.character(outfile) && outfile != "") {
|
| 114 | ! |
stopifnot(standalone || get_file_extension(outfile) == "svg", |
| 115 | ! |
!standalone || get_file_extension(outfile) %in% c("htm", "html"))
|
| 116 |
} |
|
| 117 | ! |
mlrij <- plotinfo$mlrij |
| 118 | ! |
if (is.null(mlrij)) |
| 119 | ! |
lav_msg_stop(gettext( |
| 120 | ! |
"plotinfo hasn't been processed by lav_plotinfo_positions!")) |
| 121 | ! |
if (outfile == "") outfile <- stdout() |
| 122 | ! |
if (is.character(outfile)) {
|
| 123 | ! |
zz <- file(outfile, open = "w") |
| 124 | ! |
closezz <- TRUE |
| 125 |
} else {
|
|
| 126 | ! |
zz <- outfile |
| 127 | ! |
closezz <- FALSE |
| 128 |
} |
|
| 129 | ! |
nodes <- plotinfo$nodes |
| 130 | ! |
edges <- plotinfo$edges |
| 131 | ! |
nodedist <- 100 |
| 132 | ! |
noderadius <- 0.3 |
| 133 | ! |
rijen <- max(nodes$rij) |
| 134 | ! |
kolommen <- max(nodes$kolom) |
| 135 | ! |
nodes$rij <- nodes$rij + 1 |
| 136 | ! |
nodes$kolom <- nodes$kolom + 1 |
| 137 | ! |
if (lightness != 1) {
|
| 138 | ! |
mlrij <- lightness * mlrij |
| 139 | ! |
nodes$kolom <- lightness * nodes$kolom |
| 140 | ! |
nodes$rij <- lightness * nodes$rij |
| 141 | ! |
edges$controlpt.kol <- lightness * edges$controlpt.kol |
| 142 | ! |
edges$controlpt.rij <- lightness * edges$controlpt.rij |
| 143 |
} |
|
| 144 | ! |
if (standalone) {
|
| 145 | ! |
writeLines(c( |
| 146 | ! |
'<!DOCTYPE html>', |
| 147 | ! |
'<html>', |
| 148 | ! |
'<body>', |
| 149 | ! |
'<h2>SVG diagram created by lav_plot R package</h2>'), |
| 150 | ! |
zz) |
| 151 |
} |
|
| 152 | ! |
writeLines(c( |
| 153 | ! |
paste0('<svg width="', lightness * (kolommen + 3) * nodedist, '" height="',
|
| 154 | ! |
lightness * (rijen + 3) * nodedist, |
| 155 | ! |
'" version="1.1" xmlns="http://www.w3.org/2000/svg"', |
| 156 | ! |
' xmlns:xlink="http://www.w3.org/1999/xlink">'), |
| 157 | ! |
'<rect width="100%" height="100%" fill="white" />', |
| 158 | ! |
'<defs>', |
| 159 | ! |
' <marker id="arr" markerWidth="6" markerHeight="6"', |
| 160 | ! |
' refX="6" refY="2.5" orient="auto">', |
| 161 | ! |
' <path d="M 0 0 L 6 2.5 L 0 5 L 2 2.5 z" fill="black" />', |
| 162 | ! |
' </marker>', |
| 163 | ! |
' <marker id="sarr" markerWidth="6" markerHeight="6"', |
| 164 | ! |
' refX="0" refY="2.5" orient="auto">', |
| 165 | ! |
' <path d="M 0 2.5 L 6 0 L 4 2.5 L 6 5 z" fill="black" />', |
| 166 | ! |
' </marker>', |
| 167 | ! |
'</defs>'), |
| 168 | ! |
zz) |
| 169 | ! |
plot_edge <- function(van, naar, label = "", dubbel = FALSE, |
| 170 | ! |
control = NA_real_, below = FALSE, |
| 171 | ! |
id = 0) {
|
| 172 | ! |
labele <- lav_label_code(label, |
| 173 | ! |
idx.font.size = idx.font.size, |
| 174 | ! |
dy = dy, |
| 175 | ! |
auto.subscript = auto.subscript)$svg |
| 176 | ! |
dirvec <- naar - van |
| 177 | ! |
theta <- atan2(naar[2] - van[2], naar[1] - van[1]) |
| 178 | ! |
if (is.na(control[1L])) { # line
|
| 179 | ! |
if (van[1L] <= naar[1L]) {
|
| 180 | ! |
writeLines(paste0('<path id="L', id, '" d="M ', van[1L],
|
| 181 | ! |
' ', van[2L], ' L ', naar[1L], " ", naar[2L], |
| 182 | ! |
'" stroke-width="', stroke.width, '" stroke="black" ', |
| 183 | ! |
ifelse(dubbel,'marker-start="url(#sarr)" ', ''), |
| 184 | ! |
'marker-end="url(#arr)" />'), zz) |
| 185 |
} else {
|
|
| 186 | ! |
writeLines(paste0('<path d="M ', van[1L],
|
| 187 | ! |
' ', van[2L], ' L ', naar[1L], " ", naar[2L], |
| 188 | ! |
'" stroke-width="', stroke.width, '" stroke="black" ', |
| 189 | ! |
ifelse(dubbel,'marker-start="url(#sarr)" ', ''), |
| 190 | ! |
'marker-end="url(#arr)" />'), zz) |
| 191 | ! |
writeLines(paste0('<path id="L', id, '" d="M ', naar[1L],
|
| 192 | ! |
' ', naar[2L], ' L ', van[1L], " ", van[2L], |
| 193 | ! |
'" stroke-width="0" stroke="none" fill="none" />'), |
| 194 | ! |
zz) |
| 195 |
} |
|
| 196 | ! |
midden <- (van + naar) * 0.5 |
| 197 | ! |
} else { # path Q (quadratic B\'{e}zier)
|
| 198 | ! |
if (van[1L] <= naar[1L]) {
|
| 199 | ! |
writeLines(paste0('<path id="L', id, '" d="M ', van[1L], ' ',
|
| 200 | ! |
van[2L], ' Q ', control[1L], ' ', control[2L], |
| 201 | ! |
' ', naar[1L], " ", naar[2L], |
| 202 | ! |
'" stroke-width="', stroke.width, '" stroke="black" fill="none" ', |
| 203 | ! |
ifelse(dubbel,'marker-start="url(#sarr)" ', ''), |
| 204 | ! |
'marker-end="url(#arr)" />'), zz) |
| 205 |
} else {
|
|
| 206 | ! |
writeLines(paste0('<path d="M ', van[1L], ' ',
|
| 207 | ! |
van[2L], ' Q ', control[1L], ' ', control[2L], |
| 208 | ! |
' ', naar[1L], " ", naar[2L], |
| 209 | ! |
'" stroke-width="', stroke.width, '" stroke="black" fill="none" ', |
| 210 | ! |
ifelse(dubbel,'marker-start="url(#sarr)" ', ''), |
| 211 | ! |
'marker-end="url(#arr)" />'), zz) |
| 212 | ! |
writeLines(paste0('<path id="L', id, '" d="M ', naar[1L], ' ',
|
| 213 | ! |
naar[2L], ' Q ', control[1L], ' ', control[2L], |
| 214 | ! |
' ', van[1L], " ", van[2L], |
| 215 | ! |
'" stroke-width="0" stroke="none" fill="none" />'), |
| 216 | ! |
zz) |
| 217 |
} |
|
| 218 | ! |
midden <- 0.25 * (van + naar) + 0.5 * control |
| 219 |
} |
|
| 220 | ! |
if (label != "") {
|
| 221 | ! |
if (sloped.labels) {
|
| 222 | ! |
writeLines( |
| 223 | ! |
c(paste0('<text ', textattr, ' text-anchor="middle">'),
|
| 224 | ! |
paste0('<textPath xlink:href="#L', id, '" startOffset="50%">',
|
| 225 | ! |
labele, '</textPath>'), |
| 226 | ! |
'</text>'), zz) |
| 227 |
} else {
|
|
| 228 | ! |
if (below) {
|
| 229 | ! |
if (theta >= 0 && theta < pi / 2) {
|
| 230 | ! |
extra <- 'dy="30"' |
| 231 | ! |
} else if (theta >= pi / 2) {
|
| 232 | ! |
extra <- 'dy="30" text-anchor="end"' |
| 233 | ! |
} else if (theta < -pi/2) {
|
| 234 | ! |
extra <- 'dy="30"' |
| 235 |
} else {
|
|
| 236 | ! |
extra <- 'dy="0" text-anchor="end"' |
| 237 |
} |
|
| 238 |
} else {
|
|
| 239 | ! |
if (theta >= 0 && theta < pi / 2) {
|
| 240 | ! |
extra <- 'text-anchor="end"' |
| 241 | ! |
} else if (theta >= pi / 2) {
|
| 242 | ! |
extra <- ' ' |
| 243 | ! |
} else if (theta < -pi/2) {
|
| 244 | ! |
extra <- 'text-anchor="end"' |
| 245 |
} else {
|
|
| 246 | ! |
extra <- ' ' |
| 247 |
} |
|
| 248 | ! |
writeLines(paste0('<text x="', midden[1L], '" y="', midden[2L],
|
| 249 | ! |
'" ', textattr, ' ', extra, '>', labele, '</text>'), |
| 250 | ! |
zz) |
| 251 |
} |
|
| 252 |
} |
|
| 253 |
} |
|
| 254 |
} |
|
| 255 | ! |
plot_var <- function(waar, noderadius, label = "", side = "n") {
|
| 256 | ! |
labele <- lav_label_code(label, |
| 257 | ! |
idx.font.size = idx.font.size, |
| 258 | ! |
dy = dy, |
| 259 | ! |
auto.subscript = auto.subscript)$svg |
| 260 | ! |
thetarange <- c(pi / 6, 11 * pi / 6) |
| 261 | ! |
if (side == "s") thetarange <- thetarange + 3 * pi / 2 |
| 262 | ! |
if (side == "e") thetarange <- thetarange + pi |
| 263 | ! |
if (side == "n") thetarange <- thetarange + pi / 2 |
| 264 | ! |
localradius <- noderadius * 0.8 |
| 265 | ! |
middelpt <- switch(side, |
| 266 | ! |
n = c(0, -localradius), |
| 267 | ! |
w = c(-localradius, 0), |
| 268 | ! |
s = c(0, localradius), |
| 269 | ! |
e = c(localradius, 0)) |
| 270 | ! |
middelpt <- middelpt + waar |
| 271 |
# cirkelsegment |
|
| 272 | ! |
straal <- localradius |
| 273 | ! |
xs <- middelpt[1] + cos(thetarange) * straal |
| 274 | ! |
ys <- middelpt[2] + sin(thetarange) * straal |
| 275 | ! |
writeLines(paste0( |
| 276 | ! |
'<path d="M ', xs[1L], ' ', ys[1L], ' A ', straal, ' ', straal , |
| 277 | ! |
' 0 1,1 ', xs[2L], ' ', ys[2L] , '" stroke-width="', stroke.width, |
| 278 | ! |
'" stroke="black" fill="none" ', |
| 279 | ! |
'marker-start="url(#sarr)" marker-end="url(#arr)" />' |
| 280 | ! |
), zz) |
| 281 |
# label |
|
| 282 | ! |
if (label != "") {
|
| 283 | ! |
writeLines(paste0('<text x="', middelpt[1L], '" y="', middelpt[2L],
|
| 284 | ! |
'" text-anchor="middle" ',textattr, '>', labele, |
| 285 | ! |
'</text>'), zz) |
| 286 |
} |
|
| 287 |
} |
|
| 288 | ! |
plot_node <- function(waar, tiepe, label = "") {
|
| 289 | ! |
labele <- lav_label_code(label, |
| 290 | ! |
idx.font.size = idx.font.size, |
| 291 | ! |
dy = dy, |
| 292 | ! |
auto.subscript = auto.subscript)$svg |
| 293 | ! |
elems <- node_elements_svg(tiepe, nodedist * noderadius, waar, stroke.width) |
| 294 | ! |
writeLines(c( |
| 295 | ! |
elems$drawit, |
| 296 | ! |
paste0('<text x="', waar[1], '" y="', waar[2], '" ',
|
| 297 | ! |
textattr, ' dominant-baseline="central" text-anchor="middle">', |
| 298 | ! |
labele, '</text>') |
| 299 | ! |
), zz) |
| 300 |
} |
|
| 301 | ||
| 302 | ! |
if (mlrij > 0L) {
|
| 303 | ! |
mlrij <- mlrij + lightness |
| 304 | ! |
writeLines(paste0('<path d="M 1 ', mlrij * nodedist, ' L ',
|
| 305 | ! |
(max(nodes$kolom) + lightness) * nodedist, |
| 306 | ! |
' ', mlrij * nodedist, '" stroke="black"/>'), |
| 307 | ! |
zz) |
| 308 |
} |
|
| 309 | ! |
yrange <- nodedist * range(nodes$rij) |
| 310 | ! |
xrange <- nodedist * range(nodes$kolom) |
| 311 | ! |
midxy <- c(mean(xrange), mean(yrange)) |
| 312 | ! |
for (j in seq.int(nrow(edges))) {
|
| 313 | ! |
if (edges$naar[j] != edges$van[j]) {
|
| 314 | ! |
van <- which(nodes$id == edges$van[j]) |
| 315 | ! |
naar <- which(nodes$id == edges$naar[j]) |
| 316 | ! |
adrvan <- c(nodedist * nodes$kolom[van], nodedist * nodes$rij[van]) |
| 317 | ! |
elems <- node_elements_svg(nodes$tiepe[van], nodedist * noderadius, |
| 318 | ! |
adrvan, stroke.width) |
| 319 | ! |
adrvan <- elems[[edges$vananker[j]]] |
| 320 | ! |
adrnaar <- c(nodedist * nodes$kolom[naar], nodedist * nodes$rij[naar]) |
| 321 | ! |
elems <- node_elements_svg(nodes$tiepe[naar], nodedist * noderadius, |
| 322 | ! |
adrnaar, stroke.width) |
| 323 | ! |
adrnaar <- elems[[edges$naaranker[j]]] |
| 324 | ! |
if (is.na(edges$controlpt.rij[j])) {
|
| 325 | ! |
plot_edge(adrvan, adrnaar, edges$label[j], |
| 326 | ! |
dubbel = (edges$tiepe[j] == "~~"), |
| 327 | ! |
below = edges$labelbelow[j], id = j) |
| 328 |
} else {
|
|
| 329 | ! |
controlpt <- nodedist * c(edges$controlpt.kol[j] + 1, |
| 330 | ! |
edges$controlpt.rij[j] + 1) |
| 331 | ! |
plot_edge(adrvan, adrnaar, edges$label[j], |
| 332 | ! |
dubbel = (edges$tiepe[j] == "~~"), |
| 333 | ! |
below = edges$labelbelow[j], |
| 334 | ! |
control = controlpt, |
| 335 | ! |
id = j |
| 336 |
) |
|
| 337 |
} |
|
| 338 |
} else {
|
|
| 339 | ! |
van <- which(nodes$id == edges$van[j]) |
| 340 | ! |
adrvan <- c(nodedist * nodes$kolom[van], nodedist * nodes$rij[van]) |
| 341 | ! |
elems <- node_elements_svg(nodes$tiepe[van], nodedist * noderadius, adrvan, stroke.width) |
| 342 | ! |
adrvan <- elems[[edges$vananker[j]]] |
| 343 | ! |
plot_var(adrvan, noderadius * nodedist, edges$label[j], edges$vananker[j]) |
| 344 |
} |
|
| 345 |
} |
|
| 346 | ! |
for (j in seq.int(nrow(nodes))) {
|
| 347 | ! |
plot_node(nodedist * c(nodes$kolom[j], nodes$rij[j]), |
| 348 | ! |
nodes$tiepe[j], |
| 349 | ! |
nodes$naam[j]) |
| 350 |
} |
|
| 351 | ! |
writeLines("</svg>", zz)
|
| 352 | ! |
if (standalone) writeLines(c("</body>", "</html>"), zz)
|
| 353 | ! |
if (closezz) close(zz) |
| 354 | ! |
return(invisible(NULL)) |
| 355 |
} |
| 1 |
# user-visible function to extract the fit measures |
|
| 2 |
# output can be 1) vector (default), 2) list, 3) matrix, or 4) text |
|
| 3 |
# in the latter case, the result will be of class "lavaan.fitMeasures" |
|
| 4 |
# for which the printing is done by lav_fitmeasures_print() |
|
| 5 | ||
| 6 |
# new in 0.6-13: |
|
| 7 |
# the big families are computed in dedicated functions: |
|
| 8 |
# - lav_fit_rmsea_lavobject |
|
| 9 |
# - lav_fit_cfi_lavobject |
|
| 10 |
# - lav_fit_aic_lavojbect |
|
| 11 |
# - lav_residuals_summary |
|
| 12 | ||
| 13 |
# Note: fitMeasures/fitmeasures are generic functions; they include a "..." |
|
| 14 |
# so lavaan.mi can add arguments to pass to lavTestLRT() and |
|
| 15 |
# lavTestLRT.mi() about how to pool chi-squared. |
|
| 16 | ||
| 17 |
setMethod( |
|
| 18 |
"fitMeasures", signature(object = "lavaan"), |
|
| 19 |
function(object, fit.measures = "all", baseline.model = NULL, h1.model = NULL, |
|
| 20 |
fm.args = list( |
|
| 21 |
standard.test = "default", |
|
| 22 |
scaled.test = "default", |
|
| 23 |
rmsea.ci.level = 0.90, |
|
| 24 |
rmsea.close.h0 = 0.05, |
|
| 25 |
rmsea.notclose.h0 = 0.08, |
|
| 26 |
robust = TRUE, |
|
| 27 |
cat.check.pd = TRUE |
|
| 28 |
), |
|
| 29 |
output = "vector", ...) {
|
|
| 30 | 60x |
dotdotdot <- list(...) |
| 31 | 60x |
if (length(dotdotdot) > 0L) {
|
| 32 | ! |
for (j in seq_along(dotdotdot)) {
|
| 33 | ! |
lav_msg_warn(gettextf( |
| 34 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 35 | ! |
sQuote("fitMeasures"))
|
| 36 |
) |
|
| 37 |
} |
|
| 38 |
} |
|
| 39 |
# note: the ... is not used by lavaan |
|
| 40 | 60x |
if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures) |
| 41 | ! |
if (!missing(fm.args)) fit.measures <- c(fit.measures, fm.args) |
| 42 | 60x |
lav_fit_measures( |
| 43 | 60x |
object = object, fit.measures = fit.measures, |
| 44 | 60x |
baseline.model = baseline.model, h1.model = h1.model, |
| 45 | 60x |
output = output |
| 46 |
) |
|
| 47 |
} |
|
| 48 |
) |
|
| 49 | ||
| 50 |
setMethod( |
|
| 51 |
"fitmeasures", signature(object = "lavaan"), |
|
| 52 |
function(object, fit.measures = "all", baseline.model = NULL, h1.model = NULL, |
|
| 53 |
fm.args = list( |
|
| 54 |
standard.test = "default", |
|
| 55 |
scaled.test = "default", |
|
| 56 |
rmsea.ci.level = 0.90, |
|
| 57 |
rmsea.close.h0 = 0.05, |
|
| 58 |
rmsea.notclose.h0 = 0.08, |
|
| 59 |
robust = TRUE, |
|
| 60 |
cat.check.pd = TRUE |
|
| 61 |
), |
|
| 62 |
output = "vector", ...) {
|
|
| 63 | ! |
dotdotdot <- list(...) |
| 64 | ! |
if (length(dotdotdot) > 0L) {
|
| 65 | ! |
for (j in seq_along(dotdotdot)) {
|
| 66 | ! |
lav_msg_warn(gettextf( |
| 67 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 68 | ! |
sQuote("fitmeasures"))
|
| 69 |
) |
|
| 70 |
} |
|
| 71 |
} |
|
| 72 |
# note: the ... is not used by lavaan |
|
| 73 | ! |
if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures) |
| 74 | ! |
if (!missing(fm.args)) fit.measures <- c(fit.measures, fm.args) |
| 75 | ! |
lav_fit_measures( |
| 76 | ! |
object = object, fit.measures = fit.measures, |
| 77 | ! |
baseline.model = baseline.model, h1.model = h1.model, |
| 78 | ! |
output = output |
| 79 |
) |
|
| 80 |
} |
|
| 81 |
) |
|
| 82 | ||
| 83 |
# S3 method for efaList |
|
| 84 |
lav_efalist_fitmeasures <- function( |
|
| 85 |
object, |
|
| 86 |
fit.measures = "all", |
|
| 87 |
baseline.model = NULL, h1.model = NULL, |
|
| 88 |
fm.args = list( |
|
| 89 |
standard.test = "default", |
|
| 90 |
scaled.test = "default", |
|
| 91 |
rmsea.ci.level = 0.90, |
|
| 92 |
rmsea.close.h0 = 0.05, |
|
| 93 |
rmsea.notclose.h0 = 0.08, |
|
| 94 |
robust = TRUE, |
|
| 95 |
cat.check.pd = TRUE |
|
| 96 |
), |
|
| 97 |
output = "list", ...) {
|
|
| 98 |
# kill object$loadings if present |
|
| 99 | 1x |
object[["loadings"]] <- NULL |
| 100 | ||
| 101 |
# get fit measures for each model |
|
| 102 | 1x |
if (!is.list(fit.measures)) fit.measures <- list(fit.measures = fit.measures) |
| 103 | ! |
if (!missing(fm.args)) fit.measures <- c(fit.measures, fm.args) |
| 104 | 1x |
res <- simplify2array(lapply( |
| 105 | 1x |
object, |
| 106 | 1x |
function(x) {
|
| 107 | 4x |
lav_fit_measures( |
| 108 | 4x |
object = x, |
| 109 | 4x |
fit.measures = fit.measures, h1.model = h1.model, |
| 110 | 4x |
baseline.model = baseline.model, |
| 111 | 4x |
output = "vector" |
| 112 |
) |
|
| 113 |
} |
|
| 114 |
) |
|
| 115 |
) |
|
| 116 | ||
| 117 |
# check if res is a matrix |
|
| 118 | 1x |
if (!is.matrix(res)) {
|
| 119 | ! |
if (is.numeric(res)) {
|
| 120 |
# fit.measures is just 1 element, or only one was correct |
|
| 121 | ! |
NAME <- names(res)[1] |
| 122 | ! |
res <- matrix(res, nrow = 1L) |
| 123 | ! |
rownames(res) <- NAME |
| 124 |
} else { # wrong fit measures?
|
|
| 125 |
# create empty matrix |
|
| 126 | ! |
res <- matrix(0, nrow = 0L, ncol = length(object)) |
| 127 |
} |
|
| 128 |
} |
|
| 129 | ||
| 130 |
# rownames |
|
| 131 | 1x |
nfactors <- sapply(object, function(x) x@pta$nfac[[1]]) |
| 132 | 1x |
colnames(res) <- paste0("nfactors = ", nfactors)
|
| 133 | ||
| 134 |
# class |
|
| 135 | 1x |
class(res) <- c("lavaan.matrix", "matrix")
|
| 136 | ||
| 137 | 1x |
res |
| 138 |
} |
|
| 139 | ||
| 140 | ||
| 141 |
lav_fit_measures <- function(object, fit.measures = "all", |
|
| 142 |
baseline.model = NULL, h1.model = NULL, |
|
| 143 |
fm.args = list( |
|
| 144 |
standard.test = "default", |
|
| 145 |
scaled.test = "default", |
|
| 146 |
rmsea.ci.level = 0.90, |
|
| 147 |
rmsea.close.h0 = 0.05, |
|
| 148 |
rmsea.notclose.h0 = 0.08, |
|
| 149 |
robust = TRUE, |
|
| 150 |
cat.check.pd = TRUE |
|
| 151 |
), |
|
| 152 |
output = "vector") {
|
|
| 153 |
# check object |
|
| 154 | 64x |
object <- lav_object_check_version(object) |
| 155 | ||
| 156 |
# default fm.args |
|
| 157 | 64x |
default.fm.args <- list( |
| 158 | 64x |
standard.test = "default", |
| 159 | 64x |
scaled.test = "default", |
| 160 | 64x |
rmsea.ci.level = 0.90, |
| 161 | 64x |
rmsea.close.h0 = 0.05, |
| 162 | 64x |
rmsea.notclose.h0 = 0.08, |
| 163 | 64x |
robust = TRUE, |
| 164 | 64x |
cat.check.pd = TRUE |
| 165 |
) |
|
| 166 | 64x |
if (!missing(fm.args)) {
|
| 167 | ! |
lav_deprecated_args("fit.measures", "fm.args")
|
| 168 | ! |
fm.args <- modifyList(default.fm.args, fm.args) |
| 169 |
} else {
|
|
| 170 | 64x |
fm.args <- default.fm.args |
| 171 |
} |
|
| 172 | 64x |
if (is.list(fit.measures)) {
|
| 173 | 64x |
if (is.null(names(fit.measures)) || |
| 174 | 64x |
is.null(fit.measures$fit.measures)) {
|
| 175 | ! |
lav_msg_stop(gettextf( |
| 176 | ! |
"If %s is a list, it must contain a named element %s.", |
| 177 | ! |
"fit.measures" |
| 178 |
)) |
|
| 179 |
} |
|
| 180 | 64x |
temp <- fit.measures$fit.measures |
| 181 | 64x |
fit.measures$fit.measures <- NULL |
| 182 | 64x |
fm.args <- modifyList(default.fm.args, fit.measures) |
| 183 | 64x |
fit.measures <- temp |
| 184 |
} |
|
| 185 | ||
| 186 |
# standard test |
|
| 187 | 64x |
if (fm.args$standard.test == "default") {
|
| 188 | 64x |
fm.args$standard.test <- object@Options$standard.test |
| 189 |
# usually "standard", but could have been changed |
|
| 190 | 64x |
if (is.null(fm.args$standard.test)) { # <older objects
|
| 191 | ! |
fm.args$standard.test <- "standard" |
| 192 |
} |
|
| 193 |
} |
|
| 194 | ||
| 195 |
# scaled test |
|
| 196 | 64x |
if (fm.args$scaled.test == "default") {
|
| 197 | 64x |
fm.args$scaled.test <- object@Options$scaled.test |
| 198 |
# usually "standard", but could have been changed |
|
| 199 | 64x |
if (is.null(fm.args$scaled.test)) { # <older objects
|
| 200 | ! |
fm.args$scaled.test <- "standard" |
| 201 |
} |
|
| 202 |
} |
|
| 203 | ||
| 204 |
# do we have data? (yep, we had to include this check) |
|
| 205 | 64x |
if (object@Data@data.type == "none") {
|
| 206 | ! |
lav_msg_stop(gettext("fit measures not available if there is no data."))
|
| 207 |
} |
|
| 208 | ||
| 209 |
# has the model converged? |
|
| 210 | 64x |
if (object@optim$npar > 0L && !object@optim$converged) {
|
| 211 | ! |
lav_msg_stop(gettext( |
| 212 | ! |
"fit measures not available if model did not converge")) |
| 213 |
} |
|
| 214 | ||
| 215 |
# do we have a test statistic? |
|
| 216 | 64x |
TEST <- lavInspect(object, "test") |
| 217 | 64x |
test.names <- unname(sapply(TEST, "[[", "test")) |
| 218 | 64x |
if (test.names[1] == "none") {
|
| 219 | ! |
lav_msg_stop(gettext("fit measures not available if test = \"none\"."))
|
| 220 |
#FIXME: allow RMRs, log.likelihoods, info criteria, npar, ntotal |
|
| 221 |
} |
|
| 222 | ||
| 223 | 64x |
standard.test <- fm.args$standard.test |
| 224 | 64x |
scaled.test <- fm.args$scaled.test |
| 225 | ||
| 226 |
# check standard.test |
|
| 227 | 64x |
standard.test <- lav_test_rename(standard.test, check = TRUE)[1] # only 1 |
| 228 | ||
| 229 |
# check scaled.test |
|
| 230 | 64x |
if (!scaled.test %in% c("none", "default", "standard")) {
|
| 231 | ! |
scaled.test <- lav_test_rename(scaled.test, check = TRUE)[1] # only 1 |
| 232 |
} |
|
| 233 | ||
| 234 |
# which test statistic do we need? |
|
| 235 | 64x |
rerun.lavtest.flag <- FALSE |
| 236 | 64x |
if (!standard.test %in% test.names) {
|
| 237 | ! |
rerun.lavtest.flag <- TRUE |
| 238 |
} |
|
| 239 | 64x |
if (!scaled.test %in% c("none", "default", "standard") &&
|
| 240 | 64x |
!scaled.test %in% test.names) {
|
| 241 | ! |
rerun.lavtest.flag <- TRUE |
| 242 |
} |
|
| 243 | ||
| 244 |
# do we have a scaled test statistic? if so, which one? |
|
| 245 | 64x |
scaled.flag <- FALSE |
| 246 | 64x |
if (scaled.test != "none" && |
| 247 | 64x |
any(test.names %in% c( |
| 248 | 64x |
"satorra.bentler", |
| 249 | 64x |
"yuan.bentler", "yuan.bentler.mplus", |
| 250 | 64x |
"mean.var.adjusted", "scaled.shifted" |
| 251 |
))) {
|
|
| 252 | 6x |
scaled.flag <- TRUE |
| 253 | 6x |
if (scaled.test %in% c("standard", "default")) {
|
| 254 | 6x |
tmp.idx <- which(test.names %in% c( |
| 255 | 6x |
"satorra.bentler", |
| 256 | 6x |
"yuan.bentler", "yuan.bentler.mplus", |
| 257 | 6x |
"mean.var.adjusted", "scaled.shifted" |
| 258 |
)) |
|
| 259 | 6x |
scaled.test <- test.names[tmp.idx[1]] |
| 260 |
} |
|
| 261 |
} |
|
| 262 | ||
| 263 |
# rerun lavTest? |
|
| 264 | 64x |
if (rerun.lavtest.flag) {
|
| 265 | ! |
this.test <- standard.test |
| 266 | ! |
if (scaled.flag) {
|
| 267 | ! |
this.test <- unique(this.test, scaled.test) |
| 268 |
} |
|
| 269 | ! |
TEST <- lavTest(object, |
| 270 | ! |
test = this.test, scaled.test = standard.test, |
| 271 | ! |
drop.list.single = FALSE |
| 272 |
) |
|
| 273 |
# replace in object, if we pass it to lav_fit_* functions |
|
| 274 | ! |
object@test <- TEST |
| 275 | ! |
test.names <- unname(sapply(TEST, "[[", "test")) |
| 276 |
} |
|
| 277 | ||
| 278 | ||
| 279 |
# TDJ: Check for user-supplied h1 model |
|
| 280 |
# Similar to BASELINE model, use the following priority: |
|
| 281 |
# 1. user-provided h1 model |
|
| 282 |
# 2. h1 model in @external slot |
|
| 283 |
# 3. default h1 model (already in @h1 slot, no update necessary) |
|
| 284 | ||
| 285 | 64x |
user_h1_exists <- FALSE |
| 286 |
# 1. user-provided h1 model |
|
| 287 | 64x |
if (!is.null(h1.model)) {
|
| 288 | ! |
stopifnot(inherits(h1.model, "lavaan")) |
| 289 | ! |
user_h1_exists <- TRUE |
| 290 | ||
| 291 |
# 2. h1 model in @external slot |
|
| 292 | 64x |
} else if (!is.null(object@external$h1.model)) {
|
| 293 | ! |
stopifnot(inherits(object@external$h1.model, "lavaan")) |
| 294 | ! |
h1.model <- object@external$h1.model |
| 295 | ! |
user_h1_exists <- TRUE |
| 296 |
} |
|
| 297 | ||
| 298 |
## Update statistics in @test slot? |
|
| 299 | 64x |
if (user_h1_exists) {
|
| 300 |
## update @test slot |
|
| 301 | ! |
FIT <- lav_update_test_custom_h1(lav_obj_h0 = object, lav_obj_h1 = h1.model) |
| 302 | ||
| 303 |
## re-assign TEST object that is used below |
|
| 304 | ! |
object@test <- TEST <- FIT@test |
| 305 | ! |
test.names <- unname(sapply(TEST, "[[", "test")) |
| 306 |
} |
|
| 307 | ||
| 308 |
# get index of standard.test in TEST |
|
| 309 | 64x |
test.idx <- which(test.names == standard.test)[1] |
| 310 | ||
| 311 |
# get index of scaled test (if any) in TEST |
|
| 312 | 64x |
if (scaled.flag) {
|
| 313 | 6x |
scaled.idx <- which(test.names == scaled.test)[1] |
| 314 |
} |
|
| 315 | ||
| 316 |
# check output argument |
|
| 317 | 64x |
if (output %in% c("vector", "horizontal")) {
|
| 318 | 64x |
output <- "vector" |
| 319 | ! |
} else if (output %in% c("list")) {
|
| 320 | ! |
output <- "list" |
| 321 | ! |
} else if (output %in% c("matrix", "vertical")) {
|
| 322 | ! |
output <- "matrix" |
| 323 | ! |
} else if (output %in% c("text", "pretty", "summary")) {
|
| 324 | ! |
output <- "text" |
| 325 |
} else {
|
|
| 326 | ! |
lav_msg_stop(gettextf("output should be %s.",
|
| 327 | ! |
lav_msg_view(c("vector", "list", "matrix", "text"), "none", FALSE)
|
| 328 |
)) |
|
| 329 |
} |
|
| 330 | ||
| 331 |
# options |
|
| 332 | 64x |
categorical.flag <- object@Model@categorical |
| 333 | 64x |
fiml.flag <- (fm.args$robust && |
| 334 | 64x |
object@Options$missing %in% c("ml", "ml.x"))
|
| 335 | 64x |
estimator <- object@Options$estimator |
| 336 | ||
| 337 |
# basic ingredients |
|
| 338 | 64x |
X2 <- TEST[[test.idx]]$stat |
| 339 | 64x |
df <- TEST[[test.idx]]$df |
| 340 | 64x |
if (scaled.flag) {
|
| 341 | 6x |
X2.scaled <- TEST[[scaled.idx]]$stat |
| 342 | 6x |
df.scaled <- TEST[[scaled.idx]]$df |
| 343 |
} |
|
| 344 | 64x |
npar <- lav_object_inspect_npar(object = object, ceq = TRUE) |
| 345 | 64x |
N <- lav_object_inspect_ntotal(object = object) # N vs N-1 |
| 346 | ||
| 347 | ||
| 348 |
# define 'sets' of fit measures: |
|
| 349 | 64x |
fit.always <- c("npar")
|
| 350 | ||
| 351 |
# basic chi-square test |
|
| 352 | 64x |
fit.chisq <- c("fmin", "chisq", "df", "pvalue")
|
| 353 | 64x |
if (scaled.flag) {
|
| 354 | 6x |
fit.chisq <- c( |
| 355 | 6x |
fit.chisq, "chisq.scaled", "df.scaled", "pvalue.scaled", |
| 356 | 6x |
"chisq.scaling.factor" |
| 357 |
) |
|
| 358 |
} |
|
| 359 | ||
| 360 |
# baseline model |
|
| 361 | 64x |
fit.baseline <- c("baseline.chisq", "baseline.df", "baseline.pvalue")
|
| 362 | 64x |
if (scaled.flag) {
|
| 363 | 6x |
fit.baseline <- c( |
| 364 | 6x |
fit.baseline, "baseline.chisq.scaled", |
| 365 | 6x |
"baseline.df.scaled", "baseline.pvalue.scaled", |
| 366 | 6x |
"baseline.chisq.scaling.factor" |
| 367 |
) |
|
| 368 |
} |
|
| 369 | ||
| 370 | 64x |
fit.cfi.tli <- c("cfi", "tli")
|
| 371 | 64x |
if (scaled.flag) {
|
| 372 | 6x |
fit.cfi.tli <- c(fit.cfi.tli, "cfi.scaled", "tli.scaled") |
| 373 |
} |
|
| 374 | 64x |
if (fm.args$robust && (scaled.flag || categorical.flag || fiml.flag)) {
|
| 375 | 15x |
fit.cfi.tli <- c(fit.cfi.tli, "cfi.robust", "tli.robust") |
| 376 |
} |
|
| 377 | ||
| 378 |
# other incremental fit indices |
|
| 379 | 64x |
fit.cfi.other <- c("nnfi", "rfi", "nfi", "pnfi", "ifi", "rni")
|
| 380 | 64x |
if (scaled.flag) {
|
| 381 | 6x |
fit.cfi.other <- c( |
| 382 | 6x |
fit.cfi.other, "nnfi.scaled", "rfi.scaled", |
| 383 | 6x |
"nfi.scaled", "pnfi.scaled", "ifi.scaled", "rni.scaled" |
| 384 |
) |
|
| 385 |
} |
|
| 386 | 64x |
if (fm.args$robust && (scaled.flag || categorical.flag || fiml.flag)) {
|
| 387 | 15x |
fit.cfi.other <- c(fit.cfi.other, "nnfi.robust", "rni.robust") |
| 388 |
} |
|
| 389 | 64x |
fit.cfi <- c(fit.baseline, fit.cfi.tli, fit.cfi.other) |
| 390 | ||
| 391 |
# likelihood based measures |
|
| 392 | 64x |
if (estimator == "MML") {
|
| 393 | ! |
fit.logl <- c("logl", "aic", "bic", "ntotal", "bic2")
|
| 394 |
} else {
|
|
| 395 | 64x |
fit.logl <- c( |
| 396 | 64x |
"logl", "unrestricted.logl", "aic", "bic", |
| 397 | 64x |
"ntotal", "bic2" |
| 398 |
) |
|
| 399 |
} |
|
| 400 | 64x |
if (scaled.flag && |
| 401 | 64x |
scaled.test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
|
| 402 | 3x |
fit.logl <- c(fit.logl, "scaling.factor.h1", "scaling.factor.h0") |
| 403 |
} |
|
| 404 | ||
| 405 |
# rmsea |
|
| 406 | 64x |
fit.rmsea <- c( |
| 407 | 64x |
"rmsea", |
| 408 | 64x |
"rmsea.ci.lower", "rmsea.ci.upper", "rmsea.ci.level", |
| 409 | 64x |
"rmsea.pvalue", "rmsea.close.h0", |
| 410 | 64x |
"rmsea.notclose.pvalue", "rmsea.notclose.h0" |
| 411 |
) |
|
| 412 | 64x |
if (scaled.flag) {
|
| 413 | 6x |
fit.rmsea <- c( |
| 414 | 6x |
fit.rmsea, "rmsea.scaled", "rmsea.ci.lower.scaled", |
| 415 | 6x |
"rmsea.ci.upper.scaled", "rmsea.pvalue.scaled", |
| 416 | 6x |
"rmsea.notclose.pvalue.scaled" |
| 417 |
) |
|
| 418 |
} |
|
| 419 | 64x |
if (fm.args$robust && (scaled.flag || categorical.flag || fiml.flag)) {
|
| 420 | 15x |
fit.rmsea <- c( |
| 421 | 15x |
fit.rmsea, "rmsea.robust", "rmsea.ci.lower.robust", |
| 422 | 15x |
"rmsea.ci.upper.robust", "rmsea.pvalue.robust", |
| 423 | 15x |
"rmsea.notclose.pvalue.robust" |
| 424 |
) |
|
| 425 |
} |
|
| 426 | ||
| 427 |
# srmr |
|
| 428 | 64x |
if (categorical.flag) {
|
| 429 | 3x |
fit.srmr <- c("srmr")
|
| 430 | 3x |
fit.srmr2 <- c( |
| 431 | 3x |
"rmr", "rmr_nomean", |
| 432 | 3x |
"srmr", # per default equal to srmr_bentler_nomean |
| 433 | 3x |
"srmr_bentler", "srmr_bentler_nomean", |
| 434 | 3x |
"crmr", "crmr_nomean", |
| 435 | 3x |
"srmr_mplus", "srmr_mplus_nomean" |
| 436 |
) |
|
| 437 |
} else {
|
|
| 438 | 61x |
if (object@Data@nlevels > 1L) {
|
| 439 | 3x |
fit.srmr <- c("srmr", "srmr_within", "srmr_between")
|
| 440 | 3x |
fit.srmr2 <- c("srmr", "srmr_within", "srmr_between")
|
| 441 |
} else {
|
|
| 442 | 58x |
fit.srmr <- c("srmr")
|
| 443 | 58x |
fit.srmr2 <- c( |
| 444 | 58x |
"rmr", "rmr_nomean", |
| 445 | 58x |
"srmr", # the default |
| 446 | 58x |
"srmr_bentler", "srmr_bentler_nomean", |
| 447 | 58x |
"crmr", "crmr_nomean", |
| 448 | 58x |
"srmr_mplus", "srmr_mplus_nomean" |
| 449 |
) |
|
| 450 |
} |
|
| 451 |
} |
|
| 452 | ||
| 453 |
# various |
|
| 454 | 64x |
if (object@Data@nlevels > 1L) {
|
| 455 | 3x |
fit.other <- "" |
| 456 | 61x |
} else if (estimator == "PML") {
|
| 457 | ! |
fit.other <- c("cn_05", "cn_01", "mfi")
|
| 458 | ! |
if (!categorical.flag) { # really needed?
|
| 459 | ! |
fit.other <- c(fit.other, "ecvi") |
| 460 |
} |
|
| 461 |
} else {
|
|
| 462 | 61x |
fit.other <- c("cn_05", "cn_01", "gfi", "agfi", "pgfi", "mfi")
|
| 463 | 61x |
if (!categorical.flag) { # really needed?
|
| 464 | 58x |
fit.other <- c(fit.other, "ecvi") |
| 465 |
} else {
|
|
| 466 | 3x |
fit.other <- c(fit.other, "wrmr") |
| 467 |
} |
|
| 468 |
} |
|
| 469 | ||
| 470 |
# lower case |
|
| 471 | 64x |
fit.measures <- fit.measures.orig <- tolower(fit.measures) |
| 472 | ||
| 473 |
# select 'default' fit measures |
|
| 474 | 64x |
if (length(fit.measures) == 1L) {
|
| 475 | 44x |
if (fit.measures == "default") {
|
| 476 | 4x |
if (estimator == "ML" || estimator == "PML") {
|
| 477 | 4x |
fit.measures <- c( |
| 478 | 4x |
fit.always, fit.chisq, fit.baseline, |
| 479 | 4x |
fit.cfi.tli, fit.logl, |
| 480 | 4x |
fit.rmsea, fit.srmr |
| 481 |
) |
|
| 482 | ! |
} else if (estimator == "MML") {
|
| 483 | ! |
fit.measures <- c(fit.always, fit.logl) |
| 484 |
} else {
|
|
| 485 | ! |
fit.measures <- c( |
| 486 | ! |
fit.always, |
| 487 | ! |
fit.chisq, fit.baseline, fit.cfi.tli, |
| 488 | ! |
fit.rmsea, fit.srmr |
| 489 |
) |
|
| 490 |
} |
|
| 491 | 40x |
} else if (fit.measures == "all") {
|
| 492 | 20x |
if (estimator == "ML") {
|
| 493 | 15x |
fit.measures <- c( |
| 494 | 15x |
fit.always, fit.chisq, |
| 495 | 15x |
fit.baseline, fit.cfi.tli, fit.cfi.other, |
| 496 | 15x |
fit.logl, fit.rmsea, fit.srmr2, fit.other |
| 497 |
) |
|
| 498 |
} else {
|
|
| 499 | 5x |
fit.measures <- c( |
| 500 | 5x |
fit.always, fit.chisq, |
| 501 | 5x |
fit.baseline, fit.cfi.tli, fit.cfi.other, |
| 502 | 5x |
fit.rmsea, fit.srmr2, fit.other |
| 503 |
) |
|
| 504 |
} |
|
| 505 |
} |
|
| 506 |
} |
|
| 507 | ||
| 508 |
# catch empty list |
|
| 509 | 64x |
if (length(fit.measures) == 0L) {
|
| 510 | ! |
return(list()) |
| 511 |
} |
|
| 512 | ||
| 513 |
# main container |
|
| 514 | 64x |
indices <- list() |
| 515 | 64x |
indices["npar"] <- npar |
| 516 | 64x |
indices["ntotal"] <- object@SampleStats@ntotal |
| 517 | 64x |
indices["fmin"] <- object@optim$fx # note = 0.5 * fmin if ML |
| 518 | ||
| 519 |
# CHI-SQUARE TEST |
|
| 520 | 64x |
if (any(fit.chisq %in% fit.measures)) {
|
| 521 | 64x |
indices["chisq"] <- X2 |
| 522 | 64x |
indices["df"] <- df |
| 523 | 64x |
indices["pvalue"] <- TEST[[test.idx]]$pvalue |
| 524 | 64x |
if (scaled.flag) {
|
| 525 | 6x |
indices["chisq.scaled"] <- X2.scaled |
| 526 | 6x |
indices["df.scaled"] <- df.scaled |
| 527 | 6x |
indices["chisq.scaling.factor"] <- TEST[[scaled.idx]]$scaling.factor |
| 528 | 6x |
indices["pvalue.scaled"] <- TEST[[scaled.idx]]$pvalue |
| 529 |
} |
|
| 530 |
} |
|
| 531 | ||
| 532 |
# BASELINE FAMILY |
|
| 533 | 64x |
if (any(fit.cfi %in% fit.measures)) {
|
| 534 | ||
| 535 |
# rerun baseline? |
|
| 536 | 44x |
if (rerun.lavtest.flag) {
|
| 537 | ! |
object@Options$test <- this.test |
| 538 | ! |
fit.indep <- try(lav_object_independence(object), silent = TRUE) |
| 539 |
# override object |
|
| 540 | ! |
object@baseline$test <- fit.indep@test |
| 541 |
} |
|
| 542 | ||
| 543 | 44x |
indices <- c( |
| 544 | 44x |
indices, |
| 545 | 44x |
lav_fit_cfi_lavobject( |
| 546 | 44x |
lavobject = object, |
| 547 | 44x |
fit.measures = fit.measures, |
| 548 | 44x |
baseline.model = baseline.model, |
| 549 | 44x |
h1.model = h1.model, |
| 550 | 44x |
standard.test = standard.test, |
| 551 | 44x |
scaled.test = scaled.test, |
| 552 | 44x |
robust = fm.args$robust, |
| 553 | 44x |
cat.check.pd = fm.args$cat.check.pd |
| 554 |
) |
|
| 555 |
) |
|
| 556 |
} |
|
| 557 | ||
| 558 |
# INFORMATION CRITERIA |
|
| 559 | 64x |
if (any(fit.logl %in% fit.measures)) {
|
| 560 | 19x |
indices <- c( |
| 561 | 19x |
indices, |
| 562 | 19x |
lav_fit_aic_lavobject( |
| 563 | 19x |
lavobject = object, |
| 564 | 19x |
fit.measures = fit.measures, |
| 565 | 19x |
standard.test = standard.test, |
| 566 | 19x |
scaled.test = scaled.test, |
| 567 | 19x |
estimator = estimator |
| 568 |
) |
|
| 569 |
) |
|
| 570 |
} |
|
| 571 | ||
| 572 |
# RMSEA and friends |
|
| 573 | 64x |
if (any(fit.rmsea %in% fit.measures)) {
|
| 574 |
# check rmsea options |
|
| 575 | 44x |
rmsea.ci.level <- 0.90 |
| 576 | 44x |
rmsea.close.h0 <- 0.05 |
| 577 | 44x |
rmsea.notclose.h0 <- 0.08 |
| 578 | 44x |
if (!is.null(fm.args$rmsea.ci.level) && |
| 579 | 44x |
is.finite(fm.args$rmsea.ci.level)) {
|
| 580 | 44x |
rmsea.ci.level <- fm.args$rmsea.ci.level |
| 581 | 44x |
if (rmsea.ci.level < 0 || rmsea.ci.level > 1.0) {
|
| 582 | ! |
lav_msg_warn(gettextf( |
| 583 | ! |
"invalid rmsea.ci.level value [%s] set to default 0.90.", |
| 584 | ! |
rmsea.ci.level)) |
| 585 | ! |
rmsea.ci.level <- 0.90 |
| 586 |
} |
|
| 587 |
} |
|
| 588 | 44x |
if (!is.null(fm.args$rmsea.close.h0) && |
| 589 | 44x |
is.finite(fm.args$rmsea.close.h0)) {
|
| 590 | 44x |
rmsea.close.h0 <- fm.args$rmsea.close.h0 |
| 591 | 44x |
if (rmsea.close.h0 < 0) {
|
| 592 | ! |
rmsea.close.h0 <- 0 |
| 593 |
} |
|
| 594 |
} |
|
| 595 | 44x |
if (!is.null(fm.args$rmsea.notclose.h0) && |
| 596 | 44x |
is.finite(fm.args$rmsea.notclose.h0)) {
|
| 597 | 44x |
rmsea.notclose.h0 <- fm.args$rmsea.notclose.h0 |
| 598 | 44x |
if (rmsea.notclose.h0 < 0) {
|
| 599 | ! |
rmsea.notclose.h0 <- 0 |
| 600 |
} |
|
| 601 |
} |
|
| 602 | 44x |
indices <- c( |
| 603 | 44x |
indices, |
| 604 | 44x |
lav_fit_rmsea_lavobject( |
| 605 | 44x |
lavobject = object, |
| 606 | 44x |
fit.measures = fit.measures, |
| 607 | 44x |
standard.test = standard.test, |
| 608 | 44x |
scaled.test = scaled.test, |
| 609 | 44x |
ci.level = rmsea.ci.level, |
| 610 | 44x |
close.h0 = rmsea.close.h0, |
| 611 | 44x |
notclose.h0 = rmsea.notclose.h0, |
| 612 | 44x |
robust = fm.args$robust, |
| 613 | 44x |
cat.check.pd = fm.args$cat.check.pd |
| 614 |
) |
|
| 615 |
) |
|
| 616 |
} |
|
| 617 | ||
| 618 |
# SRMR and friends |
|
| 619 | 64x |
if (any(fit.srmr2 %in% fit.measures)) {
|
| 620 | 24x |
indices <- c( |
| 621 | 24x |
indices, |
| 622 | 24x |
lav_fit_srmr_lavobject( |
| 623 | 24x |
lavobject = object, |
| 624 | 24x |
fit.measures = fit.measures |
| 625 |
) |
|
| 626 |
) |
|
| 627 |
} |
|
| 628 | ||
| 629 |
# GFI and friends |
|
| 630 | 64x |
fit.gfi <- c("gfi", "agfi", "pgfi")
|
| 631 | 64x |
if (any(fit.gfi %in% fit.measures)) {
|
| 632 | 19x |
indices <- c( |
| 633 | 19x |
indices, |
| 634 | 19x |
lav_fit_gfi_lavobject( |
| 635 | 19x |
lavobject = object, |
| 636 | 19x |
fit.measures = fit.measures |
| 637 |
) |
|
| 638 |
) |
|
| 639 |
} |
|
| 640 | ||
| 641 |
# various: Hoelter Critical N (CN) |
|
| 642 | 64x |
if (any(c("cn_05", "cn_01") %in% fit.measures)) {
|
| 643 | 19x |
indices["cn_05"] <- lav_fit_cn(X2 = X2, df = df, N = N, alpha = 0.05) |
| 644 | 19x |
indices["cn_01"] <- lav_fit_cn(X2 = X2, df = df, N = N, alpha = 0.01) |
| 645 |
} |
|
| 646 | ||
| 647 |
# various: WRMR |
|
| 648 | 64x |
if ("wrmr" %in% fit.measures) {
|
| 649 | 1x |
nel <- length(object@SampleStats@WLS.obs[[1]]) |
| 650 | 1x |
indices["wrmr"] <- lav_fit_wrmr(X2 = X2, nel = nel) |
| 651 |
} |
|
| 652 | ||
| 653 |
# various: MFI |
|
| 654 | 64x |
if ("mfi" %in% fit.measures) {
|
| 655 | 19x |
indices["mfi"] <- lav_fit_mfi(X2 = X2, df = df, N = N) |
| 656 |
} |
|
| 657 | ||
| 658 |
# various: ECVI |
|
| 659 | 64x |
if ("ecvi" %in% fit.measures) {
|
| 660 | 18x |
indices["ecvi"] <- lav_fit_ecvi(X2 = X2, npar = npar, N = N) |
| 661 |
} |
|
| 662 | ||
| 663 | ||
| 664 |
# keep only what we need |
|
| 665 | 64x |
out <- indices[fit.measures] |
| 666 | ||
| 667 | 64x |
if (all(is.na(names(out)))) { # perhaps, fit.measures = ""
|
| 668 |
# nothing left |
|
| 669 | ! |
return(numeric(0L)) |
| 670 |
} |
|
| 671 | ||
| 672 |
# select output type |
|
| 673 | 64x |
if (output == "list") {
|
| 674 |
# nothing to do |
|
| 675 | 64x |
} else if (output == "vector") {
|
| 676 | 64x |
out <- unlist(out) |
| 677 | 64x |
class(out) <- c("lavaan.vector", "numeric")
|
| 678 | ! |
} else if (output == "matrix") {
|
| 679 | ! |
out <- as.matrix(unlist(out)) |
| 680 | ! |
colnames(out) <- "" |
| 681 | ! |
class(out) <- c("lavaan.matrix", "matrix")
|
| 682 | ! |
} else if (output == "text") {
|
| 683 | ! |
out <- unlist(out) |
| 684 | ! |
class(out) <- c("lavaan.fitMeasures", "lavaan.vector", "numeric")
|
| 685 |
} |
|
| 686 | ||
| 687 |
# attributes? |
|
| 688 |
# only if fit.measures == "all" or "default" |
|
| 689 | 64x |
if (length(fit.measures.orig) == 1L && |
| 690 | 64x |
fit.measures.orig %in% c("all", "default")) {
|
| 691 | 24x |
X2.label <- TEST[[test.idx]]$label # NULL if "standard" |
| 692 | 24x |
X2.baseline.label <- object@baseline$test[[test.idx]]$label |
| 693 | 24x |
attr(out, "X2.label") <- X2.label |
| 694 | 24x |
attr(out, "X2.baseline.label") <- X2.baseline.label |
| 695 | 24x |
if (standard.test != "standard") {
|
| 696 | ! |
attr(out, "standard.test") <- standard.test |
| 697 |
} |
|
| 698 | 24x |
if (scaled.flag && scaled.test != "standard") {
|
| 699 | 2x |
attr(out, "scaled.test") <- scaled.test |
| 700 |
} |
|
| 701 |
} |
|
| 702 | ||
| 703 | 64x |
out |
| 704 |
} |
|
| 705 | ||
| 706 |
# print a nice summary of the fit measures |
|
| 707 |
lav_fitmeasures_print <- function(x, ..., nd = 3L, add.h0 = TRUE) {
|
|
| 708 | ! |
names.x <- names(x) |
| 709 | ||
| 710 |
# scaled? |
|
| 711 | ! |
scaled.flag <- "chisq.scaled" %in% names.x |
| 712 | ||
| 713 |
# num format |
|
| 714 | ! |
num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")
|
| 715 | ||
| 716 |
## TDJ: optionally add h0 model's fit statistic, for lavaan.mi |
|
| 717 | ! |
if (add.h0 && "chisq" %in% names.x) {
|
| 718 | ! |
cat("\nModel Test User Model:\n\n")
|
| 719 | ||
| 720 |
# container three columns |
|
| 721 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 722 | ||
| 723 |
# TDJ: Add header used in summary() by lavaan.mi |
|
| 724 | ! |
if (scaled.flag) {
|
| 725 | ! |
c1 <- c("", c1)
|
| 726 | ! |
c2 <- c("Standard", c2)
|
| 727 | ! |
c3 <- c("Scaled", c3)
|
| 728 |
} |
|
| 729 | ||
| 730 |
# if test is not standard, add label |
|
| 731 | ! |
if (!is.null(attr(x, "X2.label"))) {
|
| 732 | ! |
c1 <- c(c1, attr(x, "X2.label")) |
| 733 | ! |
c2 <- c(c2, "") |
| 734 | ! |
c3 <- c(c3, "") |
| 735 |
} |
|
| 736 | ||
| 737 | ! |
c1 <- c(c1, "Test statistic") |
| 738 | ! |
c2 <- c(c2, sprintf(num.format, x["chisq"])) |
| 739 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 740 | ! |
sprintf(num.format, x["chisq.scaled"]), "" |
| 741 |
)) |
|
| 742 | ||
| 743 | ! |
c1 <- c(c1, "Degrees of freedom") |
| 744 | ! |
c2 <- c(c2, x["df"]) |
| 745 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 746 | ! |
ifelse(x["df.scaled"] %% 1 == 0, x["df.scaled"], |
| 747 | ! |
sprintf(num.format, x["df.scaled"]) |
| 748 |
), "" |
|
| 749 |
)) |
|
| 750 | ||
| 751 | ! |
c1 <- c(c1, "P-value") |
| 752 | ! |
c2 <- c(c2, sprintf(num.format, x["pvalue"])) |
| 753 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 754 | ! |
sprintf(num.format, x["pvalue.scaled"]), "" |
| 755 |
)) |
|
| 756 | ||
| 757 | ! |
if (scaled.flag && "chisq.scaling.factor" %in% names.x) {
|
| 758 | ! |
c1 <- c(c1, "Average scaling correction factor") |
| 759 | ! |
c2 <- c(c2, "") |
| 760 | ! |
c3 <- c(c3, sprintf(num.format, x["chisq.scaling.factor"])) |
| 761 | ||
| 762 |
## check for shift parameter |
|
| 763 | ! |
chisq.shift.parameter <- attr(attr(x, "header"), "shift") |
| 764 | ! |
if (!is.null(chisq.shift.parameter)) {
|
| 765 | ! |
c1 <- c(c1, "Average shift parameter", |
| 766 | ! |
" simple second-order correction") |
| 767 | ! |
c2 <- c(c2, "", "") |
| 768 |
## This is only provided by the fitMeasures() method for lavaan.mi-class |
|
| 769 | ! |
c3 <- c(c3, sprintf(num.format, chisq.shift.parameter), |
| 770 |
"") |
|
| 771 |
} |
|
| 772 |
} |
|
| 773 | ||
| 774 |
# check for lavaan.mi attributes "pool.method" and "pool.robust" |
|
| 775 | ! |
if (!is.null(attr(x, "pool.method"))) {
|
| 776 |
## extract information from lavaan.mi object about |
|
| 777 |
## the method used to pool the test statistic |
|
| 778 | ! |
pool.method <- attr( x , "pool.method") |
| 779 | ! |
pool.robust <- attr( x , "pool.robust") |
| 780 | ! |
standard.test <- attr(attr(x, "header"), "standard.test") |
| 781 | ! |
scaled.test <- attr(attr(x, "header"), "scaled.test") |
| 782 | ||
| 783 | ! |
c1 <- c(c1, "Pooling method") |
| 784 | ! |
c2 <- c(c2, pool.method) |
| 785 | ! |
c3 <- c(c3, "") |
| 786 | ||
| 787 |
## (conditionally for D2 method) add other pooling information |
|
| 788 | ! |
if (scaled.flag) {
|
| 789 | ! |
c1 <- c(c1, " Pooled statistic") |
| 790 | ! |
c2 <- c(c2, ifelse(pool.robust, dQuote(scaled.test), dQuote(standard.test))) |
| 791 | ! |
c3 <- c(c3, "") |
| 792 | ||
| 793 | ! |
if (pool.robust && pool.method == "D2") {
|
| 794 | ! |
c1 <- c(c1, paste0(" ", dQuote(scaled.test), " correction applied"))
|
| 795 | ! |
c2 <- c(c2, "BEFORE") |
| 796 | ! |
c3 <- c(c3, "pooling") |
| 797 |
} else {
|
|
| 798 | ! |
c1 <- c(c1, paste0(" ", dQuote(scaled.test), " correction applied"))
|
| 799 | ! |
c2 <- c(c2, "AFTER") |
| 800 | ! |
c3 <- c(c3, "pooling") |
| 801 |
} |
|
| 802 | ||
| 803 |
} |
|
| 804 |
} |
|
| 805 | ||
| 806 |
# format c1/c2/c3 |
|
| 807 | ! |
c1 <- format(c1, width = 35L) |
| 808 | ! |
c2 <- format(c2, width = 16L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 809 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 810 | ||
| 811 |
# create character matrix |
|
| 812 | ! |
if (scaled.flag) {
|
| 813 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 814 |
} else {
|
|
| 815 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 816 |
} |
|
| 817 | ! |
colnames(M) <- rep("", ncol(M))
|
| 818 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 819 | ||
| 820 |
|
|
| 821 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 822 |
} |
|
| 823 | ||
| 824 |
# print information about standard.test? (new in 0.6-21) |
|
| 825 |
# (only if "standard.test" is not "standard") |
|
| 826 | ! |
if (!is.null(attr(x, "standard.test"))) {
|
| 827 | ! |
cat("\nNote: fit measures based on the chi-square test statistic\n",
|
| 828 | ! |
" use", attr(x, "X2.label"),"\n") |
| 829 |
} |
|
| 830 | ||
| 831 |
# independence model |
|
| 832 | ! |
if ("baseline.chisq" %in% names.x) {
|
| 833 | ! |
cat("\nModel Test Baseline Model:\n\n")
|
| 834 | ||
| 835 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 836 |
# if test is not standard, add label |
|
| 837 | ! |
if (!is.null(attr(x, "X2.baseline.label"))) {
|
| 838 | ! |
c1 <- c(c1, attr(x, "X2.label")) |
| 839 | ! |
c2 <- c(c2, "") |
| 840 | ! |
c3 <- c(c3, "") |
| 841 |
} |
|
| 842 | ||
| 843 | ! |
c1 <- c(c1, "Test statistic") |
| 844 | ! |
c2 <- c(c2, sprintf(num.format, x["baseline.chisq"])) |
| 845 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 846 | ! |
sprintf(num.format, x["baseline.chisq.scaled"]), "" |
| 847 |
)) |
|
| 848 | ||
| 849 | ! |
c1 <- c(c1, "Degrees of freedom") |
| 850 | ! |
c2 <- c(c2, x["baseline.df"]) |
| 851 | ! |
c3 <- c(c3, ifelse(scaled.flag, ifelse(x["baseline.df.scaled"] %% 1 == 0, |
| 852 | ! |
x["baseline.df.scaled"], |
| 853 | ! |
sprintf(num.format, x["baseline.df.scaled"]) |
| 854 |
), |
|
| 855 |
"" |
|
| 856 |
)) |
|
| 857 | ||
| 858 | ! |
c1 <- c(c1, "P-value") |
| 859 | ! |
c2 <- c(c2, sprintf(num.format, x["baseline.pvalue"])) |
| 860 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 861 | ! |
sprintf(num.format, x["baseline.pvalue.scaled"]), "" |
| 862 |
)) |
|
| 863 | ||
| 864 | ! |
if (scaled.flag && "baseline.chisq.scaling.factor" %in% names.x) {
|
| 865 | ! |
c1 <- c(c1, "Scaling correction factor") |
| 866 | ! |
c2 <- c(c2, "") |
| 867 | ! |
c3 <- c(c3, sprintf(num.format, x["baseline.chisq.scaling.factor"])) |
| 868 |
} |
|
| 869 | ||
| 870 |
# format c1/c2/c3 |
|
| 871 | ! |
c1 <- format(c1, width = 35L) |
| 872 | ! |
c2 <- format(c2, width = 16L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 873 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 874 | ||
| 875 |
# create character matrix |
|
| 876 | ! |
if (scaled.flag) {
|
| 877 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 878 |
} else {
|
|
| 879 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 880 |
} |
|
| 881 | ! |
colnames(M) <- rep("", ncol(M))
|
| 882 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 883 | ||
| 884 |
|
|
| 885 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 886 |
} |
|
| 887 | ||
| 888 |
# cfi/tli |
|
| 889 | ! |
if (any(c("cfi", "tli", "nnfi", "rfi", "nfi", "ifi", "rni", "pnfi") %in% names.x)) {
|
| 890 | ! |
cat("\nUser Model versus Baseline Model:\n\n")
|
| 891 | ||
| 892 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 893 | ||
| 894 | ! |
if ("cfi" %in% names.x) {
|
| 895 | ! |
c1 <- c(c1, "Comparative Fit Index (CFI)") |
| 896 | ! |
c2 <- c(c2, sprintf(num.format, x["cfi"])) |
| 897 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 898 | ! |
sprintf(num.format, x["cfi.scaled"]), "" |
| 899 |
)) |
|
| 900 |
} |
|
| 901 | ||
| 902 | ! |
if ("tli" %in% names.x) {
|
| 903 | ! |
c1 <- c(c1, "Tucker-Lewis Index (TLI)") |
| 904 | ! |
c2 <- c(c2, sprintf(num.format, x["tli"])) |
| 905 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 906 | ! |
sprintf(num.format, x["tli.scaled"]), "" |
| 907 |
)) |
|
| 908 |
} |
|
| 909 | ||
| 910 | ! |
if ("cfi.robust" %in% names.x) {
|
| 911 | ! |
c1 <- c(c1, "") |
| 912 | ! |
c2 <- c(c2, "") |
| 913 | ! |
c3 <- c(c3, "") |
| 914 | ! |
c1 <- c(c1, "Robust Comparative Fit Index (CFI)") |
| 915 | ! |
if (scaled.flag) {
|
| 916 | ! |
c2 <- c(c2, "") |
| 917 | ! |
c3 <- c(c3, sprintf(num.format, x["cfi.robust"])) |
| 918 |
} else {
|
|
| 919 | ! |
c2 <- c(c2, sprintf(num.format, x["cfi.robust"])) |
| 920 | ! |
c3 <- c(c3, "") |
| 921 |
} |
|
| 922 |
} |
|
| 923 | ||
| 924 | ! |
if ("tli.robust" %in% names.x) {
|
| 925 | ! |
c1 <- c(c1, "Robust Tucker-Lewis Index (TLI)") |
| 926 | ! |
if (scaled.flag) {
|
| 927 | ! |
c2 <- c(c2, "") |
| 928 | ! |
c3 <- c(c3, sprintf(num.format, x["tli.robust"])) |
| 929 |
} else {
|
|
| 930 | ! |
c2 <- c(c2, sprintf(num.format, x["tli.robust"])) |
| 931 | ! |
c3 <- c(c3, "") |
| 932 |
} |
|
| 933 |
} |
|
| 934 | ||
| 935 | ! |
if ("nnfi" %in% names.x) {
|
| 936 | ! |
c1 <- c(c1, "Bentler-Bonett Non-normed Fit Index (NNFI)") |
| 937 | ! |
c2 <- c(c2, sprintf(num.format, x["nnfi"])) |
| 938 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 939 | ! |
sprintf(num.format, x["nnfi.robust"]), "" |
| 940 |
)) |
|
| 941 |
} |
|
| 942 | ||
| 943 | ! |
if ("nfi" %in% names.x) {
|
| 944 | ! |
c1 <- c(c1, "Bentler-Bonett Normed Fit Index (NFI)") |
| 945 | ! |
c2 <- c(c2, sprintf(num.format, x["nfi"])) |
| 946 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 947 | ! |
sprintf(num.format, x["nfi.scaled"]), "" |
| 948 |
)) |
|
| 949 |
} |
|
| 950 | ||
| 951 | ! |
if ("pnfi" %in% names.x) {
|
| 952 | ! |
c1 <- c(c1, "Parsimony Normed Fit Index (PNFI)") |
| 953 | ! |
c2 <- c(c2, sprintf(num.format, x["pnfi"])) |
| 954 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 955 | ! |
sprintf(num.format, x["pnfi.scaled"]), "" |
| 956 |
)) |
|
| 957 |
} |
|
| 958 | ||
| 959 | ! |
if ("rfi" %in% names.x) {
|
| 960 | ! |
c1 <- c(c1, "Bollen's Relative Fit Index (RFI)") |
| 961 | ! |
c2 <- c(c2, sprintf(num.format, x["rfi"])) |
| 962 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 963 | ! |
sprintf(num.format, x["rfi.scaled"]), "" |
| 964 |
)) |
|
| 965 |
} |
|
| 966 | ||
| 967 | ! |
if ("ifi" %in% names.x) {
|
| 968 | ! |
c1 <- c(c1, "Bollen's Incremental Fit Index (IFI)") |
| 969 | ! |
c2 <- c(c2, sprintf(num.format, x["ifi"])) |
| 970 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 971 | ! |
sprintf(num.format, x["ifi.scaled"]), "" |
| 972 |
)) |
|
| 973 |
} |
|
| 974 | ||
| 975 | ! |
if ("rni" %in% names.x) {
|
| 976 | ! |
c1 <- c(c1, "Relative Noncentrality Index (RNI)") |
| 977 | ! |
c2 <- c(c2, sprintf(num.format, x["rni"])) |
| 978 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 979 | ! |
sprintf(num.format, x["rni.robust"]), "" |
| 980 |
)) |
|
| 981 |
} |
|
| 982 | ||
| 983 |
# format c1/c2/c3 |
|
| 984 | ! |
c1 <- format(c1, width = 43L) |
| 985 | ! |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 986 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 987 | ||
| 988 |
# create character matrix |
|
| 989 | ! |
if (scaled.flag) {
|
| 990 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 991 |
} else {
|
|
| 992 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 993 |
} |
|
| 994 | ! |
colnames(M) <- rep("", ncol(M))
|
| 995 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 996 | ||
| 997 |
|
|
| 998 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 999 |
} |
|
| 1000 | ||
| 1001 |
# likelihood |
|
| 1002 | ! |
if ("logl" %in% names.x) {
|
| 1003 | ! |
cat("\nLoglikelihood and Information Criteria:\n\n")
|
| 1004 | ||
| 1005 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 1006 | ||
| 1007 | ! |
c1 <- c(c1, "Loglikelihood user model (H0)") |
| 1008 | ! |
c2 <- c(c2, sprintf(num.format, x["logl"])) |
| 1009 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["logl"]), "")) |
| 1010 | ! |
if (!is.na(x["scaling.factor.h0"])) {
|
| 1011 | ! |
c1 <- c(c1, "Scaling correction factor") |
| 1012 | ! |
c2 <- c(c2, sprintf(" %10s", ""))
|
| 1013 | ! |
c3 <- c(c3, sprintf(num.format, x["scaling.factor.h0"])) |
| 1014 | ! |
c1 <- c(c1, " for the MLR correction") |
| 1015 | ! |
c2 <- c(c2, "") |
| 1016 | ! |
c3 <- c(c3, "") |
| 1017 |
} |
|
| 1018 | ||
| 1019 | ! |
if ("unrestricted.logl" %in% names.x) {
|
| 1020 | ! |
c1 <- c(c1, "Loglikelihood unrestricted model (H1)") |
| 1021 | ! |
c2 <- c(c2, sprintf(num.format, x["unrestricted.logl"])) |
| 1022 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1023 | ! |
sprintf(num.format, x["unrestricted.logl"]), "" |
| 1024 |
)) |
|
| 1025 | ! |
if (!is.na(x["scaling.factor.h1"])) {
|
| 1026 | ! |
c1 <- c(c1, "Scaling correction factor") |
| 1027 | ! |
c2 <- c(c2, sprintf(" %10s", ""))
|
| 1028 | ! |
c3 <- c(c3, sprintf(num.format, x["scaling.factor.h1"])) |
| 1029 | ! |
c1 <- c(c1, " for the MLR correction") |
| 1030 | ! |
c2 <- c(c2, "") |
| 1031 | ! |
c3 <- c(c3, "") |
| 1032 |
} |
|
| 1033 |
} |
|
| 1034 | ||
| 1035 | ! |
c1 <- c(c1, "") |
| 1036 | ! |
c2 <- c(c2, "") |
| 1037 | ! |
c3 <- c(c3, "") |
| 1038 |
# c1 <- c(c1, "Number of free parameters") |
|
| 1039 |
# c2 <- c(c2, sprintf(" %10i", x["npar"]))
|
|
| 1040 |
# c3 <- c(c3, ifelse(scaled, sprintf(" %10i", x["npar"]), ""))
|
|
| 1041 | ||
| 1042 | ! |
c1 <- c(c1, "Akaike (AIC)") |
| 1043 | ! |
c2 <- c(c2, sprintf(num.format, x["aic"])) |
| 1044 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["aic"]), "")) |
| 1045 | ! |
c1 <- c(c1, "Bayesian (BIC)") |
| 1046 | ! |
c2 <- c(c2, sprintf(num.format, x["bic"])) |
| 1047 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["bic"]), "")) |
| 1048 | ! |
if (!is.na(x["bic2"])) {
|
| 1049 | ! |
c1 <- c(c1, "Sample-size adjusted Bayesian (SABIC)") |
| 1050 | ! |
c2 <- c(c2, sprintf(num.format, x["bic2"])) |
| 1051 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["bic2"]), "")) |
| 1052 |
} |
|
| 1053 | ||
| 1054 |
# format c1/c2/c3 |
|
| 1055 | ! |
c1 <- format(c1, width = 39L) |
| 1056 | ! |
c2 <- format(c2, width = 12L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 1057 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 1058 | ||
| 1059 |
# create character matrix |
|
| 1060 | ! |
if (scaled.flag) {
|
| 1061 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 1062 |
} else {
|
|
| 1063 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1064 |
} |
|
| 1065 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1066 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1067 | ||
| 1068 |
|
|
| 1069 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1070 |
} |
|
| 1071 | ||
| 1072 |
# RMSEA |
|
| 1073 | ! |
if ("rmsea" %in% names.x) {
|
| 1074 | ! |
cat("\nRoot Mean Square Error of Approximation:\n\n")
|
| 1075 | ||
| 1076 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 1077 | ||
| 1078 | ! |
c1 <- c(c1, "RMSEA") |
| 1079 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea"])) |
| 1080 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1081 | ! |
sprintf(num.format, x["rmsea.scaled"]), "" |
| 1082 |
)) |
|
| 1083 | ||
| 1084 | ! |
ci.level <- NULL |
| 1085 | ! |
if ("rmsea.ci.level" %in% names.x) {
|
| 1086 | ! |
ci.level <- x["rmsea.ci.level"] |
| 1087 |
} |
|
| 1088 | ! |
if ("rmsea.ci.lower" %in% names.x) {
|
| 1089 | ! |
if (is.null(ci.level)) {
|
| 1090 | ! |
c1 <- c(c1, "Confidence interval - lower") |
| 1091 |
} else {
|
|
| 1092 | ! |
c1 <- c(c1, paste0( |
| 1093 | ! |
sprintf("%2d", round(ci.level * 100)),
|
| 1094 | ! |
" Percent confidence interval - lower" |
| 1095 |
)) |
|
| 1096 |
} |
|
| 1097 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.ci.lower"])) |
| 1098 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1099 | ! |
sprintf(num.format, x["rmsea.ci.lower.scaled"]), "" |
| 1100 |
)) |
|
| 1101 | ! |
if (is.null(ci.level)) {
|
| 1102 | ! |
c1 <- c(c1, "Confidence interval - upper") |
| 1103 |
} else {
|
|
| 1104 | ! |
c1 <- c(c1, paste0( |
| 1105 | ! |
sprintf("%2d", round(ci.level * 100)),
|
| 1106 | ! |
" Percent confidence interval - upper" |
| 1107 |
)) |
|
| 1108 |
} |
|
| 1109 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.ci.upper"])) |
| 1110 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1111 | ! |
sprintf(num.format, x["rmsea.ci.upper.scaled"]), "" |
| 1112 |
)) |
|
| 1113 |
} |
|
| 1114 | ||
| 1115 | ! |
rmsea.close.h0 <- NULL |
| 1116 | ! |
if ("rmsea.close.h0" %in% names.x) {
|
| 1117 | ! |
rmsea.close.h0 <- x["rmsea.close.h0"] |
| 1118 |
} |
|
| 1119 | ! |
rmsea.notclose.h0 <- NULL |
| 1120 | ! |
if ("rmsea.notclose.h0" %in% names.x) {
|
| 1121 | ! |
rmsea.notclose.h0 <- x["rmsea.notclose.h0"] |
| 1122 |
} |
|
| 1123 | ! |
if ("rmsea.pvalue" %in% names.x) {
|
| 1124 | ! |
if (is.null(rmsea.close.h0)) {
|
| 1125 | ! |
c1 <- c(c1, "P-value H_0: RMSEA <= 0.05") |
| 1126 |
} else {
|
|
| 1127 | ! |
c1 <- c(c1, paste0( |
| 1128 | ! |
"P-value H_0: RMSEA <= ", |
| 1129 | ! |
sprintf("%4.3f", rmsea.close.h0)
|
| 1130 |
)) |
|
| 1131 |
} |
|
| 1132 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.pvalue"])) |
| 1133 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1134 | ! |
sprintf(num.format, x["rmsea.pvalue.scaled"]), "" |
| 1135 |
)) |
|
| 1136 |
} |
|
| 1137 | ! |
if ("rmsea.notclose.pvalue" %in% names.x) {
|
| 1138 | ! |
if (is.null(rmsea.notclose.h0)) {
|
| 1139 | ! |
c1 <- c(c1, "P-value H_0: RMSEA >= 0.080") |
| 1140 |
} else {
|
|
| 1141 | ! |
c1 <- c(c1, paste0( |
| 1142 | ! |
"P-value H_0: RMSEA >= ", |
| 1143 | ! |
sprintf("%4.3f", rmsea.notclose.h0)
|
| 1144 |
)) |
|
| 1145 |
} |
|
| 1146 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.notclose.pvalue"])) |
| 1147 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1148 | ! |
sprintf(num.format, x["rmsea.notclose.pvalue.scaled"]), "" |
| 1149 |
)) |
|
| 1150 |
} |
|
| 1151 | ||
| 1152 |
# robust |
|
| 1153 | ! |
if ("rmsea.robust" %in% names.x) {
|
| 1154 | ! |
c1 <- c(c1, "") |
| 1155 | ! |
c2 <- c(c2, "") |
| 1156 | ! |
c3 <- c(c3, "") |
| 1157 | ! |
c1 <- c(c1, "Robust RMSEA") |
| 1158 | ! |
if (scaled.flag) {
|
| 1159 | ! |
c2 <- c(c2, "") |
| 1160 | ! |
c3 <- c(c3, sprintf(num.format, x["rmsea.robust"])) |
| 1161 |
} else {
|
|
| 1162 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.robust"])) |
| 1163 | ! |
c3 <- c(c3, "") |
| 1164 |
} |
|
| 1165 |
} |
|
| 1166 | ! |
if ("rmsea.ci.lower.robust" %in% names.x) {
|
| 1167 | ! |
if (is.null(ci.level)) {
|
| 1168 | ! |
c1 <- c(c1, "Confidence interval - lower") |
| 1169 |
} else {
|
|
| 1170 | ! |
c1 <- c(c1, paste0( |
| 1171 | ! |
sprintf("%2d", round(ci.level * 100)),
|
| 1172 | ! |
" Percent confidence interval - lower" |
| 1173 |
)) |
|
| 1174 |
} |
|
| 1175 | ! |
if (scaled.flag) {
|
| 1176 | ! |
c2 <- c(c2, "") |
| 1177 | ! |
c3 <- c(c3, sprintf(num.format, x["rmsea.ci.lower.robust"])) |
| 1178 |
} else {
|
|
| 1179 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.ci.lower.robust"])) |
| 1180 | ! |
c3 <- c(c3, "") |
| 1181 |
} |
|
| 1182 | ||
| 1183 | ! |
if (is.null(ci.level)) {
|
| 1184 | ! |
c1 <- c(c1, "Confidence interval - upper") |
| 1185 |
} else {
|
|
| 1186 | ! |
c1 <- c(c1, paste0( |
| 1187 | ! |
sprintf("%2d", round(ci.level * 100)),
|
| 1188 | ! |
" Percent confidence interval - upper" |
| 1189 |
)) |
|
| 1190 |
} |
|
| 1191 | ! |
if (scaled.flag) {
|
| 1192 | ! |
c2 <- c(c2, "") |
| 1193 | ! |
c3 <- c(c3, sprintf(num.format, x["rmsea.ci.upper.robust"])) |
| 1194 |
} else {
|
|
| 1195 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.ci.upper.robust"])) |
| 1196 | ! |
c3 <- c(c3, "") |
| 1197 |
} |
|
| 1198 |
} |
|
| 1199 | ! |
if ("rmsea.pvalue.robust" %in% names.x) {
|
| 1200 | ! |
if (is.null(rmsea.close.h0)) {
|
| 1201 | ! |
c1 <- c(c1, "P-value H_0: Robust RMSEA <= 0.05") |
| 1202 |
} else {
|
|
| 1203 | ! |
c1 <- c(c1, paste0( |
| 1204 | ! |
"P-value H_0: Robust RMSEA <= ", |
| 1205 | ! |
sprintf("%4.3f", rmsea.close.h0)
|
| 1206 |
)) |
|
| 1207 |
} |
|
| 1208 | ! |
if (scaled.flag) {
|
| 1209 | ! |
c2 <- c(c2, "") |
| 1210 | ! |
c3 <- c(c3, sprintf(num.format, x["rmsea.pvalue.robust"])) |
| 1211 |
} else {
|
|
| 1212 | ! |
c2 <- c(c2, sprintf(num.format, x["rmsea.pvalue.robust"])) |
| 1213 | ! |
c3 <- c(c3, "") |
| 1214 |
} |
|
| 1215 |
} |
|
| 1216 | ! |
if ("rmsea.notclose.pvalue.robust" %in% names.x) {
|
| 1217 | ! |
if (is.null(rmsea.notclose.h0)) {
|
| 1218 | ! |
c1 <- c(c1, "P-value H_0: Robust RMSEA >= 0.080") |
| 1219 |
} else {
|
|
| 1220 | ! |
c1 <- c(c1, paste0( |
| 1221 | ! |
"P-value H_0: Robust RMSEA >= ", |
| 1222 | ! |
sprintf("%4.3f", rmsea.notclose.h0)
|
| 1223 |
)) |
|
| 1224 |
} |
|
| 1225 | ! |
if (scaled.flag) {
|
| 1226 | ! |
c2 <- c(c2, "") |
| 1227 | ! |
c3 <- c( |
| 1228 | ! |
c3, |
| 1229 | ! |
sprintf(num.format, x["rmsea.notclose.pvalue.robust"]) |
| 1230 |
) |
|
| 1231 |
} else {
|
|
| 1232 | ! |
c2 <- c( |
| 1233 | ! |
c2, |
| 1234 | ! |
sprintf(num.format, x["rmsea.notclose.pvalue.robust"]) |
| 1235 |
) |
|
| 1236 | ! |
c3 <- c(c3, "") |
| 1237 |
} |
|
| 1238 |
} |
|
| 1239 | ||
| 1240 |
# format c1/c2/c3 |
|
| 1241 | ! |
c1 <- format(c1, width = 43L) |
| 1242 | ! |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 1243 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 1244 | ||
| 1245 |
# create character matrix |
|
| 1246 | ! |
if (scaled.flag) {
|
| 1247 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 1248 |
} else {
|
|
| 1249 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1250 |
} |
|
| 1251 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1252 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1253 | ||
| 1254 |
|
|
| 1255 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1256 |
} |
|
| 1257 | ||
| 1258 |
# SRMR |
|
| 1259 |
#TODO: add CRMR |
|
| 1260 | ! |
if (any(c("rmr", "srmr") %in% names.x) && !"srmr_within" %in% names.x) {
|
| 1261 | ! |
cat("\nStandardized Root Mean Square Residual:\n\n")
|
| 1262 | ||
| 1263 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 1264 | ||
| 1265 | ! |
if ("rmr" %in% names.x) {
|
| 1266 | ! |
c1 <- c(c1, "RMR") |
| 1267 | ! |
c2 <- c(c2, sprintf(num.format, x["rmr"])) |
| 1268 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["rmr"]), "")) |
| 1269 |
} |
|
| 1270 | ! |
if ("rmr_nomean" %in% names.x) {
|
| 1271 | ! |
c1 <- c(c1, "RMR (No Mean)") |
| 1272 | ! |
c2 <- c(c2, sprintf(num.format, x["rmr_nomean"])) |
| 1273 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1274 | ! |
sprintf(num.format, x["rmr_nomean"]), "" |
| 1275 |
)) |
|
| 1276 |
} |
|
| 1277 | ! |
if ("srmr" %in% names.x) {
|
| 1278 | ! |
c1 <- c(c1, "SRMR") |
| 1279 | ! |
c2 <- c(c2, sprintf(num.format, x["srmr"])) |
| 1280 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["srmr"]), "")) |
| 1281 |
} |
|
| 1282 | ! |
if ("srmr_nomean" %in% names.x) {
|
| 1283 | ! |
c1 <- c(c1, "SRMR (No Mean)") |
| 1284 | ! |
c2 <- c(c2, sprintf(num.format, x["srmr_nomean"])) |
| 1285 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1286 | ! |
sprintf(num.format, x["srmr_nomean"]), "" |
| 1287 |
)) |
|
| 1288 |
} |
|
| 1289 | ||
| 1290 |
# format c1/c2/c3 |
|
| 1291 | ! |
c1 <- format(c1, width = 43L) |
| 1292 | ! |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 1293 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 1294 | ||
| 1295 |
# create character matrix |
|
| 1296 | ! |
if (scaled.flag) {
|
| 1297 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 1298 |
} else {
|
|
| 1299 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1300 |
} |
|
| 1301 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1302 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1303 | ||
| 1304 |
|
|
| 1305 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1306 |
} |
|
| 1307 | ||
| 1308 |
# SRMR -- multilevel |
|
| 1309 |
#TODO: add CRMR? |
|
| 1310 | ! |
if (any(c("srmr_within", "srmr_between") %in% names.x)) {
|
| 1311 | ! |
cat("\nStandardized Root Mean Square Residual (corr metric):\n\n")
|
| 1312 | ||
| 1313 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 1314 | ||
| 1315 | ! |
if ("srmr_within" %in% names.x) {
|
| 1316 | ! |
c1 <- c(c1, "SRMR (within covariance matrix)") |
| 1317 | ! |
c2 <- c(c2, sprintf(num.format, x["srmr_within"])) |
| 1318 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1319 | ! |
sprintf(num.format, x["srmr_within"]), "" |
| 1320 |
)) |
|
| 1321 |
} |
|
| 1322 | ! |
if ("srmr_between" %in% names.x) {
|
| 1323 | ! |
c1 <- c(c1, "SRMR (between covariance matrix)") |
| 1324 | ! |
c2 <- c(c2, sprintf(num.format, x["srmr_between"])) |
| 1325 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1326 | ! |
sprintf(num.format, x["srmr_between"]), "" |
| 1327 |
)) |
|
| 1328 |
} |
|
| 1329 | ||
| 1330 |
# format c1/c2/c3 |
|
| 1331 | ! |
c1 <- format(c1, width = 43L) |
| 1332 | ! |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 1333 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 1334 | ||
| 1335 |
# create character matrix |
|
| 1336 | ! |
if (scaled.flag) {
|
| 1337 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 1338 |
} else {
|
|
| 1339 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1340 |
} |
|
| 1341 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1342 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1343 | ||
| 1344 |
|
|
| 1345 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1346 |
} |
|
| 1347 | ||
| 1348 |
# WRMR |
|
| 1349 | ! |
if ("wrmr" %in% names.x) {
|
| 1350 | ! |
cat("\nWeighted Root Mean Square Residual:\n\n")
|
| 1351 | ||
| 1352 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 1353 | ||
| 1354 | ! |
if ("wrmr" %in% names.x) {
|
| 1355 | ! |
c1 <- c(c1, "WRMR") |
| 1356 | ! |
c2 <- c(c2, sprintf(num.format, x["wrmr"])) |
| 1357 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["wrmr"]), "")) |
| 1358 |
} |
|
| 1359 | ||
| 1360 |
# format c1/c2/c3 |
|
| 1361 | ! |
c1 <- format(c1, width = 43L) |
| 1362 | ! |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 1363 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 1364 | ||
| 1365 |
# create character matrix |
|
| 1366 | ! |
if (scaled.flag) {
|
| 1367 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 1368 |
} else {
|
|
| 1369 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1370 |
} |
|
| 1371 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1372 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1373 | ||
| 1374 |
|
|
| 1375 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1376 |
} |
|
| 1377 | ||
| 1378 |
# Other |
|
| 1379 | ! |
if (any(c("cn_05", "cn_01", "gfi", "agfi", "pgfi", "mfi") %in% names.x)) {
|
| 1380 | ! |
cat("\nOther Fit Indices:\n\n")
|
| 1381 | ||
| 1382 | ! |
c1 <- c2 <- c3 <- character(0L) |
| 1383 | ||
| 1384 | ! |
if ("cn_05" %in% names.x) {
|
| 1385 | ! |
c1 <- c(c1, "Hoelter Critical N (CN) alpha = 0.05") |
| 1386 | ! |
c2 <- c(c2, sprintf(num.format, x["cn_05"])) |
| 1387 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1388 | ! |
sprintf(num.format, x["cn_05"]), "" |
| 1389 |
)) |
|
| 1390 |
} |
|
| 1391 | ! |
if ("cn_01" %in% names.x) {
|
| 1392 | ! |
c1 <- c(c1, "Hoelter Critical N (CN) alpha = 0.01") |
| 1393 | ! |
c2 <- c(c2, sprintf(num.format, x["cn_01"])) |
| 1394 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1395 | ! |
sprintf(num.format, x["cn_01"]), "" |
| 1396 |
)) |
|
| 1397 |
} |
|
| 1398 | ! |
if (any(c("cn_05", "cn_01") %in% names.x)) {
|
| 1399 | ! |
c1 <- c(c1, "") |
| 1400 | ! |
c2 <- c(c2, "") |
| 1401 | ! |
c3 <- c(c3, "") |
| 1402 |
} |
|
| 1403 | ! |
if ("gfi" %in% names.x) {
|
| 1404 | ! |
c1 <- c(c1, "Goodness of Fit Index (GFI)") |
| 1405 | ! |
c2 <- c(c2, sprintf(num.format, x["gfi"])) |
| 1406 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1407 | ! |
sprintf(num.format, x["gfi"]), "" |
| 1408 |
)) |
|
| 1409 |
} |
|
| 1410 | ! |
if ("agfi" %in% names.x) {
|
| 1411 | ! |
c1 <- c(c1, "Adjusted Goodness of Fit Index (AGFI)") |
| 1412 | ! |
c2 <- c(c2, sprintf(num.format, x["agfi"])) |
| 1413 | ! |
c3 <- c(c3, ifelse(scaled.flag, |
| 1414 | ! |
sprintf(num.format, x["agfi"]), "" |
| 1415 |
)) |
|
| 1416 |
} |
|
| 1417 | ! |
if ("pgfi" %in% names.x) {
|
| 1418 | ! |
c1 <- c(c1, "Parsimony Goodness of Fit Index (PGFI)") |
| 1419 | ! |
c2 <- c(c2, sprintf(num.format, x["pgfi"])) |
| 1420 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["pgfi"]), "")) |
| 1421 |
} |
|
| 1422 | ! |
if (any(c("gfi", "agfi", "pgfi") %in% names.x)) {
|
| 1423 | ! |
c1 <- c(c1, "") |
| 1424 | ! |
c2 <- c(c2, "") |
| 1425 | ! |
c3 <- c(c3, "") |
| 1426 |
} |
|
| 1427 | ! |
if ("mfi" %in% names.x) {
|
| 1428 | ! |
c1 <- c(c1, "McDonald Fit Index (MFI)") |
| 1429 | ! |
c2 <- c(c2, sprintf(num.format, x["mfi"])) |
| 1430 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["mfi"]), "")) |
| 1431 |
} |
|
| 1432 | ! |
if ("mfi" %in% names.x) {
|
| 1433 | ! |
c1 <- c(c1, "") |
| 1434 | ! |
c2 <- c(c2, "") |
| 1435 | ! |
c3 <- c(c3, "") |
| 1436 |
} |
|
| 1437 | ! |
if ("ecvi" %in% names.x) {
|
| 1438 | ! |
c1 <- c(c1, "Expected Cross-Validation Index (ECVI)") |
| 1439 | ! |
c2 <- c(c2, sprintf(num.format, x["ecvi"])) |
| 1440 | ! |
c3 <- c(c3, ifelse(scaled.flag, sprintf(num.format, x["ecvi"]), "")) |
| 1441 |
} |
|
| 1442 | ||
| 1443 |
# format c1/c2/c3 |
|
| 1444 | ! |
c1 <- format(c1, width = 43L) |
| 1445 | ! |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 1446 | ! |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 1447 | ||
| 1448 |
# create character matrix |
|
| 1449 | ! |
if (scaled.flag) {
|
| 1450 | ! |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 1451 |
} else {
|
|
| 1452 | ! |
M <- cbind(c1, c2, deparse.level = 0) |
| 1453 |
} |
|
| 1454 | ! |
colnames(M) <- rep("", ncol(M))
|
| 1455 | ! |
rownames(M) <- rep(" ", nrow(M))
|
| 1456 | ||
| 1457 |
|
|
| 1458 | ! |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 1459 |
} |
|
| 1460 | ||
| 1461 | ! |
invisible(x) |
| 1462 |
} |
| 1 |
# build a bare-bones parameter table from a fitted lm object |
|
| 2 |
# |
|
| 3 |
# YR: this function was broken since Mar 3, 2017, but nobody noticed this! |
|
| 4 |
# fixed again Apr 29, 2025. |
|
| 5 | ||
| 6 |
lav_partable_from_lm <- function(object, est = FALSE, label = FALSE, |
|
| 7 |
as.data.frame. = FALSE) {
|
|
| 8 |
# sanity check |
|
| 9 | ! |
if (!inherits(object, "lm")) {
|
| 10 | ! |
lav_msg_stop(gettext("object must be of class lm"))
|
| 11 |
} |
|
| 12 | ||
| 13 | ! |
objectTerms <- terms(object) |
| 14 | ||
| 15 | ! |
responseIndex <- attr(objectTerms, "response") |
| 16 | ! |
varNames <- as.character(attr(objectTerms, "variables"))[-1] |
| 17 | ! |
responseName <- varNames[responseIndex] |
| 18 | ||
| 19 | ! |
predCoef <- coef(object) |
| 20 | ! |
predNames <- names(predCoef) |
| 21 | ||
| 22 | ! |
lhs <- rep(responseName, length(predNames)) |
| 23 | ! |
op <- rep("~", length(predNames))
|
| 24 | ! |
rhs <- predNames |
| 25 | ||
| 26 |
# intercept? |
|
| 27 | ! |
if (attr(objectTerms, "intercept")) {
|
| 28 | ! |
int.idx <- which(rhs == "(Intercept)") |
| 29 | ! |
op[int.idx] <- "~1" |
| 30 | ! |
rhs[int.idx] <- "" |
| 31 |
} |
|
| 32 | ||
| 33 |
# always add residual variance? |
|
| 34 |
# lhs <- c(lhs, responseName) |
|
| 35 |
# op <- c(op, "~~") |
|
| 36 |
# rhs <- c(rhs, responseName) |
|
| 37 | ||
| 38 |
# construct minimal partable |
|
| 39 | ! |
partable <- list(lhs = lhs, op = op, rhs = rhs) |
| 40 | ||
| 41 |
# include 'est' column? |
|
| 42 | ! |
if (est) {
|
| 43 |
# partable$est <- c(as.numeric(predCoef), |
|
| 44 |
# sum(resid(object)^2) / object$df.residual) |
|
| 45 | ! |
partable$est <- as.numeric(predCoef) |
| 46 |
} |
|
| 47 | ||
| 48 |
# include 'label' column? |
|
| 49 | ! |
if (label) {
|
| 50 |
# partable$label <- c(predNames, responseName) |
|
| 51 | ! |
partable$label <- predNames |
| 52 | ||
| 53 |
# convert all ':' to '.' |
|
| 54 | ! |
partable$label <- gsub("[:()]", ".", partable$label)
|
| 55 |
} |
|
| 56 | ||
| 57 |
# convert to data.frame? |
|
| 58 | ! |
if (as.data.frame.) {
|
| 59 | ! |
partable <- as.data.frame(partable, stringsAsFactors = FALSE) |
| 60 |
} |
|
| 61 | ||
| 62 | ! |
partable |
| 63 |
} |
| 1 |
# model objective |
|
| 2 | ||
| 3 |
lav_model_objective <- function(lavmodel = NULL, |
|
| 4 |
GLIST = NULL, |
|
| 5 |
lavsamplestats = NULL, |
|
| 6 |
lavdata = NULL, |
|
| 7 |
lavcache = NULL) {
|
|
| 8 |
# state or final? |
|
| 9 | 2x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST |
| 10 | ||
| 11 |
# shortcut for data.type == "none" or estimator == "none" |
|
| 12 | 6174x |
if (lavmodel@estimator == "none" || length(lavsamplestats@cov) == 0L) {
|
| 13 | 2x |
fx <- as.numeric(NA) |
| 14 | 2x |
attr(fx, "fx.group") <- rep(as.numeric(NA), lavsamplestats@ngroups) |
| 15 | 2x |
return(fx) |
| 16 |
} |
|
| 17 | ||
| 18 | 6172x |
meanstructure <- lavmodel@meanstructure |
| 19 | 6172x |
estimator <- lavmodel@estimator |
| 20 | 6172x |
categorical <- lavmodel@categorical |
| 21 | 6172x |
correlation <- lavmodel@correlation |
| 22 | 6172x |
group.w.free <- lavmodel@group.w.free |
| 23 |
# fixed.x <- lavmodel@fixed.x |
|
| 24 | 6172x |
conditional.x <- lavmodel@conditional.x |
| 25 | 6172x |
num.idx <- lavmodel@num.idx |
| 26 | 6172x |
th.idx <- lavmodel@th.idx |
| 27 | 6172x |
estimator.args <- lavmodel@estimator.args |
| 28 | ||
| 29 |
# do we need WLS.est? |
|
| 30 | 6172x |
if (estimator %in% c("ULS", "WLS", "DWLS", "NTRLS", "DLS")) {
|
| 31 | 3500x |
lavimplied <- lav_model_implied(lavmodel, GLIST = GLIST) |
| 32 |
# check for COV with negative diagonal elements? |
|
| 33 | 3500x |
for (g in 1:lavsamplestats@ngroups) {
|
| 34 | 3500x |
COV <- if (lavmodel@conditional.x) {
|
| 35 | 3098x |
lavimplied$res.cov[[g]] |
| 36 |
} else {
|
|
| 37 | 402x |
lavimplied$cov[[g]] |
| 38 |
} |
|
| 39 | 3500x |
dCOV <- diag(COV) |
| 40 | 3500x |
if (anyNA(COV) || any(dCOV < 0)) {
|
| 41 |
# return NA |
|
| 42 | 6x |
fx <- as.numeric(NA) |
| 43 | 6x |
attr(fx, "fx.group") <- rep(as.numeric(NA), lavsamplestats@ngroups) |
| 44 | 6x |
return(fx) |
| 45 |
} |
|
| 46 |
} |
|
| 47 | 3494x |
WLS.est <- lav_model_wls_est( |
| 48 | 3494x |
lavmodel = lavmodel, GLIST = GLIST, |
| 49 | 3494x |
lavimplied = lavimplied |
| 50 |
) # , |
|
| 51 |
# cov.x = lavsamplestats@cov.x) |
|
| 52 | 3494x |
if (estimator == "NTRLS") {
|
| 53 | ! |
Sigma.hat <- lav_model_sigma( |
| 54 | ! |
lavmodel = lavmodel, GLIST = GLIST, |
| 55 | ! |
extra = TRUE |
| 56 |
) |
|
| 57 | ! |
Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST) |
| 58 |
} |
|
| 59 | 3494x |
if (estimator == "DLS" && estimator.args$dls.GammaNT == "model") {
|
| 60 | ! |
Sigma.hat <- lav_model_sigma( |
| 61 | ! |
lavmodel = lavmodel, GLIST = GLIST, |
| 62 | ! |
extra = FALSE |
| 63 |
) |
|
| 64 | ! |
Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST) |
| 65 |
} |
|
| 66 | ! |
if (lav_debug()) print(WLS.est) |
| 67 | 2672x |
} else if (estimator %in% c("ML", "GLS", "PML", "FML", "REML", "catML") &&
|
| 68 | 2672x |
lavdata@nlevels == 1L) {
|
| 69 |
# compute moments for all groups |
|
| 70 |
# if(conditional.x) {
|
|
| 71 |
# Sigma.hat <- lav_model_cond2joint_sigma(lavmodel = lavmodel, |
|
| 72 |
# GLIST = GLIST, lavsamplestats = lavsamplestats, |
|
| 73 |
# extra = (estimator %in% c("ML", "REML","NTRLS")))
|
|
| 74 |
# } else {
|
|
| 75 | 2504x |
Sigma.hat <- lav_model_sigma( |
| 76 | 2504x |
lavmodel = lavmodel, GLIST = GLIST, |
| 77 | 2504x |
extra = (estimator %in% c( |
| 78 | 2504x |
"ML", "REML", |
| 79 | 2504x |
"NTRLS", "catML" |
| 80 |
)) |
|
| 81 |
) |
|
| 82 |
# } |
|
| 83 | ||
| 84 |
# if (estimator == "REML") {
|
|
| 85 |
# LAMBDA <- lav_model_lambda(lavmodel = lavmodel, GLIST = GLIST) |
|
| 86 |
# } |
|
| 87 | ||
| 88 |
# ridge? |
|
| 89 | 2504x |
if (lavsamplestats@ridge > 0.0) {
|
| 90 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 91 | ! |
diag(Sigma.hat[[g]]) <- diag(Sigma.hat[[g]]) + |
| 92 | ! |
lavsamplestats@ridge |
| 93 |
} |
|
| 94 |
} |
|
| 95 | ! |
if (lav_debug()) print(Sigma.hat) |
| 96 | ||
| 97 | 2504x |
if (meanstructure) {
|
| 98 |
# if(conditional.x) {
|
|
| 99 |
# Mu.hat <- lav_model_cond2joint_mu(lavmodel = lavmodel, GLIST = GLIST, |
|
| 100 |
# lavsamplestats = lavsamplestats) |
|
| 101 |
# } else {
|
|
| 102 | 1427x |
Mu.hat <- lav_model_mu(lavmodel = lavmodel, GLIST = GLIST) |
| 103 |
# } |
|
| 104 |
} |
|
| 105 | ||
| 106 | 2504x |
if (categorical) {
|
| 107 | ! |
TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST) |
| 108 |
} |
|
| 109 | ||
| 110 | 2504x |
if (conditional.x) {
|
| 111 | ! |
PI <- lav_model_pi(lavmodel = lavmodel, GLIST = GLIST) |
| 112 |
} |
|
| 113 | ||
| 114 | 2504x |
if (group.w.free) {
|
| 115 | ! |
GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST) |
| 116 |
} |
|
| 117 | 168x |
} else if (estimator == "MML") {
|
| 118 | ! |
TH <- lav_model_th(lavmodel = lavmodel, GLIST = GLIST) |
| 119 | ! |
THETA <- lav_model_theta(lavmodel = lavmodel, GLIST = GLIST) |
| 120 | ! |
GW <- lav_model_gw(lavmodel = lavmodel, GLIST = GLIST) |
| 121 |
} |
|
| 122 | ||
| 123 | 6166x |
fx <- 0.0 |
| 124 | 6166x |
fx.group <- numeric(lavsamplestats@ngroups) |
| 125 | 6166x |
logl.group <- rep(as.numeric(NA), lavsamplestats@ngroups) |
| 126 | ||
| 127 | 6166x |
for (g in 1:lavsamplestats@ngroups) {
|
| 128 |
# incomplete data and fiml? |
|
| 129 | 6469x |
if (lavsamplestats@missing.flag && estimator != "Bayes") {
|
| 130 | 636x |
if (estimator == "ML" && lavdata@nlevels == 1L) {
|
| 131 |
# FIML |
|
| 132 | 636x |
if (!attr(Sigma.hat[[g]], "po")) {
|
| 133 | ! |
fx <- as.numeric(Inf) |
| 134 | ! |
attr(fx, "fx.group") <- rep(as.numeric(Inf), lavsamplestats@ngroups) |
| 135 | ! |
return(fx) |
| 136 |
} |
|
| 137 |
# check if h1 is defined (eg zero coverage) |
|
| 138 | 636x |
if (is.null(lavsamplestats@missing.h1[[g]]$h1)) {
|
| 139 |
#this.h1 <- lav_mvnorm_missing_loglik_samplestats( |
|
| 140 |
# Yp = lavsamplestats@missing[[g]], |
|
| 141 |
# Mu = Mu.hat[[g]], Sigma = Sigma.hat[[g]], |
|
| 142 |
# log2pi = FALSE, minus.two = TRUE) / lavsamplestats@nobs[[g]] |
|
| 143 |
#this.h1 <- this.h1 * 0.9999999 # avoid perfect fit |
|
| 144 | ! |
this.h1 <- NULL #for now |
| 145 |
} else {
|
|
| 146 | 636x |
this.h1 <- lavsamplestats@missing.h1[[g]]$h1 |
| 147 |
} |
|
| 148 | 636x |
group.fx <- lav_model_objective_fiml( |
| 149 | 636x |
Sigma.hat = Sigma.hat[[g]], |
| 150 | 636x |
Mu.hat = Mu.hat[[g]], |
| 151 | 636x |
Yp = lavsamplestats@missing[[g]], |
| 152 | 636x |
h1 = this.h1, N = lavsamplestats@nobs[[g]] |
| 153 |
) |
|
| 154 | ! |
} else if (estimator == "ML" && lavdata@nlevels > 1L) {
|
| 155 |
# FIML twolevel |
|
| 156 | ! |
group.fx <- lav_model_objective_2l( |
| 157 | ! |
lavmodel = lavmodel, |
| 158 | ! |
GLIST = GLIST, |
| 159 | ! |
Y1 = lavdata@X[[g]], |
| 160 | ! |
Lp = lavdata@Lp[[g]], |
| 161 | ! |
Mp = lavdata@Mp[[g]], |
| 162 | ! |
lavsamplestats = lavsamplestats, |
| 163 | ! |
group = g |
| 164 |
) |
|
| 165 |
} else {
|
|
| 166 | ! |
lav_msg_stop(gettextf( |
| 167 | ! |
"this estimator: `%s' can not be used with incomplete data and |
| 168 | ! |
the missing=\"ml\" option", estimator)) |
| 169 |
} |
|
| 170 | 5833x |
} else if (estimator == "ML" || estimator == "Bayes" || |
| 171 | 5833x |
estimator == "catML") {
|
| 172 |
# complete data |
|
| 173 |
# ML and friends |
|
| 174 | 1923x |
if (lavdata@nlevels > 1L) {
|
| 175 | 336x |
if (estimator %in% c("catML", "Bayes")) {
|
| 176 | ! |
lav_msg_stop(gettext("multilevel data not supported for estimator"),
|
| 177 | ! |
estimator) |
| 178 |
} |
|
| 179 | 336x |
group.fx <- lav_model_objective_2l( |
| 180 | 336x |
lavmodel = lavmodel, |
| 181 | 336x |
GLIST = GLIST, |
| 182 | 336x |
Lp = lavdata@Lp[[g]], |
| 183 | 336x |
Mp = NULL, # complete data |
| 184 | 336x |
lavsamplestats = lavsamplestats, |
| 185 | 336x |
group = g |
| 186 |
) |
|
| 187 | 1587x |
} else if (conditional.x) {
|
| 188 | ! |
group.fx <- lav_model_objective_ml_res( |
| 189 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 190 | ! |
Mu.hat = Mu.hat[[g]], |
| 191 | ! |
PI = PI[[g]], |
| 192 | ! |
res.cov = lavsamplestats@res.cov[[g]], |
| 193 | ! |
res.int = lavsamplestats@res.int[[g]], |
| 194 | ! |
res.slopes = lavsamplestats@res.slopes[[g]], |
| 195 | ! |
res.cov.log.det = lavsamplestats@res.cov.log.det[[g]], |
| 196 | ! |
cov.x = lavsamplestats@cov.x[[g]], |
| 197 | ! |
mean.x = lavsamplestats@mean.x[[g]] |
| 198 |
) |
|
| 199 |
} else {
|
|
| 200 | 1587x |
group.fx <- lav_model_objective_ml( |
| 201 | 1587x |
Sigma.hat = Sigma.hat[[g]], |
| 202 | 1587x |
Mu.hat = Mu.hat[[g]], |
| 203 | 1587x |
data.cov = lavsamplestats@cov[[g]], |
| 204 | 1587x |
data.mean = lavsamplestats@mean[[g]], |
| 205 | 1587x |
data.cov.log.det = lavsamplestats@cov.log.det[[g]], |
| 206 | 1587x |
meanstructure = meanstructure |
| 207 |
) |
|
| 208 |
} |
|
| 209 | ||
| 210 | ||
| 211 |
### GLS #### (0.6-10: not using WLS function any longer) |
|
| 212 | 3910x |
} else if (estimator == "GLS") {
|
| 213 | 416x |
group.fx <- lav_model_objective_gls( |
| 214 | 416x |
Sigma.hat = Sigma.hat[[g]], |
| 215 | 416x |
Mu.hat = Mu.hat[[g]], |
| 216 | 416x |
data.cov = lavsamplestats@cov[[g]], |
| 217 | 416x |
data.cov.inv = lavsamplestats@icov[[g]], |
| 218 | 416x |
data.mean = lavsamplestats@mean[[g]], |
| 219 | 416x |
meanstructure = meanstructure, |
| 220 | 416x |
correlation = correlation |
| 221 |
) |
|
| 222 | 3494x |
} else if (estimator == "WLS" || |
| 223 | 3494x |
estimator == "DLS" || |
| 224 | 3494x |
estimator == "NTRLS") {
|
| 225 |
# full weight matrix |
|
| 226 | 396x |
if (estimator == "WLS") {
|
| 227 | 396x |
WLS.V <- lavsamplestats@WLS.V[[g]] |
| 228 | ! |
} else if (estimator == "DLS") {
|
| 229 | ! |
if (estimator.args$dls.GammaNT == "sample") {
|
| 230 | ! |
WLS.V <- lavsamplestats@WLS.V[[g]] |
| 231 |
} else {
|
|
| 232 | ! |
dls.a <- estimator.args$dls.a |
| 233 | ! |
GammaNT <- lav_samplestats_Gamma_NT( |
| 234 | ! |
COV = Sigma.hat[[g]], |
| 235 | ! |
MEAN = Mu.hat[[g]], |
| 236 | ! |
rescale = FALSE, |
| 237 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 238 | ! |
fixed.x = lavmodel@fixed.x, |
| 239 | ! |
conditional.x = lavmodel@conditional.x, |
| 240 | ! |
meanstructure = lavmodel@meanstructure, |
| 241 | ! |
slopestructure = lavmodel@conditional.x |
| 242 |
) |
|
| 243 | ! |
W.DLS <- (1 - dls.a) * lavsamplestats@NACOV[[g]] + dls.a * GammaNT |
| 244 | ! |
WLS.V <- lav_matrix_symmetric_inverse(W.DLS) |
| 245 |
} |
|
| 246 | ! |
} else if (estimator == "NTRLS") {
|
| 247 |
# WLS.V <- lav_samplestats_Gamma_inverse_NT( |
|
| 248 |
# ICOV = attr(Sigma.hat[[g]],"inv")[,,drop=FALSE], |
|
| 249 |
# COV = Sigma.hat[[g]][,,drop=FALSE], |
|
| 250 |
# MEAN = Mu.hat[[g]], |
|
| 251 |
# x.idx = c(10000,10001), ### FIXME!!!! |
|
| 252 |
# fixed.x = fixed.x, |
|
| 253 |
# conditional.x = conditional.x, |
|
| 254 |
# meanstructure = meanstructure, |
|
| 255 |
# slopestructure = conditional.x) |
|
| 256 | ! |
WLS.V <- lav_mvnorm_information_expected( |
| 257 | ! |
Sigma = Sigma.hat[[g]], |
| 258 | ! |
x.idx = lavsamplestats@x.idx[[g]], |
| 259 | ! |
meanstructure = lavmodel@meanstructure |
| 260 |
) |
|
| 261 |
# DEBUG!!!! |
|
| 262 |
# WLS.V <- 2*WLS.V |
|
| 263 |
} |
|
| 264 | ||
| 265 | 396x |
group.fx <- lav_model_objective_wls( |
| 266 | 396x |
WLS.est = WLS.est[[g]], |
| 267 | 396x |
WLS.obs = lavsamplestats@WLS.obs[[g]], |
| 268 | 396x |
WLS.V = WLS.V |
| 269 |
) |
|
| 270 | 396x |
attr(group.fx, "WLS.est") <- WLS.est[[g]] |
| 271 | 3098x |
} else if (estimator == "DWLS" || estimator == "ULS") {
|
| 272 |
# diagonal weight matrix |
|
| 273 | 3098x |
group.fx <- lav_model_objective_dwls( |
| 274 | 3098x |
WLS.est = WLS.est[[g]], |
| 275 | 3098x |
WLS.obs = lavsamplestats@WLS.obs[[g]], |
| 276 | 3098x |
WLS.VD = lavsamplestats@WLS.VD[[g]] |
| 277 |
) |
|
| 278 | 3098x |
attr(group.fx, "WLS.est") <- WLS.est[[g]] |
| 279 | ! |
} else if (estimator == "PML") {
|
| 280 |
# Pairwise maximum likelihood |
|
| 281 | ! |
if (lavdata@nlevels > 1L) {
|
| 282 |
# group.fx <- lav_model_objective_pml.2L(lavmodel = lavmodel, |
|
| 283 |
# GLIST = GLIST, |
|
| 284 |
# Lp = lavdata@Lp[[g]], |
|
| 285 |
# lavsamplestats = lavsamplestats, |
|
| 286 |
# group = g) |
|
| 287 | ! |
group.fx <- 0 # for now |
| 288 | ! |
attr(group.fx, "logl") <- 0 |
| 289 | ! |
} else if (conditional.x) {
|
| 290 | ! |
group.fx <- lav_model_objective_pml( |
| 291 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 292 | ! |
Mu.hat = Mu.hat[[g]], |
| 293 | ! |
TH = TH[[g]], |
| 294 | ! |
PI = PI[[g]], |
| 295 | ! |
th.idx = th.idx[[g]], |
| 296 | ! |
num.idx = num.idx[[g]], |
| 297 | ! |
X = lavdata@X[[g]], |
| 298 | ! |
eXo = lavdata@eXo[[g]], |
| 299 | ! |
wt = lavdata@weights[[g]], |
| 300 | ! |
lavcache = lavcache[[g]], |
| 301 | ! |
missing = lavdata@missing |
| 302 |
) |
|
| 303 |
} else {
|
|
| 304 | ! |
group.fx <- lav_model_objective_pml( |
| 305 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 306 | ! |
Mu.hat = Mu.hat[[g]], |
| 307 | ! |
TH = TH[[g]], |
| 308 | ! |
PI = NULL, |
| 309 | ! |
th.idx = th.idx[[g]], |
| 310 | ! |
num.idx = num.idx[[g]], |
| 311 | ! |
X = lavdata@X[[g]], |
| 312 | ! |
eXo = NULL, |
| 313 | ! |
wt = lavdata@weights[[g]], |
| 314 | ! |
lavcache = lavcache[[g]], |
| 315 | ! |
missing = lavdata@missing |
| 316 |
) |
|
| 317 |
} |
|
| 318 | ! |
logl.group[g] <- attr(group.fx, "logl") |
| 319 | ! |
} else if (estimator == "FML") {
|
| 320 |
# Full maximum likelihood (underlying multivariate normal) |
|
| 321 | ! |
group.fx <- lav_model_objective_fml( |
| 322 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 323 | ! |
TH = TH[[g]], |
| 324 | ! |
th.idx = th.idx[[g]], |
| 325 | ! |
num.idx = num.idx[[g]], |
| 326 | ! |
X = lavdata@X[[g]], |
| 327 | ! |
lavcache = lavcache[[g]] |
| 328 |
) |
|
| 329 | ! |
} else if (estimator == "MML") {
|
| 330 |
# marginal maximum likelihood |
|
| 331 | ! |
group.fx <- lav_model_objective_mml( |
| 332 | ! |
lavmodel = lavmodel, |
| 333 | ! |
GLIST = GLIST, |
| 334 | ! |
THETA = THETA[[g]], |
| 335 | ! |
TH = TH[[g]], |
| 336 | ! |
group = g, |
| 337 | ! |
lavdata = lavdata, |
| 338 | ! |
sample.mean = lavsamplestats@mean[[g]], |
| 339 | ! |
sample.mean.x = lavsamplestats@mean.x[[g]], |
| 340 | ! |
lavcache = lavcache |
| 341 |
) |
|
| 342 | ! |
} else if (estimator == "REML") {
|
| 343 |
# restricted/residual maximum likelihood |
|
| 344 | ! |
group.fx <- lav_model_objective_reml( |
| 345 | ! |
Sigma.hat = Sigma.hat[[g]], |
| 346 | ! |
Mu.hat = Mu.hat[[g]], |
| 347 | ! |
data.cov = lavsamplestats@cov[[g]], |
| 348 | ! |
data.mean = lavsamplestats@mean[[g]], |
| 349 | ! |
data.cov.log.det = lavsamplestats@cov.log.det[[g]], |
| 350 | ! |
meanstructure = meanstructure, |
| 351 | ! |
group = g, |
| 352 | ! |
lavmodel = lavmodel, |
| 353 | ! |
lavsamplestats = lavsamplestats, |
| 354 | ! |
lavdata = lavdata |
| 355 |
) |
|
| 356 |
} else {
|
|
| 357 | ! |
lav_msg_stop(gettext("unsupported estimator:"), estimator)
|
| 358 |
} |
|
| 359 | ||
| 360 | 6469x |
if (estimator %in% c("ML", "REML", "NTRLS", "catML")) {
|
| 361 | 2559x |
if (lavdata@nlevels == 1L) {
|
| 362 | 2223x |
group.fx <- 0.5 * group.fx ## FIXME |
| 363 |
} |
|
| 364 | 3910x |
} else if (estimator == "PML" || estimator == "FML" || |
| 365 | 3910x |
estimator == "MML") {
|
| 366 |
# do nothing |
|
| 367 | 3910x |
} else if (estimator == "DLS") {
|
| 368 | ! |
if (estimator.args$dls.FtimesNminus1) {
|
| 369 | ! |
group.fx <- 0.5 * (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]] * group.fx |
| 370 |
} else {
|
|
| 371 | ! |
group.fx <- 0.5 * group.fx |
| 372 |
} |
|
| 373 |
} else {
|
|
| 374 | 3910x |
group.fx <- 0.5 * (lavsamplestats@nobs[[g]] - 1) / lavsamplestats@nobs[[g]] * group.fx |
| 375 |
} |
|
| 376 | ||
| 377 | 6469x |
fx.group[g] <- group.fx |
| 378 |
} # g |
|
| 379 | ||
| 380 | 6166x |
if (lavsamplestats@ngroups > 1) {
|
| 381 |
## FIXME: if group.w.free, should we use group.w or nobs??? |
|
| 382 |
## - if we use estimated group.w, gradient changes!!!! |
|
| 383 |
## - but, if group models are misspecified, the group weights |
|
| 384 |
## will be affected too... which is unwanted (I think) |
|
| 385 |
# if(group.w.free) {
|
|
| 386 |
# nobs <- unlist(GW) * lavsamplestats@ntotal |
|
| 387 |
# nobs <- exp(unlist(GW)) |
|
| 388 |
# } else {
|
|
| 389 | 303x |
if (estimator == "PML") {
|
| 390 |
# no weighting needed! (since N_g is part of the logl per group) |
|
| 391 | ! |
fx <- sum(fx.group) |
| 392 | 303x |
} else if(lavdata@nlevels > 1L) {
|
| 393 |
# no weighting needed! (implicit in obj, which is based on loglik) |
|
| 394 | 168x |
fx <- sum(fx.group) |
| 395 |
} else {
|
|
| 396 | 135x |
nobs <- unlist(lavsamplestats@nobs) |
| 397 |
# } |
|
| 398 | 135x |
fx <- weighted.mean(fx.group, w = nobs) |
| 399 |
} |
|
| 400 |
} else { # single group
|
|
| 401 | 5863x |
fx <- fx.group[1] |
| 402 |
} |
|
| 403 | ||
| 404 |
# penalty for group.w + ML |
|
| 405 | 6166x |
if (group.w.free && estimator %in% c( |
| 406 | 6166x |
"ML", "MML", "FML", "PML", |
| 407 | 6166x |
"REML", "catML" |
| 408 |
)) {
|
|
| 409 |
# obs.prop <- unlist(lavsamplestats@group.w) |
|
| 410 |
# est.prop <- unlist(GW) |
|
| 411 |
# if(estimator %in% c("WLS", "GLS", ...) {
|
|
| 412 |
# # X2 style discrepancy measures (aka GLS/WLS!!) |
|
| 413 |
# fx.w <- sum ( (obs.prop-est.prop)^2/est.prop ) |
|
| 414 |
# } else {
|
|
| 415 |
# # G2 style discrepancy measures (aka ML) |
|
| 416 |
# # deriv is here -2 * (obs.prop - est.prop) |
|
| 417 |
# fx.w <- sum(obs.prop * log(obs.prop/est.prop) ) |
|
| 418 |
# } |
|
| 419 | ||
| 420 |
# poisson kernel |
|
| 421 | ! |
obs.freq <- unlist(lavsamplestats@group.w) * lavsamplestats@ntotal |
| 422 | ! |
est.freq <- exp(unlist(GW)) |
| 423 | ! |
fx.w <- -1 * sum(obs.freq * log(est.freq) - est.freq) |
| 424 |
# divide by N (to be consistent with the rest of lavaan) |
|
| 425 | ! |
fx.w <- fx.w / lavsamplestats@ntotal |
| 426 | ||
| 427 | ! |
fx.sat <- sum(obs.freq * log(obs.freq) - obs.freq) |
| 428 | ! |
fx.sat <- fx.sat / lavsamplestats@ntotal |
| 429 | ||
| 430 |
# saturated - poisson |
|
| 431 |
# fx.w <- sum(obs.freq * log(obs.freq/est.freq)) |
|
| 432 |
# does not work without constraints? --> need lagrange multiplier |
|
| 433 | ||
| 434 | ! |
fx <- fx + (fx.w + fx.sat) |
| 435 |
} |
|
| 436 | ||
| 437 | 6166x |
fx.value <- as.numeric(fx) |
| 438 | ||
| 439 | 6166x |
attr(fx, "fx.group") <- fx.group |
| 440 | 6166x |
if (estimator == "PML") {
|
| 441 | ! |
attr(fx, "logl.group") <- logl.group |
| 442 | ! |
attr(fx, "fx.pml") <- fx.value |
| 443 |
} |
|
| 444 | ||
| 445 | 6166x |
fx |
| 446 |
} |
| 1 |
# create (if not already created) an environment to put cached objects in |
|
| 2 |
# this is executed when the package is 'compiled' ! |
|
| 3 |
if (!exists("lavaan_cache_env")) lavaan_cache_env <- new.env(parent = emptyenv())
|
|
| 4 | ||
| 5 |
# tracing possibility in functions defined below, an example of use : |
|
| 6 |
# |
|
| 7 |
# in the function where you want to trace add a line |
|
| 8 |
# lav_trace(x) |
|
| 9 |
# where x is a characterstring you want to show in the trace |
|
| 10 |
# |
|
| 11 |
# thereafter execute a script like this: |
|
| 12 |
# library(lavaan) |
|
| 13 |
# lavaan:::lav_trace_set(TRUE) |
|
| 14 |
# model <- ' |
|
| 15 |
# # latent variable definitions |
|
| 16 |
# ind60 =~ x1 + x2 + x3 |
|
| 17 |
# dem60 =~ y1 + a*y2 + b*y3 + c*y4 |
|
| 18 |
# dem65 =~ y5 + a*y6 + b*y7 + c*y8 |
|
| 19 |
# |
|
| 20 |
# # regressions |
|
| 21 |
# dem60 ~ ind60 |
|
| 22 |
# dem65 ~ ind60 + dem60 |
|
| 23 |
# |
|
| 24 |
# # residual correlations |
|
| 25 |
# y1 ~~ y5 |
|
| 26 |
# y2 ~~ y4 + y6 |
|
| 27 |
# y3 ~~ y7 |
|
| 28 |
# y4 ~~ y8 |
|
| 29 |
# y6 ~~ y8 |
|
| 30 |
# ' |
|
| 31 |
# fit <- sem(model, data = PoliticalDemocracy) |
|
| 32 |
# summary(fit) |
|
| 33 |
# lavaan:::lav_trace_set(FALSE) |
|
| 34 |
# lavaan:::lav_trace_print("PolDem_trace.txt")
|
|
| 35 |
# |
|
| 36 | ||
| 37 |
lav_trace <- function(content = "") {
|
|
| 38 | ! |
ignore.in.stack <- c( |
| 39 | ! |
"eval", "try", "tryCatch", "tryCatchList", "tryCatchOne", "doTryCatch", |
| 40 | ! |
"which", "unique", "as.list", "as.character", "unlist", "lav_trace", |
| 41 | ! |
"source", "withVisible", "tryCatch.W.E", "withCallingHandlers", "do.call" |
| 42 |
) |
|
| 43 | ! |
if (!exists("TRACE", lavaan_cache_env)) {
|
| 44 | ! |
return(invisible(NULL)) |
| 45 |
} |
|
| 46 | ! |
if (!exists("TRACENR", lavaan_cache_env)) assign("TRACENR", 1L, lavaan_cache_env)
|
| 47 | ! |
tracenr <- get("TRACENR", lavaan_cache_env)
|
| 48 | ! |
x <- sub("[() ].*$", "", as.character(sys.calls()))
|
| 49 | ! |
if (length(x) == 0) {
|
| 50 | ! |
return(invisible(NULL)) |
| 51 |
} |
|
| 52 | ! |
a <- paste0("trc", formatC(tracenr, format = "d", width = 5, flag = "0"))
|
| 53 | ! |
x <- x[!(x %in% ignore.in.stack)] |
| 54 | ! |
if (length(x) > 0) {
|
| 55 | ! |
assign(a, list(stack = x, content = content, time = Sys.time()), lavaan_cache_env) |
| 56 | ! |
assign("TRACENR", tracenr + 1L, lavaan_cache_env)
|
| 57 |
} |
|
| 58 | ||
| 59 | ! |
invisible(NULL) |
| 60 |
} |
|
| 61 | ||
| 62 |
lav_trace_set <- function(state = NULL, silent = FALSE) {
|
|
| 63 | ! |
traceon <- exists("TRACE", lavaan_cache_env)
|
| 64 | ! |
msg <- "" |
| 65 | ! |
if (is.null(state)) {
|
| 66 | ! |
rm(list = ls(lavaan_cache_env, pattern = "^trc"), envir = lavaan_cache_env) |
| 67 | ! |
if (exists("TRACENR", lavaan_cache_env)) rm("TRACENR", envir = lavaan_cache_env)
|
| 68 | ! |
msg <- "Traces removed." |
| 69 | ! |
} else if (state) {
|
| 70 | ! |
if (traceon) {
|
| 71 | ! |
msg <- "Trace already active!" |
| 72 |
} else {
|
|
| 73 | ! |
assign("TRACE", TRUE, lavaan_cache_env)
|
| 74 | ! |
msg <- "Trace on." |
| 75 |
} |
|
| 76 |
} else {
|
|
| 77 | ! |
if (traceon) {
|
| 78 | ! |
rm("TRACE", envir = lavaan_cache_env)
|
| 79 | ! |
msg <- "Trace off." |
| 80 |
} else {
|
|
| 81 | ! |
msg <- "Trace not active!" |
| 82 |
} |
|
| 83 |
} |
|
| 84 | ! |
if (!silent) cat(msg, "\n", sep = "") |
| 85 | ||
| 86 | ! |
invisible(NULL) |
| 87 |
} |
|
| 88 | ||
| 89 |
lav_trace_get <- function() {
|
|
| 90 | ! |
traceobjects <- ls(lavaan_cache_env, pattern = "^trc") |
| 91 | ! |
if (length(traceobjects) == 0) {
|
| 92 | ! |
return(list()) |
| 93 |
} |
|
| 94 | ! |
x <- mget(traceobjects, envir = lavaan_cache_env) |
| 95 | ! |
x <- x[order(names(x))] |
| 96 | ||
| 97 | ! |
x |
| 98 |
} |
|
| 99 | ||
| 100 |
lav_trace_print <- function(file = "", clean_after = (file != "")) {
|
|
| 101 | ! |
cat("Trace print on ", format(Sys.time(), format = "%F"), "\n\n", file = file)
|
| 102 | ! |
x <- lav_trace_get() |
| 103 | ! |
for (x1 in x) {
|
| 104 | ! |
cat(format(x1$time, format = "%T"), |
| 105 | ! |
paste(x1$stack, collapse = ">"), ":", x1$content, |
| 106 | ! |
"\n", |
| 107 | ! |
sep = " ", file = file, append = TRUE |
| 108 |
) |
|
| 109 |
} |
|
| 110 | ! |
if (clean_after) lav_trace_set(NULL, TRUE) |
| 111 |
} |
|
| 112 | ||
| 113 |
lav_trace_summary <- function(file = "", clean_after = FALSE) {
|
|
| 114 | ! |
x <- lav_trace_get() |
| 115 | ! |
temp <- new.env(parent = emptyenv()) |
| 116 | ! |
for (x1 in x) {
|
| 117 | ! |
nn <- length(x1$stack) |
| 118 | ! |
mm <- paste(x1$stack[nn], paste(x1$stack[seq_len(nn - 1L)], collapse = ">"), sep = "\t") |
| 119 | ! |
assign(mm, 1L + get0(mm, temp, ifnotfound = 0L), temp) |
| 120 |
} |
|
| 121 | ! |
objects <- sort(ls(temp)) |
| 122 | ! |
for (i in seq_along(objects)) {
|
| 123 | ! |
cat(objects[i], get(objects[i], temp), "\n", file = file, append = TRUE) |
| 124 |
} |
|
| 125 | ! |
if (clean_after) lav_trace_set(NULL, TRUE) |
| 126 |
} |
| 1 |
# generate labels for each parameter |
|
| 2 |
lav_partable_labels <- function(partable, |
|
| 3 |
blocks = c("group", "level"),
|
|
| 4 |
group.equal = "", group.partial = "", |
|
| 5 |
type = "user") {
|
|
| 6 |
# catch empty partable |
|
| 7 | 133x |
if (length(partable$lhs) == 0L) {
|
| 8 | ! |
return(character(0L)) |
| 9 |
} |
|
| 10 | ||
| 11 |
# default labels |
|
| 12 | 133x |
label <- paste(partable$lhs, partable$op, partable$rhs, sep = "") |
| 13 | ||
| 14 |
# handle multiple groups |
|
| 15 | 133x |
if ("group" %in% blocks) {
|
| 16 | 133x |
if (is.character(partable$group)) {
|
| 17 | 10x |
group.label <- unique(partable$group) |
| 18 | 10x |
group.label <- group.label[nchar(group.label) > 0L] |
| 19 | 10x |
ngroups <- length(group.label) |
| 20 |
} else {
|
|
| 21 | 123x |
ngroups <- lav_partable_ngroups(partable) |
| 22 | 123x |
group.label <- 1:ngroups |
| 23 |
} |
|
| 24 | 133x |
if (ngroups > 1L) {
|
| 25 | 17x |
for (g in 2:ngroups) {
|
| 26 | 17x |
label[partable$group == group.label[g]] <- |
| 27 | 17x |
paste(label[partable$group == group.label[g]], |
| 28 | 17x |
".g", g, |
| 29 | 17x |
sep = "" |
| 30 |
) |
|
| 31 |
} |
|
| 32 |
} |
|
| 33 |
} else {
|
|
| 34 | ! |
ngroups <- 1L |
| 35 |
} |
|
| 36 | ||
| 37 |
# cat("DEBUG: label start:\n"); print(label); cat("\n")
|
|
| 38 |
# cat("group.equal = ", group.equal, "\n")
|
|
| 39 |
# cat("group.partial = ", group.partial, "\n")
|
|
| 40 | ||
| 41 |
# use group.equal so that equal sets of parameters get the same label |
|
| 42 | 133x |
if (ngroups > 1L && length(group.equal) > 0L) {
|
| 43 | 8x |
if ("intercepts" %in% group.equal ||
|
| 44 | 8x |
"residuals" %in% group.equal || |
| 45 | 8x |
"residual.covariances" %in% group.equal) {
|
| 46 | ! |
ov.names.nox <- vector("list", length = ngroups)
|
| 47 | ! |
for (g in 1:ngroups) {
|
| 48 | ! |
ov.names.nox[[g]] <- unique(unlist(lav_partable_vnames(partable, "ov.nox", group = g))) |
| 49 |
} |
|
| 50 |
} |
|
| 51 | 8x |
if ("thresholds" %in% group.equal) {
|
| 52 | ! |
ov.names.ord <- vector("list", length = ngroups)
|
| 53 | ! |
for (g in 1:ngroups) {
|
| 54 | ! |
ov.names.ord[[g]] <- unique(unlist(lav_partable_vnames(partable, "ov.ord", group = g))) |
| 55 |
} |
|
| 56 |
} |
|
| 57 | 8x |
if ("means" %in% group.equal ||
|
| 58 | 8x |
"lv.variances" %in% group.equal || |
| 59 | 8x |
"lv.covariances" %in% group.equal) {
|
| 60 | ! |
lv.names <- vector("list", length = ngroups)
|
| 61 | ! |
for (g in 1:ngroups) {
|
| 62 | ! |
lv.names[[g]] <- unique(unlist(lav_partable_vnames(partable, "lv", group = g))) |
| 63 |
} |
|
| 64 |
} |
|
| 65 | ||
| 66 |
# g1.flag: TRUE if included, FALSE if not |
|
| 67 | 8x |
g1.flag <- logical(length(partable$lhs)) |
| 68 | ||
| 69 |
# LOADINGS |
|
| 70 | 8x |
if ("loadings" %in% group.equal) {
|
| 71 | ! |
g1.flag[partable$op == "=~" & partable$group == 1L] <- TRUE |
| 72 |
} |
|
| 73 |
# COMPOSITE LOADINGS (new in 0.6-4) |
|
| 74 | 8x |
if ("composite.loadings" %in% group.equal) {
|
| 75 |
# new setting (0.6-20): <~ |
|
| 76 | ! |
if (any(partable$op == "<~" & partable$group == 1L)) {
|
| 77 | ! |
lav_msg_warn(gettext("composite.loadings are in fact composite weights;
|
| 78 | ! |
better use composite.weights")) |
| 79 | ! |
g1.flag[partable$op == "<~" & partable$group == 1L] <- TRUE |
| 80 |
} else {
|
|
| 81 |
# old school: composites are phantom constructs with zero residual... |
|
| 82 | ! |
lv.f.names <- unique(unlist(lav_partable_vnames(partable, "lv.formative"))) |
| 83 | ! |
g1.flag[partable$op == "~" & |
| 84 | ! |
partable$lhs %in% lv.f.names & |
| 85 | ! |
partable$group == 1L] <- TRUE |
| 86 |
} |
|
| 87 |
} |
|
| 88 |
# COMPOSITE WEIGHTS (new in 0.6-20) # same as 'loadings'... |
|
| 89 | 8x |
if ("composite.weights" %in% group.equal) {
|
| 90 | ! |
g1.flag[partable$op == "<~" & partable$group == 1L] <- TRUE |
| 91 |
} |
|
| 92 |
# INTERCEPTS (OV) |
|
| 93 | 8x |
if ("intercepts" %in% group.equal) {
|
| 94 | ! |
g1.flag[partable$op == "~1" & partable$group == 1L & |
| 95 | ! |
partable$lhs %in% ov.names.nox[[1L]]] <- TRUE |
| 96 |
} |
|
| 97 |
# THRESHOLDS (OV-ORD) |
|
| 98 | 8x |
if ("thresholds" %in% group.equal) {
|
| 99 | ! |
g1.flag[partable$op == "|" & partable$group == 1L & |
| 100 | ! |
partable$lhs %in% ov.names.ord[[1L]]] <- TRUE |
| 101 |
} |
|
| 102 |
# MEANS (LV) |
|
| 103 | 8x |
if ("means" %in% group.equal) {
|
| 104 | ! |
g1.flag[partable$op == "~1" & partable$group == 1L & |
| 105 | ! |
partable$lhs %in% lv.names[[1L]]] <- TRUE |
| 106 |
} |
|
| 107 |
# REGRESSIONS |
|
| 108 | 8x |
if ("regressions" %in% group.equal) {
|
| 109 | ! |
g1.flag[partable$op == "~" & partable$group == 1L] <- TRUE |
| 110 |
} |
|
| 111 |
# RESIDUAL variances (FIXME: OV ONLY!) |
|
| 112 | 8x |
if ("residuals" %in% group.equal) {
|
| 113 | ! |
g1.flag[partable$op == "~~" & partable$group == 1L & |
| 114 | ! |
partable$lhs %in% ov.names.nox[[1L]] & |
| 115 | ! |
partable$lhs == partable$rhs] <- TRUE |
| 116 |
} |
|
| 117 |
# RESIDUAL covariances (FIXME: OV ONLY!) |
|
| 118 | 8x |
if ("residual.covariances" %in% group.equal) {
|
| 119 | ! |
g1.flag[partable$op == "~~" & partable$group == 1L & |
| 120 | ! |
partable$lhs %in% ov.names.nox[[1L]] & |
| 121 | ! |
partable$lhs != partable$rhs] <- TRUE |
| 122 |
} |
|
| 123 |
# LV VARIANCES |
|
| 124 | 8x |
if ("lv.variances" %in% group.equal) {
|
| 125 | ! |
g1.flag[partable$op == "~~" & partable$group == 1L & |
| 126 | ! |
partable$lhs %in% lv.names[[1L]] & |
| 127 | ! |
partable$lhs == partable$rhs] <- TRUE |
| 128 |
} |
|
| 129 |
# LV COVARIANCES |
|
| 130 | 8x |
if ("lv.covariances" %in% group.equal) {
|
| 131 | ! |
g1.flag[partable$op == "~~" & partable$group == 1L & |
| 132 | ! |
partable$lhs %in% lv.names[[1L]] & |
| 133 | ! |
partable$lhs != partable$rhs] <- TRUE |
| 134 |
} |
|
| 135 | ||
| 136 |
# if group.partial, set corresponding flag to FALSE |
|
| 137 | 8x |
if (length(group.partial) > 0L) {
|
| 138 | 8x |
g1.flag[label %in% group.partial & |
| 139 | 8x |
partable$group == 1L] <- FALSE |
| 140 |
} |
|
| 141 | ||
| 142 |
# for each (constrained) parameter in 'group 1', find a similar one |
|
| 143 |
# in the other groups (we assume here that the models need |
|
| 144 |
# NOT be the same across groups! |
|
| 145 | 8x |
g1.idx <- which(g1.flag) |
| 146 | 8x |
for (i in 1:length(g1.idx)) {
|
| 147 | 16x |
ref.idx <- g1.idx[i] |
| 148 | 16x |
idx <- which(partable$lhs == partable$lhs[ref.idx] & |
| 149 | 16x |
partable$op == partable$op[ref.idx] & |
| 150 | 16x |
partable$rhs == partable$rhs[ref.idx] & |
| 151 | 16x |
partable$group > 1L) |
| 152 | 16x |
label[idx] <- label[ref.idx] |
| 153 |
} |
|
| 154 |
} |
|
| 155 | ||
| 156 |
# cat("DEBUG: g1.idx = ", g1.idx, "\n")
|
|
| 157 |
# cat("DEBUG: label after group.equal:\n"); print(label); cat("\n")
|
|
| 158 | ||
| 159 |
# handle other block identifier (not 'group') |
|
| 160 | 133x |
for (block in blocks) {
|
| 161 | 221x |
if (block == "group") {
|
| 162 | 133x |
next |
| 163 | 88x |
} else if (block == "level" && !is.null(partable[[block]])) {
|
| 164 |
# all but first level |
|
| 165 | 10x |
lev_vals <- lav_partable_level_values(partable) |
| 166 | 10x |
idx <- which(partable[[block]] != lev_vals[1]) |
| 167 | 10x |
label[idx] <- paste(label[idx], ".", "l", |
| 168 | 10x |
partable[[block]][idx], |
| 169 | 10x |
sep = "" |
| 170 |
) |
|
| 171 | 78x |
} else if (!is.null(partable[[block]])) {
|
| 172 | ! |
label <- paste(label, ".", block, partable[[block]], sep = "") |
| 173 |
} |
|
| 174 |
} |
|
| 175 | ||
| 176 |
# user-specified labels -- override everything!! |
|
| 177 | 133x |
user.idx <- which(nchar(partable$label) > 0L) |
| 178 | 133x |
label[user.idx] <- partable$label[user.idx] |
| 179 | ||
| 180 |
# cat("DEBUG: user.idx = ", user.idx, "\n")
|
|
| 181 |
# cat("DEBUG: label after user.idx:\n"); print(label); cat("\n")
|
|
| 182 | ||
| 183 |
# which labels do we need? |
|
| 184 | 133x |
if (type == "user") {
|
| 185 | 51x |
idx <- 1:length(label) |
| 186 | 82x |
} else if (type == "free") {
|
| 187 |
# idx <- which(partable$free > 0L & !duplicated(partable$free)) |
|
| 188 | 82x |
idx <- which(partable$free > 0L) |
| 189 |
# } else if(type == "unco") {
|
|
| 190 |
# idx <- which(partable$unco > 0L & !duplicated(partable$unco)) |
|
| 191 |
} else {
|
|
| 192 | ! |
lav_msg_stop(gettext("argument `type' must be one of free or user"))
|
| 193 |
} |
|
| 194 | ||
| 195 | 133x |
label[idx] |
| 196 |
} |
| 1 |
# Browne's residual test statistic |
|
| 2 |
# see Browne (1984) eq 2.20a |
|
| 3 | ||
| 4 |
# T_B = (N-1) * t(RES) %*% Delta.c %*% |
|
| 5 |
# solve(t(Delta.c) %*% Gamma %*% Delta.c) %*% |
|
| 6 |
# t(Delta.c) %*% RES |
|
| 7 |
# |
|
| 8 |
# = (N-1) * t(RES) %*% (Gamma.inv - |
|
| 9 |
# Gamma.inv %*% Delta %*% |
|
| 10 |
# solve(t(Delta) %*% Gamma.inv %*% Delta) %*% |
|
| 11 |
# t(Delta) %*% Gamma.inv) %*% RES |
|
| 12 | ||
| 13 |
# Note: if Gamma == solve(Weight matrix), then: |
|
| 14 |
# t(Delta) %*% solve(Gamma) %*% RES == 0-vector! |
|
| 15 |
# |
|
| 16 |
# Therefore: |
|
| 17 |
# - if estimator = "WLS", X2 == Browne's residual ADF statistic |
|
| 18 |
# - if estimator = "GLS", X2 == Browne's residual NT statistic |
|
| 19 |
# |
|
| 20 |
# - if estimator = "NTRLS", X2 == Browne's residual NT statistic (model-based) |
|
| 21 |
# also known as the RLS test statistic |
|
| 22 |
# ... except in multigroup + equality constraints, where |
|
| 23 |
# t(Delta) %*% solve(Gamma) %*% RES not zero everywhere!? |
|
| 24 | ||
| 25 |
# YR 26 July 2022: add alternative slots, if lavobject = NULL |
|
| 26 |
# YR 22 Jan 2023: allow for model-based 'structured' Sigma |
|
| 27 | ||
| 28 |
# TODo: - allow for non-linear equality constraints |
|
| 29 |
# (see Browne, 1982, eq 1.7.19; although we may face singular matrices) |
|
| 30 | ||
| 31 |
lav_test_browne <- function(lavobject = NULL, |
|
| 32 |
# or |
|
| 33 |
lavdata = NULL, |
|
| 34 |
lavsamplestats = NULL, # WLS.obs, NACOV |
|
| 35 |
lavmodel = NULL, |
|
| 36 |
lavpartable = NULL, # DF |
|
| 37 |
lavoptions = NULL, |
|
| 38 |
lavh1 = NULL, |
|
| 39 |
lavimplied = NULL, |
|
| 40 |
# further options: |
|
| 41 |
n.minus.one = "default", |
|
| 42 |
ADF = TRUE, |
|
| 43 |
model.based = FALSE) {
|
|
| 44 | ! |
if (!is.null(lavobject)) {
|
| 45 |
# check input |
|
| 46 | ! |
if (!inherits(lavobject, "lavaan")) {
|
| 47 | ! |
lav_msg_stop(gettext("object is not a lavaan object."))
|
| 48 |
} |
|
| 49 | ||
| 50 |
# slots |
|
| 51 | ! |
lavdata <- lavobject@Data |
| 52 | ! |
lavsamplestats <- lavobject@SampleStats |
| 53 | ! |
lavmodel <- lavobject@Model |
| 54 | ! |
lavpartable <- lavobject@ParTable |
| 55 | ! |
lavoptions <- lavobject@Options |
| 56 | ! |
lavh1 <- lavobject@h1 |
| 57 | ! |
lavimplied <- lavobject@implied |
| 58 |
} |
|
| 59 | ||
| 60 | ! |
if (!ADF && lavmodel@categorical) {
|
| 61 | ! |
lav_msg_stop(gettext("normal theory version not available in the categorical
|
| 62 | ! |
setting.")) |
| 63 |
} |
|
| 64 | ! |
if (lavdata@missing != "listwise" && !model.based) {
|
| 65 | ! |
lav_msg_stop(gettext("Browne's test is not available when data is missing"))
|
| 66 |
} |
|
| 67 | ! |
if (lavdata@nlevels > 1L) {
|
| 68 | ! |
lav_msg_stop(gettext("Browne's test is not available when data is
|
| 69 | ! |
multilevel.")) |
| 70 |
} |
|
| 71 | ! |
if (length(lavmodel@ceq.nonlinear.idx) > 0L) {
|
| 72 | ! |
lav_msg_stop(gettext("Browne's test is not available (yet) when nonlinear
|
| 73 | ! |
equality constraints are involved.")) |
| 74 |
} |
|
| 75 | ||
| 76 | ! |
if (!is.logical(n.minus.one)) {
|
| 77 | ! |
if (lavoptions$estimator == "ML" && |
| 78 | ! |
lavoptions$likelihood == "normal") {
|
| 79 | ! |
n.minus.one <- FALSE |
| 80 |
} else {
|
|
| 81 | ! |
n.minus.one <- TRUE |
| 82 |
} |
|
| 83 |
} |
|
| 84 | ||
| 85 |
# ingredients |
|
| 86 | ! |
Delta <- lav_model_delta(lavmodel) |
| 87 | ! |
if (ADF) {
|
| 88 |
# ADF version |
|
| 89 | ! |
if (!is.null(lavsamplestats@NACOV[[1]])) {
|
| 90 | ! |
Gamma <- lavsamplestats@NACOV |
| 91 |
} else {
|
|
| 92 | ! |
if (!is.null(lavobject)) {
|
| 93 | ! |
if (lavobject@Data@data.type != "full") {
|
| 94 | ! |
lav_msg_stop(gettext("ADF version not available without full data or
|
| 95 | ! |
user-provided Gamma/NACOV matrix")) |
| 96 |
} |
|
| 97 | ! |
Gamma <- lav_object_gamma(lavobject, |
| 98 | ! |
ADF = TRUE, |
| 99 | ! |
model.based = model.based |
| 100 |
) |
|
| 101 |
} else {
|
|
| 102 | ! |
if (lavdata@data.type != "full") {
|
| 103 | ! |
lav_msg_stop(gettext("ADF version not available without full data or
|
| 104 | ! |
user-provided Gamma/NACOV matrix")) |
| 105 |
} |
|
| 106 | ! |
Gamma <- lav_object_gamma( |
| 107 | ! |
lavobject = NULL, |
| 108 | ! |
lavdata = lavdata, |
| 109 | ! |
lavoptions = lavoptions, |
| 110 | ! |
lavsamplestats = lavsamplestats, |
| 111 | ! |
lavh1 = lavh1, |
| 112 | ! |
lavimplied = lavimplied, |
| 113 | ! |
ADF = TRUE, |
| 114 | ! |
model.based = model.based |
| 115 |
) |
|
| 116 |
} |
|
| 117 |
} |
|
| 118 |
} else {
|
|
| 119 |
# NT version |
|
| 120 | ! |
if (!is.null(lavobject)) {
|
| 121 | ! |
Gamma <- lav_object_gamma(lavobject, |
| 122 | ! |
ADF = FALSE, |
| 123 | ! |
model.based = model.based |
| 124 |
) |
|
| 125 |
} else {
|
|
| 126 | ! |
Gamma <- lav_object_gamma( |
| 127 | ! |
lavobject = NULL, |
| 128 | ! |
lavdata = lavdata, |
| 129 | ! |
lavoptions = lavoptions, |
| 130 | ! |
lavsamplestats = lavsamplestats, |
| 131 | ! |
lavh1 = lavh1, |
| 132 | ! |
lavimplied = lavimplied, |
| 133 | ! |
ADF = FALSE, |
| 134 | ! |
model.based = model.based |
| 135 |
) |
|
| 136 |
} |
|
| 137 |
} |
|
| 138 | ! |
WLS.obs <- lavsamplestats@WLS.obs |
| 139 | ! |
WLS.est <- lav_model_wls_est(lavmodel) |
| 140 | ! |
nobs <- lavsamplestats@nobs |
| 141 | ! |
ntotal <- lavsamplestats@ntotal |
| 142 | ||
| 143 |
# linear equality constraints? |
|
| 144 | ! |
lineq.flag <- FALSE |
| 145 | ! |
if (lavmodel@eq.constraints) {
|
| 146 | ! |
lineq.flag <- TRUE |
| 147 | ! |
} else if (lavmodel@ceq.simple.only) {
|
| 148 | ! |
lineq.flag <- TRUE |
| 149 |
} |
|
| 150 | ||
| 151 |
# compute T.B per group |
|
| 152 | ! |
ngroups <- length(WLS.obs) |
| 153 | ! |
stat.group <- numeric(ngroups) |
| 154 | ||
| 155 |
# 1. standard setting: no equality constraints |
|
| 156 | ! |
if (!lineq.flag) {
|
| 157 | ! |
for (g in seq_len(ngroups)) {
|
| 158 | ! |
RES <- WLS.obs[[g]] - WLS.est[[g]] |
| 159 | ! |
Delta.g <- Delta[[g]] |
| 160 | ! |
Delta.c <- lav_matrix_orthogonal_complement(Delta.g) |
| 161 | ! |
tDGD <- crossprod(Delta.c, Gamma[[g]]) %*% Delta.c |
| 162 |
# if fixed.x = TRUE, Gamma[[g]] may contain zero col/rows |
|
| 163 | ! |
tDGD.inv <- lav_matrix_symmetric_inverse(tDGD) |
| 164 | ! |
if (n.minus.one) {
|
| 165 | ! |
Ng <- nobs[[g]] - 1L |
| 166 |
} else {
|
|
| 167 | ! |
Ng <- nobs[[g]] |
| 168 |
} |
|
| 169 | ! |
tResDelta.c <- crossprod(RES, Delta.c) |
| 170 | ! |
stat.group[g] <- |
| 171 | ! |
Ng * drop(tResDelta.c %*% tDGD.inv %*% t(tResDelta.c)) |
| 172 |
} |
|
| 173 | ! |
STAT <- sum(stat.group) |
| 174 | ||
| 175 |
# 2. linear equality constraint |
|
| 176 | ! |
} else if (lineq.flag) {
|
| 177 | ! |
RES.all <- do.call("c", WLS.obs) - do.call("c", WLS.est)
|
| 178 | ! |
Delta.all <- do.call("rbind", Delta)
|
| 179 | ! |
if (lavmodel@eq.constraints) {
|
| 180 | ! |
Delta.g <- Delta.all %*% lavmodel@eq.constraints.K |
| 181 | ! |
} else if (lavmodel@ceq.simple.only) {
|
| 182 | ! |
Delta.g <- Delta.all %*% lavmodel@ceq.simple.K |
| 183 |
} |
|
| 184 | ! |
Gamma.inv.weighted <- vector("list", ngroups)
|
| 185 | ! |
for (g in seq_len(ngroups)) {
|
| 186 | ! |
if (n.minus.one) {
|
| 187 | ! |
Ng <- nobs[[g]] - 1L |
| 188 |
} else {
|
|
| 189 | ! |
Ng <- nobs[[g]] |
| 190 |
} |
|
| 191 | ! |
Gamma.inv.temp <- try(solve(Gamma[[g]]), silent = TRUE) |
| 192 | ! |
if (inherits(Gamma.inv.temp, "try-error")) {
|
| 193 |
# TDJ: This will happen whenever an (otherwise) unrestricted |
|
| 194 |
# covariance matrix has a structure to it, such as equal |
|
| 195 |
# variances (and certain covariances) for 2 members of an |
|
| 196 |
# indistinguishable dyad (represented as 2 columns). In |
|
| 197 |
# such cases, their (N)ACOV elements are also identical. |
|
| 198 | ! |
Gamma.inv.temp <- MASS::ginv(Gamma[[g]]) |
| 199 |
} |
|
| 200 | ! |
Gamma.inv.weighted[[g]] <- Gamma.inv.temp * Ng / ntotal |
| 201 |
} |
|
| 202 | ! |
GI <- lav_matrix_bdiag(Gamma.inv.weighted) |
| 203 | ! |
tDGiD <- t(Delta.g) %*% GI %*% Delta.g |
| 204 | ! |
tDGiD.inv <- MASS::ginv(tDGiD) # GI may be rank-deficient |
| 205 | ! |
q1 <- drop(t(RES.all) %*% GI %*% RES.all) |
| 206 | ! |
q2 <- drop(t(RES.all) %*% |
| 207 | ! |
GI %*% Delta.g %*% tDGiD.inv %*% t(Delta.g) %*% GI %*% |
| 208 | ! |
RES.all) |
| 209 | ! |
STAT <- ntotal * (q1 - q2) |
| 210 | ! |
stat.group <- STAT * unlist(nobs) / ntotal # proxy only |
| 211 | ||
| 212 |
# 3. nonlinear equality constraints |
|
| 213 |
} else {
|
|
| 214 |
# TODO |
|
| 215 |
} |
|
| 216 | ||
| 217 | ||
| 218 |
# DF |
|
| 219 | ! |
if (!is.null(lavobject)) {
|
| 220 | ! |
DF <- lavobject@test[[1]]$df |
| 221 |
} else {
|
|
| 222 |
# same approach as in lav_test.R |
|
| 223 | ! |
df <- lav_partable_df(lavpartable) |
| 224 | ! |
if (nrow(lavmodel@con.jac) > 0L) {
|
| 225 | ! |
ceq.idx <- attr(lavmodel@con.jac, "ceq.idx") |
| 226 | ! |
if (length(ceq.idx) > 0L) {
|
| 227 | ! |
neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank |
| 228 | ! |
df <- df + neq |
| 229 |
} |
|
| 230 | ! |
} else if (lavmodel@ceq.simple.only) {
|
| 231 |
# needed?? |
|
| 232 | ! |
ndat <- lav_partable_ndat(lavpartable) |
| 233 | ! |
npar <- max(lavpartable$free) |
| 234 | ! |
df <- ndat - npar |
| 235 |
} |
|
| 236 | ! |
DF <- df |
| 237 |
} |
|
| 238 | ||
| 239 | ! |
if (ADF) {
|
| 240 | ! |
if (model.based) {
|
| 241 |
# using model-based Gamma |
|
| 242 | ! |
NAME <- "browne.residual.adf.model" |
| 243 | ! |
LABEL <- "Browne's residual (ADF model-based) test" |
| 244 |
} else {
|
|
| 245 |
# regular one |
|
| 246 | ! |
NAME <- "browne.residual.adf" |
| 247 | ! |
LABEL <- "Browne's residual-based (ADF) test" |
| 248 |
} |
|
| 249 |
} else {
|
|
| 250 | ! |
if (model.based) {
|
| 251 |
# using model-implied Sigma (instead of S) |
|
| 252 |
# also called the 'reweighted least-squares (RLS)' version |
|
| 253 | ! |
NAME <- "browne.residual.nt.model" |
| 254 | ! |
LABEL <- "Browne's residual (NT model-based) test" |
| 255 |
} else {
|
|
| 256 |
# regular one |
|
| 257 | ! |
NAME <- "browne.residual.nt" |
| 258 | ! |
LABEL <- "Browne's residual-based (NT) test" |
| 259 |
} |
|
| 260 |
} |
|
| 261 | ! |
out <- list( |
| 262 | ! |
test = NAME, |
| 263 | ! |
stat = STAT, |
| 264 | ! |
stat.group = stat.group, |
| 265 | ! |
df = DF, |
| 266 | ! |
refdistr = "chisq", |
| 267 | ! |
pvalue = 1 - pchisq(STAT, DF), |
| 268 | ! |
label = LABEL |
| 269 |
) |
|
| 270 | ! |
out |
| 271 |
} |
| 1 |
# tools for the multivariate Bernoulli distribution |
|
| 2 |
# |
|
| 3 |
# see: |
|
| 4 |
# |
|
| 5 |
# Maydeu-Olivares & Joe (2005). Limited- and Full-Information Estimation and |
|
| 6 |
# Goodness-of-Fit Testing in 2^n Contingency Tables: A Unified Framework. |
|
| 7 |
# Journal of the American Statistical Association, 100, 1009--1020. |
|
| 8 | ||
| 9 |
# YR. 15 April 2014 -- first version |
|
| 10 | ||
| 11 |
# compute higher-order joint moments (Teugels 1991) |
|
| 12 |
# PROP must be an array, with dim = rep(2L, nitems) |
|
| 13 |
lav_tables_mvb_getPiDot <- function(PROP, order. = nitems) {
|
|
| 14 |
# number of items/dimensions |
|
| 15 | ! |
nitems <- length(dim(PROP)) |
| 16 | ||
| 17 |
# compute 'pi dot' up to order = order. |
|
| 18 | ! |
pidot <- unlist( |
| 19 | ! |
lapply(1:order., function(Order) {
|
| 20 | ! |
IDX <- utils::combn(1:nitems, Order) |
| 21 | ! |
tmp <- apply(IDX, 2L, function(idx) {
|
| 22 | ! |
as.numeric(apply(PROP, idx, sum))[1L] |
| 23 |
}) |
|
| 24 | ! |
tmp |
| 25 |
}) |
|
| 26 |
) |
|
| 27 | ||
| 28 | ! |
pidot |
| 29 |
} |
|
| 30 | ||
| 31 |
# compute 'T' matrix, so that pidot = T %*% prop |
|
| 32 |
lav_tables_mvb_getT <- function(nitems = 3L, order. = nitems, rbind. = FALSE) {
|
|
| 33 |
# index matrix |
|
| 34 | ! |
INDEX <- array(1:(2^nitems), dim = rep(2L, nitems)) |
| 35 | ||
| 36 | ! |
T.r <- lapply(1:order., function(Order) {
|
| 37 | ! |
IDX <- utils::combn(1:nitems, Order) |
| 38 | ! |
TT <- matrix(0L, ncol(IDX), 2^nitems) |
| 39 | ! |
TT <- do.call( |
| 40 | ! |
"rbind", |
| 41 | ! |
lapply(1:ncol(IDX), function(i) {
|
| 42 | ! |
TRue <- as.list(rep(TRUE, nitems)) |
| 43 | ! |
TRue[IDX[, i]] <- 1L |
| 44 | ! |
ARGS <- c(list(INDEX), TRue) |
| 45 | ! |
T1 <- integer(2^nitems) |
| 46 | ! |
T1[as.vector(do.call("[", ARGS))] <- 1L
|
| 47 | ! |
T1 |
| 48 |
}) |
|
| 49 |
) |
|
| 50 | ! |
TT |
| 51 |
}) |
|
| 52 | ||
| 53 | ! |
if (rbind.) {
|
| 54 | ! |
T.r <- do.call("rbind", T.r)
|
| 55 |
} |
|
| 56 | ||
| 57 | ! |
T.r |
| 58 |
} |
|
| 59 | ||
| 60 |
# simple test function to check that pidot = T %*% prop |
|
| 61 |
lav_tables_mvb_test <- function(nitems = 3L) {
|
|
| 62 | ! |
freq <- sample(5:50, 2^nitems, replace = TRUE) |
| 63 | ! |
prop <- freq / sum(freq) |
| 64 | ! |
TABLE <- array(freq, dim = rep(2, nitems)) |
| 65 | ! |
PROP <- array(prop, dim = rep(2, nitems)) |
| 66 |
# note: freq is always as.numeric(TABLE) |
|
| 67 |
# prop is always as.numeric(PROP) |
|
| 68 | ||
| 69 | ! |
pidot <- lav_tables_mvb_getPiDot(PROP) |
| 70 | ! |
T.r <- lav_tables_mvb_getT(nitems = nitems, order. = nitems, rbind. = TRUE) |
| 71 | ||
| 72 | ! |
if (lav_verbose()) {
|
| 73 | ! |
out <- cbind(as.numeric(T.r %*% prop), pidot) |
| 74 | ! |
colnames(out) <- c("T * prop", "pidot")
|
| 75 | ! |
print(out) |
| 76 |
} |
|
| 77 | ||
| 78 | ! |
all.equal(pidot, as.numeric(T.r %*% prop)) |
| 79 |
} |
|
| 80 | ||
| 81 |
# L_r test of Maydeu-Olivares & Joe (2005) eq (4) |
|
| 82 |
lav_tables_mvb_Lr <- function(nitems = 0L, |
|
| 83 |
obs.prop = NULL, est.prop = NULL, nobs = 0L, |
|
| 84 |
order. = 2L) {
|
|
| 85 |
# recreate tables |
|
| 86 | ! |
obs.PROP <- array(obs.prop, dim = rep(2L, nitems)) |
| 87 | ! |
est.PROP <- array(est.prop, dim = rep(2L, nitems)) |
| 88 | ||
| 89 |
# compute {obs,est}.prop.dot
|
|
| 90 | ! |
obs.prop.dot <- lav_tables_mvb_getPiDot(obs.PROP, order. = order.) |
| 91 | ! |
est.prop.dot <- lav_tables_mvb_getPiDot(est.PROP, order. = order.) |
| 92 | ||
| 93 |
# compute T.r |
|
| 94 | ! |
T.r <- lav_tables_mvb_getT(nitems = nitems, order. = order., rbind. = TRUE) |
| 95 | ||
| 96 |
# compute GAMMA based on est.prop |
|
| 97 | ! |
GAMMA <- diag(est.prop) - tcrossprod(est.prop) |
| 98 | ||
| 99 |
# compute XI |
|
| 100 | ! |
XI <- T.r %*% GAMMA %*% t(T.r) |
| 101 | ||
| 102 |
# compute Lr |
|
| 103 | ! |
diff.dot <- obs.prop.dot - est.prop.dot |
| 104 | ! |
Lr <- as.numeric(nobs * t(diff.dot) %*% solve(XI) %*% diff.dot) |
| 105 | ! |
df <- 2^nitems - 1L |
| 106 | ! |
p.value <- 1 - pchisq(Lr, df = df) |
| 107 | ||
| 108 |
# return list |
|
| 109 | ! |
list(Lr = Lr, df = df, p.value = p.value) |
| 110 |
} |
| 1 |
lav_lavaan_step17_lavaan <- function(lavmc = NULL, |
|
| 2 |
timing = NULL, |
|
| 3 |
lavoptions = NULL, |
|
| 4 |
lavpartable = NULL, |
|
| 5 |
lavdata = NULL, |
|
| 6 |
lavsamplestats = NULL, |
|
| 7 |
lavmodel = NULL, |
|
| 8 |
lavcache = NULL, |
|
| 9 |
lavfit = NULL, |
|
| 10 |
lavboot = NULL, |
|
| 11 |
lavoptim = NULL, |
|
| 12 |
lavimplied = NULL, |
|
| 13 |
lavloglik = NULL, |
|
| 14 |
lavvcov = NULL, |
|
| 15 |
lavtest = NULL, |
|
| 16 |
lavh1 = NULL, |
|
| 17 |
lavbaseline = NULL, |
|
| 18 |
laveqs = NULL, |
|
| 19 |
start.time0 = NULL) {
|
|
| 20 |
# # # # # # # # # # |
|
| 21 |
# # 17. lavaan # # |
|
| 22 |
# # # # # # # # # # |
|
| 23 | ||
| 24 |
# stop timer |
|
| 25 |
# create lavaan object |
|
| 26 |
# if lavmodel@nefa > 0 |
|
| 27 |
# compute standardizedSolution and store in ParTable slot in lavaan object |
|
| 28 |
# if post-checking demanded and converged, execute |
|
| 29 |
# lavInspect(lavaan, "post.check") |
|
| 30 |
# |
|
| 31 | 140x |
timing$total <- (proc.time()[3] - start.time0) |
| 32 | 140x |
timing$start.time <- NULL |
| 33 | 140x |
lavpta <- lav_partable_attributes(lavpartable) |
| 34 | 140x |
lavpartable <- lav_partable_remove_cache(lavpartable) |
| 35 | 140x |
lavaan <- new("lavaan", # type_of_slot - where created or modified ?
|
| 36 |
# ------------ ------------------------- - |
|
| 37 | 140x |
version = packageDescription("lavaan", fields = "Version"),
|
| 38 | 140x |
call = lavmc, # match.call - ldw_adapt_match_call |
| 39 | 140x |
timing = timing, # list - ldw_add_timing |
| 40 | 140x |
Options = lavoptions, # list - options (2) / data (3) / partable (4) |
| 41 | 140x |
ParTable = lavpartable, |
| 42 |
# list - partable/bounds/start/model/estoptim/vcovboot/rotation |
|
| 43 | 140x |
pta = lavpta, # list - lav_partable_attributes |
| 44 | 140x |
Data = lavdata, # S4 class - data (3) |
| 45 | 140x |
SampleStats = lavsamplestats, # S4 class - samplestats (5) |
| 46 | 140x |
Model = lavmodel, # S4 class - model (9) / estoptim (11) / vcovboot (13) |
| 47 | 140x |
Cache = lavcache, # list - cache (10) |
| 48 | 140x |
Fit = lavfit, # S4 class - lav_model_fit (14bis) |
| 49 | 140x |
boot = lavboot, # list - vcovboot (13) |
| 50 | 140x |
optim = lavoptim, # list - estoptim (11) |
| 51 | 140x |
implied = lavimplied, # list - lav_model_implied (12) |
| 52 | 140x |
loglik = lavloglik, # list - lav_model_loglik (12) |
| 53 | 140x |
vcov = lavvcov, # list - vcovboot (13) |
| 54 | 140x |
test = lavtest, # list - test (14) |
| 55 | 140x |
h1 = lavh1, # list - h1 (6) |
| 56 | 140x |
baseline = lavbaseline, # list - baseline (15) |
| 57 | 140x |
internal = list(), # empty list |
| 58 | 140x |
external = list() # empty list |
| 59 |
) |
|
| 60 | ||
| 61 |
# if model.type = "efa", add standardized solution to partable |
|
| 62 | 140x |
if (lavmodel@nefa > 0L) {
|
| 63 | 4x |
if (lav_verbose()) {
|
| 64 | ! |
cat("computing standardized solution ... ")
|
| 65 |
} |
|
| 66 | 4x |
std <- standardizedSolution(lavaan, |
| 67 | 4x |
remove.eq = FALSE, |
| 68 | 4x |
remove.ineq = FALSE, remove.def = FALSE |
| 69 |
) |
|
| 70 | 4x |
if (lav_verbose()) {
|
| 71 | ! |
cat(" done.\n")
|
| 72 |
} |
|
| 73 | 4x |
lavaan@ParTable$est.std <- std$est.std |
| 74 | 4x |
if (!is.null(std$se)) {
|
| 75 | 4x |
lavaan@ParTable$se.std <- std$se |
| 76 |
} |
|
| 77 |
} |
|
| 78 | ||
| 79 |
# eqs? |
|
| 80 | 140x |
if (length(laveqs) > 0L) {
|
| 81 | ! |
lavaan@internal <- list(eqs = laveqs) |
| 82 |
} |
|
| 83 | ||
| 84 |
# post-fitting check of parameters |
|
| 85 | 140x |
if (!is.null(lavoptions$check.post) && lavoptions$check.post && |
| 86 | 140x |
lavTech(lavaan, "converged")) {
|
| 87 | 45x |
if (lav_verbose()) {
|
| 88 | ! |
cat("post check ...")
|
| 89 |
} |
|
| 90 | 45x |
lavInspect(lavaan, "post.check") |
| 91 | 45x |
if (lav_verbose()) {
|
| 92 | ! |
cat(" done.\n")
|
| 93 |
} |
|
| 94 |
} |
|
| 95 | ||
| 96 | 140x |
lavaan |
| 97 |
} |
| 1 |
# - 0.6-13: fix multiple-group UG^2 bug (reported by Gronneberg, Foldnes and |
|
| 2 |
# Moss) when Satterthwaite = TRUE, ngroups > 1, and eq constraints. |
|
| 3 |
# |
|
| 4 |
# Note however that Satterthwaite = FALSE always (for now), so |
|
| 5 |
# the fix has no (visible) effect |
|
| 6 | ||
| 7 |
lav_test_yuan_bentler <- function(lavobject = NULL, |
|
| 8 |
lavsamplestats = NULL, |
|
| 9 |
lavmodel = NULL, |
|
| 10 |
lavimplied = NULL, |
|
| 11 |
lavh1 = NULL, |
|
| 12 |
lavoptions = NULL, |
|
| 13 |
lavdata = NULL, |
|
| 14 |
TEST.unscaled = NULL, |
|
| 15 |
E.inv = NULL, |
|
| 16 |
B0.group = NULL, |
|
| 17 |
test = "yuan.bentler", |
|
| 18 |
mimic = "lavaan", |
|
| 19 |
# method = "default", |
|
| 20 |
ug2.old.approach = FALSE, |
|
| 21 |
return.ugamma = FALSE) {
|
|
| 22 | 8x |
TEST <- list() |
| 23 | ||
| 24 | 8x |
if (!is.null(lavobject)) {
|
| 25 | ! |
lavsamplestats <- lavobject@SampleStats |
| 26 | ! |
lavmodel <- lavobject@Model |
| 27 | ! |
lavoptions <- lavobject@Options |
| 28 | ! |
lavpartable <- lavobject@ParTable |
| 29 | ! |
lavimplied <- lavobject@implied |
| 30 | ! |
lavh1 <- lavobject@h1 |
| 31 | ! |
lavdata <- lavobject@Data |
| 32 | ! |
TEST$standard <- lavobject@test[[1]] |
| 33 |
} else {
|
|
| 34 | 8x |
TEST$standard <- TEST.unscaled |
| 35 |
} |
|
| 36 | ||
| 37 |
# ug2.old.approach |
|
| 38 | 8x |
if (missing(ug2.old.approach)) {
|
| 39 | 8x |
if (!is.null(lavoptions$ug2.old.approach)) {
|
| 40 | 8x |
ug2.old.approach <- lavoptions$ug2.old.approach |
| 41 |
} else {
|
|
| 42 | ! |
ug2.old.approach <- FALSE |
| 43 |
} |
|
| 44 |
} |
|
| 45 | ||
| 46 |
# E.inv ok? |
|
| 47 | 8x |
if (length(lavoptions$information) == 1L && |
| 48 | 8x |
length(lavoptions$h1.information) == 1L && |
| 49 | 8x |
length(lavoptions$observed.information) == 1L) {
|
| 50 | ! |
E.inv.recompute <- FALSE |
| 51 | 8x |
} else if ((lavoptions$information[1] == lavoptions$information[2]) && |
| 52 | 8x |
(lavoptions$h1.information[1] == lavoptions$h1.information[2]) && |
| 53 | 8x |
(lavoptions$information[2] == "expected" || |
| 54 | 8x |
lavoptions$observed.information[1] == |
| 55 | 8x |
lavoptions$observed.information[2])) {
|
| 56 | 8x |
E.inv.recompute <- FALSE |
| 57 |
} else {
|
|
| 58 | ! |
E.inv.recompute <- TRUE |
| 59 |
# change information options |
|
| 60 | ! |
lavoptions$information[1] <- lavoptions$information[2] |
| 61 | ! |
lavoptions$h1.information[1] <- lavoptions$h1.information[2] |
| 62 | ! |
lavoptions$observed.information[1] <- lavoptions$observed.information[2] |
| 63 |
} |
|
| 64 | 8x |
if (!is.null(E.inv)) {
|
| 65 | 8x |
E.inv.recompute <- FALSE # user-provided |
| 66 |
} |
|
| 67 | ||
| 68 |
# check test |
|
| 69 | 8x |
if (!all(test %in% c( |
| 70 | 8x |
"yuan.bentler", |
| 71 | 8x |
"yuan.bentler.mplus" |
| 72 |
))) {
|
|
| 73 | ! |
lav_msg_warn(gettext("test must be one of `yuan.bentler', or
|
| 74 | ! |
`yuan.bentler.mplus'; will use `yuan.bentler' only")) |
| 75 | ! |
test <- "yuan.bentler" |
| 76 |
} |
|
| 77 | ||
| 78 |
# information |
|
| 79 | 8x |
information <- lavoptions$information[1] |
| 80 | ||
| 81 |
# ndat |
|
| 82 | 8x |
ndat <- numeric(lavsamplestats@ngroups) |
| 83 | ||
| 84 | ||
| 85 |
# do we have E.inv? |
|
| 86 | 8x |
if (is.null(E.inv) || E.inv.recompute) {
|
| 87 | ! |
E.inv <- try( |
| 88 | ! |
lav_model_information( |
| 89 | ! |
lavmodel = lavmodel, |
| 90 | ! |
lavsamplestats = lavsamplestats, |
| 91 | ! |
lavdata = lavdata, |
| 92 | ! |
lavimplied = lavimplied, |
| 93 | ! |
lavoptions = lavoptions, |
| 94 | ! |
extra = FALSE, |
| 95 | ! |
augmented = TRUE, |
| 96 | ! |
inverted = TRUE |
| 97 |
), |
|
| 98 | ! |
silent = TRUE |
| 99 |
) |
|
| 100 | ! |
if (inherits(E.inv, "try-error")) {
|
| 101 | ! |
if (return.ugamma) {
|
| 102 | ! |
lav_msg_warn(gettext( |
| 103 | ! |
"could not invert information matrix needed for UGamma")) |
| 104 | ! |
return(NULL) |
| 105 |
} else {
|
|
| 106 | ! |
TEST$standard$stat <- as.numeric(NA) |
| 107 | ! |
TEST$standard$stat.group <- rep(as.numeric(NA), lavdata@ngroups) |
| 108 | ! |
TEST$standard$pvalue <- as.numeric(NA) |
| 109 | ! |
TEST[[test[1]]] <- c(TEST$standard, |
| 110 | ! |
scaling.factor = as.numeric(NA), |
| 111 | ! |
shift.parameter = as.numeric(NA), |
| 112 | ! |
label = character(0) |
| 113 |
) |
|
| 114 | ! |
lav_msg_warn(gettext("could not invert information [matrix needed for
|
| 115 | ! |
robust test statistic")) |
| 116 | ! |
TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models |
| 117 | ! |
return(TEST) |
| 118 |
} |
|
| 119 |
} |
|
| 120 |
} |
|
| 121 | ||
| 122 |
# catch df == 0 |
|
| 123 | 8x |
if (TEST$standard$df == 0L || TEST$standard$df < 0) {
|
| 124 | 2x |
TEST[[test[1]]] <- c(TEST$standard, |
| 125 | 2x |
scaling.factor = as.numeric(NA), |
| 126 | 2x |
label = character(0) |
| 127 |
) |
|
| 128 | 2x |
TEST[[test[1]]]$test <- test[1] # to prevent lavTestLRT error when robust test is detected for some but not all models |
| 129 | 2x |
return(TEST) |
| 130 |
} |
|
| 131 | ||
| 132 |
# mean and variance adjusted? |
|
| 133 | 6x |
Satterthwaite <- FALSE # for now |
| 134 |
# if(any(test %in% c("mean.var.adjusted", "scaled.shifted"))) {
|
|
| 135 |
# Satterthwaite <- TRUE |
|
| 136 |
# } |
|
| 137 | ||
| 138 |
# FIXME: should we not always use 'unstructured' here? |
|
| 139 |
# if the model is, say, the independence model, the |
|
| 140 |
# 'structured' information (A1) will be so far away from B1 |
|
| 141 |
# that we will end up with 'NA' |
|
| 142 | 6x |
h1.options <- lavoptions |
| 143 | 6x |
if (test == "yuan.bentler.mplus") {
|
| 144 |
# always 'unstructured' H1 information |
|
| 145 | 6x |
h1.options$h1.information <- "unstructured" |
| 146 |
} |
|
| 147 | ||
| 148 |
# A1 is usually expected or observed |
|
| 149 | 6x |
A1.group <- lav_model_h1_information( |
| 150 | 6x |
lavmodel = lavmodel, |
| 151 | 6x |
lavsamplestats = lavsamplestats, |
| 152 | 6x |
lavdata = lavdata, |
| 153 | 6x |
lavimplied = lavimplied, |
| 154 | 6x |
lavh1 = lavh1, |
| 155 | 6x |
lavoptions = h1.options |
| 156 |
) |
|
| 157 |
# B1 is always first.order |
|
| 158 | 6x |
B1.group <- lav_model_h1_information_firstorder( |
| 159 | 6x |
lavmodel = lavmodel, |
| 160 | 6x |
lavsamplestats = lavsamplestats, |
| 161 | 6x |
lavdata = lavdata, |
| 162 | 6x |
lavimplied = lavimplied, |
| 163 | 6x |
lavh1 = lavh1, |
| 164 | 6x |
lavoptions = h1.options |
| 165 |
) |
|
| 166 | ||
| 167 | 6x |
if (test == "yuan.bentler.mplus") {
|
| 168 | 6x |
if (is.null(B0.group)) {
|
| 169 | ! |
B0 <- lav_model_information_firstorder( |
| 170 | ! |
lavmodel = lavmodel, |
| 171 | ! |
lavsamplestats = lavsamplestats, |
| 172 | ! |
lavdata = lavdata, |
| 173 | ! |
lavh1 = lavh1, |
| 174 | ! |
lavoptions = lavoptions, |
| 175 | ! |
extra = TRUE, |
| 176 | ! |
check.pd = FALSE, |
| 177 | ! |
augmented = FALSE, |
| 178 | ! |
inverted = FALSE |
| 179 |
) |
|
| 180 | ! |
B0.group <- attr(B0, "B0.group") |
| 181 |
} |
|
| 182 | 6x |
trace.UGamma <- |
| 183 | 6x |
lav_test_yuan_bentler_mplus_trace( |
| 184 | 6x |
lavsamplestats = lavsamplestats, |
| 185 | 6x |
A1.group = A1.group, |
| 186 | 6x |
B1.group = B1.group, |
| 187 | 6x |
B0.group = B0.group, |
| 188 | 6x |
E.inv = E.inv, |
| 189 | 6x |
meanstructure = lavmodel@meanstructure |
| 190 |
) |
|
| 191 | ! |
} else if (test == "yuan.bentler") {
|
| 192 |
# compute Delta |
|
| 193 | ! |
Delta <- lav_model_delta(lavmodel = lavmodel) |
| 194 | ||
| 195 |
# compute Omega/Gamma |
|
| 196 | ! |
Omega <- lav_model_h1_omega( |
| 197 | ! |
lavmodel = lavmodel, |
| 198 | ! |
lavsamplestats = lavsamplestats, |
| 199 | ! |
lavdata = lavdata, |
| 200 | ! |
lavimplied = lavimplied, |
| 201 | ! |
lavh1 = lavh1, |
| 202 | ! |
lavoptions = lavoptions |
| 203 |
) |
|
| 204 | ||
| 205 |
# compute trace 'U %*% Gamma' (or 'U %*% Omega') |
|
| 206 | ! |
trace.UGamma <- lav_test_yuan_bentler_trace( |
| 207 | ! |
lavsamplestats = lavsamplestats, |
| 208 | ! |
meanstructure = lavmodel@meanstructure, |
| 209 | ! |
A1.group = A1.group, |
| 210 | ! |
B1.group = B1.group, |
| 211 | ! |
Delta = Delta, |
| 212 | ! |
Omega = Omega, |
| 213 | ! |
E.inv = E.inv, |
| 214 | ! |
ug2.old.approach = ug2.old.approach, |
| 215 | ! |
Satterthwaite = FALSE |
| 216 | ! |
) # for now |
| 217 |
} |
|
| 218 | ||
| 219 |
# unscaled test |
|
| 220 | 6x |
df <- TEST$standard$df |
| 221 | ||
| 222 | 6x |
scaling.factor <- trace.UGamma / df |
| 223 | ! |
if (scaling.factor < 0) scaling.factor <- as.numeric(NA) |
| 224 | 6x |
chisq.scaled <- TEST$standard$stat / scaling.factor |
| 225 | 6x |
pvalue.scaled <- 1 - pchisq(chisq.scaled, df) |
| 226 | ||
| 227 | 6x |
ndat <- sum(attr(trace.UGamma, "h1.ndat")) |
| 228 | 6x |
npar <- lavmodel@nx.free |
| 229 | ||
| 230 | 6x |
scaling.factor.h1 <- sum(attr(trace.UGamma, "h1")) / ndat |
| 231 | 6x |
scaling.factor.h0 <- sum(attr(trace.UGamma, "h0")) / npar |
| 232 | 6x |
trace.UGamma2 <- attr(trace.UGamma, "trace.UGamma2") |
| 233 | 6x |
attributes(trace.UGamma) <- NULL |
| 234 | ||
| 235 | 6x |
if ("yuan.bentler" %in% test) {
|
| 236 | ! |
TEST$yuan.bentler <- |
| 237 | ! |
list( |
| 238 | ! |
test = test, |
| 239 | ! |
stat = chisq.scaled, |
| 240 | ! |
stat.group = (TEST$standard$stat.group / |
| 241 | ! |
scaling.factor), |
| 242 | ! |
df = df, |
| 243 | ! |
pvalue = pvalue.scaled, |
| 244 | ! |
scaling.factor = scaling.factor, |
| 245 | ! |
scaling.factor.h1 = scaling.factor.h1, |
| 246 | ! |
scaling.factor.h0 = scaling.factor.h0, |
| 247 | ! |
label = "Yuan-Bentler correction", |
| 248 | ! |
trace.UGamma = trace.UGamma, |
| 249 | ! |
trace.UGamma2 = trace.UGamma2, |
| 250 | ! |
scaled.test.stat = TEST$standard$stat, |
| 251 | ! |
scaled.test = TEST$standard$test |
| 252 |
) |
|
| 253 | 6x |
} else if ("yuan.bentler.mplus" %in% test) {
|
| 254 | 6x |
TEST$yuan.bentler.mplus <- |
| 255 | 6x |
list( |
| 256 | 6x |
test = test, |
| 257 | 6x |
stat = chisq.scaled, |
| 258 | 6x |
stat.group = (TEST$standard$stat.group / |
| 259 | 6x |
scaling.factor), |
| 260 | 6x |
df = df, |
| 261 | 6x |
pvalue = pvalue.scaled, |
| 262 | 6x |
scaling.factor = scaling.factor, |
| 263 | 6x |
scaling.factor.h1 = scaling.factor.h1, |
| 264 | 6x |
scaling.factor.h0 = scaling.factor.h0, |
| 265 | 6x |
label = |
| 266 | 6x |
"Yuan-Bentler correction (Mplus variant)", |
| 267 | 6x |
trace.UGamma = trace.UGamma, |
| 268 | 6x |
trace.UGamma2 = as.numeric(NA), |
| 269 | 6x |
scaled.test.stat = TEST$standard$stat, |
| 270 | 6x |
scaled.test = TEST$standard$test |
| 271 |
) |
|
| 272 |
} |
|
| 273 | ||
| 274 | 6x |
TEST |
| 275 |
} |
|
| 276 | ||
| 277 | ||
| 278 |
lav_test_yuan_bentler_trace <- function(lavsamplestats = lavsamplestats, |
|
| 279 |
meanstructure = TRUE, |
|
| 280 |
A1.group = NULL, |
|
| 281 |
B1.group = NULL, |
|
| 282 |
Delta = NULL, |
|
| 283 |
Omega = NULL, |
|
| 284 |
E.inv = NULL, |
|
| 285 |
ug2.old.approach = FALSE, |
|
| 286 |
Satterthwaite = FALSE) {
|
|
| 287 |
# we always assume a meanstructure (nope, not any longer, since 0.6) |
|
| 288 |
# meanstructure <- TRUE |
|
| 289 | ||
| 290 | ! |
ngroups <- lavsamplestats@ngroups |
| 291 | ||
| 292 | ! |
trace.h1 <- attr(Omega, "trace.h1") |
| 293 | ! |
h1.ndat <- attr(Omega, "h1.ndat") |
| 294 | ||
| 295 | ! |
if (ug2.old.approach || !Satterthwaite) {
|
| 296 | ! |
trace.UGamma <- numeric(ngroups) |
| 297 | ! |
trace.UGamma2 <- numeric(ngroups) |
| 298 | ! |
trace.h0 <- numeric(ngroups) |
| 299 | ||
| 300 | ! |
for (g in 1:ngroups) {
|
| 301 | ! |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 302 | ||
| 303 | ! |
A1 <- A1.group[[g]] * fg |
| 304 | ! |
B1 <- B1.group[[g]] * fg |
| 305 | ! |
DELTA <- Delta[[g]] |
| 306 | ! |
Gamma.g <- Omega[[g]] / fg |
| 307 | ||
| 308 | ! |
D.Einv.tD <- DELTA %*% tcrossprod(E.inv, DELTA) |
| 309 | ||
| 310 |
# trace.h1[g] <- sum( B1 * t( A1.inv ) ) |
|
| 311 |
# fg cancels out: trace.h1[g] <- sum( fg*B1 * t( 1/fg*A1.inv ) ) |
|
| 312 | ! |
trace.h0[g] <- sum(B1 * D.Einv.tD) |
| 313 |
# trace.UGamma[g] <- trace.h1[g] - trace.h0[g] |
|
| 314 | ! |
U <- A1 - A1 %*% D.Einv.tD %*% A1 |
| 315 | ! |
trace.UGamma[g] <- sum(U * Gamma.g) |
| 316 | ||
| 317 | ! |
if (Satterthwaite) {
|
| 318 | ! |
UG <- U %*% Gamma.g |
| 319 | ! |
trace.UGamma2[g] <- sum(UG * t(UG)) |
| 320 |
} |
|
| 321 |
} # g |
|
| 322 | ! |
trace.UGamma <- sum(trace.UGamma) |
| 323 | ! |
attr(trace.UGamma, "h1") <- trace.h1 |
| 324 | ! |
attr(trace.UGamma, "h0") <- trace.h0 |
| 325 | ! |
attr(trace.UGamma, "h1.ndat") <- h1.ndat |
| 326 | ! |
if (Satterthwaite) {
|
| 327 | ! |
attr(trace.UGamma, "trace.UGamma2") <- sum(trace.UGamma2) |
| 328 |
} |
|
| 329 |
} else {
|
|
| 330 | ! |
trace.UGamma <- trace.UGamma2 <- UG <- as.numeric(NA) |
| 331 | ! |
fg <- unlist(lavsamplestats@nobs) / lavsamplestats@ntotal |
| 332 |
# if(Satterthwaite) {
|
|
| 333 | ||
| 334 | ! |
A1.f <- A1.group |
| 335 | ! |
for (g in 1:ngroups) {
|
| 336 | ! |
A1.f[[g]] <- A1.group[[g]] * fg[g] |
| 337 |
} |
|
| 338 | ! |
A1.all <- lav_matrix_bdiag(A1.f) |
| 339 | ||
| 340 | ! |
B1.f <- B1.group |
| 341 | ! |
for (g in 1:ngroups) {
|
| 342 | ! |
B1.f[[g]] <- B1.group[[g]] * fg[g] |
| 343 |
} |
|
| 344 | ! |
B1.all <- lav_matrix_bdiag(B1.f) |
| 345 | ||
| 346 | ! |
Gamma.f <- Omega |
| 347 | ! |
for (g in 1:ngroups) {
|
| 348 | ! |
Gamma.f[[g]] <- 1 / fg[g] * Omega[[g]] |
| 349 |
} |
|
| 350 | ! |
Gamma.all <- lav_matrix_bdiag(Gamma.f) |
| 351 | ! |
Delta.all <- do.call("rbind", Delta)
|
| 352 | ||
| 353 | ! |
D.Einv.tD <- Delta.all %*% tcrossprod(E.inv, Delta.all) |
| 354 | ||
| 355 | ! |
trace.h0 <- sum(B1.all * D.Einv.tD) |
| 356 | ! |
U.all <- A1.all - A1.all %*% D.Einv.tD %*% A1.all |
| 357 | ! |
trace.UGamma <- sum(U.all * Gamma.all) |
| 358 | ||
| 359 | ! |
attr(trace.UGamma, "h1") <- sum(trace.h1) |
| 360 | ! |
attr(trace.UGamma, "h0") <- trace.h0 |
| 361 | ! |
attr(trace.UGamma, "h1.ndat") <- sum(h1.ndat) |
| 362 | ! |
if (Satterthwaite) {
|
| 363 | ! |
UG <- U.all %*% Gamma.all |
| 364 | ! |
trace.UGamma2 <- sum(UG * t(UG)) |
| 365 | ! |
attr(trace.UGamma, "trace.UGamma2") <- trace.UGamma2 |
| 366 |
} |
|
| 367 | ||
| 368 |
# } else {
|
|
| 369 |
} |
|
| 370 | ||
| 371 | ! |
trace.UGamma |
| 372 |
} |
|
| 373 | ||
| 374 |
lav_test_yuan_bentler_mplus_trace <- function(lavsamplestats = NULL, |
|
| 375 |
A1.group = NULL, |
|
| 376 |
B1.group = NULL, |
|
| 377 |
B0.group = NULL, |
|
| 378 |
E.inv = NULL, |
|
| 379 |
meanstructure = TRUE) {
|
|
| 380 |
# typical for Mplus: |
|
| 381 |
# - do NOT use the YB formula, but use an approximation |
|
| 382 |
# relying on A0 ~= Delta' A1 Delta and the same for B0 |
|
| 383 |
# |
|
| 384 |
# NOTE: if A0 is based on the hessian, then A0 only approximates |
|
| 385 |
# Delta' A1 Delta |
|
| 386 |
# |
|
| 387 |
# - always use h1.information = "unstructured"!!! |
|
| 388 | ||
| 389 | 6x |
ngroups <- lavsamplestats@ngroups |
| 390 | ||
| 391 | 6x |
trace.UGamma <- numeric(lavsamplestats@ngroups) |
| 392 | 6x |
trace.h1 <- numeric(lavsamplestats@ngroups) |
| 393 | 6x |
trace.h0 <- numeric(lavsamplestats@ngroups) |
| 394 | 6x |
h1.ndat <- numeric(lavsamplestats@ngroups) |
| 395 | ||
| 396 | 6x |
for (g in 1:lavsamplestats@ngroups) {
|
| 397 |
# group weight |
|
| 398 | 6x |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 399 | ||
| 400 | 6x |
A1 <- A1.group[[g]] |
| 401 | 6x |
B1 <- B1.group[[g]] |
| 402 | ||
| 403 |
# mask independent 'fixed-x' variables |
|
| 404 | 6x |
zero.idx <- which(diag(A1) == 0) |
| 405 | 6x |
if (length(zero.idx) > 0L) {
|
| 406 | 6x |
A1.inv <- matrix(0, nrow(A1), ncol(A1)) |
| 407 | 6x |
a1 <- A1[-zero.idx, -zero.idx] |
| 408 | 6x |
a1.inv <- solve(a1) |
| 409 | 6x |
A1.inv[-zero.idx, -zero.idx] <- a1.inv |
| 410 |
} else {
|
|
| 411 | ! |
A1.inv <- solve(A1) |
| 412 |
} |
|
| 413 | 6x |
h1.ndat[g] <- ncol(A1) - length(zero.idx) |
| 414 | ||
| 415 |
# if data is complete, why not just A1 %*% Gamma? |
|
| 416 | 6x |
trace.h1[g] <- sum(B1 * t(A1.inv)) |
| 417 | 6x |
trace.h0[g] <- fg * sum(B0.group[[g]] * t(E.inv)) |
| 418 | 6x |
trace.UGamma[g] <- (trace.h1[g] - trace.h0[g]) |
| 419 |
} |
|
| 420 | ||
| 421 |
# we take the sum here |
|
| 422 | 6x |
trace.UGamma <- sum(trace.UGamma) |
| 423 | ||
| 424 | 6x |
attr(trace.UGamma, "h1") <- trace.h1 |
| 425 | 6x |
attr(trace.UGamma, "h0") <- trace.h0 |
| 426 | 6x |
attr(trace.UGamma, "h1.ndat") <- h1.ndat |
| 427 | ||
| 428 | 6x |
trace.UGamma |
| 429 |
} |
| 1 |
# compute two-step standard errors for SAM models |
|
| 2 |
# |
|
| 3 |
# several possibilities: |
|
| 4 |
# 1) se = "twostep": classic (but global) two-step corrected SEs |
|
| 5 |
# - create 'global' model, only to get the 'joint' information matrix |
|
| 6 |
# - partition information matrix (step 1, step 2) |
|
| 7 |
# - apply two-step correction for second step |
|
| 8 |
# - 'insert' these corrected SEs (and vcov) in JOINT |
|
| 9 |
# 2) se = "standard": using I.22.inv (but without correction term) |
|
| 10 |
# 3) se = "naive": grab (naive) VCOV from FIT.PA |
|
| 11 |
# 4) se = "local": grab (robust) VCOV from FIT.PA |
|
| 12 | ||
| 13 |
lav_sam_step2_se <- function(FIT = NULL, JOINT = NULL, |
|
| 14 |
STEP1 = NULL, STEP2 = NULL, |
|
| 15 |
local.options = list()) {
|
|
| 16 | ! |
out <- list() |
| 17 | ! |
Sigma.11 <- STEP1$Sigma.11 |
| 18 | ! |
step1.free.idx <- STEP1$step1.free.idx |
| 19 | ! |
step2.free.idx <- STEP2$step2.free.idx |
| 20 | ! |
lavoptions <- FIT@Options |
| 21 | ! |
nlevels <- FIT@pta$nlevels |
| 22 | ! |
FIT.PA <- STEP2$FIT.PA |
| 23 | ! |
extra.id <- STEP2$extra.id |
| 24 | ||
| 25 |
# catch empty step2.free.idx |
|
| 26 | ! |
if (length(step2.free.idx) == 0L) {
|
| 27 |
# no (free) structural parameters at all! |
|
| 28 | ! |
out <- list( |
| 29 | ! |
V1 = matrix(0, 0, 0), V2 = matrix(0, 0, 0), |
| 30 | ! |
VCOV = matrix(0, 0, 0) |
| 31 |
) |
|
| 32 | ! |
return(out) |
| 33 |
} |
|
| 34 | ||
| 35 | ! |
if (!lavoptions$se %in% |
| 36 | ! |
c("none", "standard", "naive", "twostep", "twostep.robust",
|
| 37 | ! |
"local", "local.nt")) {
|
| 38 | ! |
lav_msg_warn(gettextf( |
| 39 | ! |
"unknown se= argument: %s. Switching to twostep.", |
| 40 | ! |
lavoptions$se |
| 41 |
)) |
|
| 42 |
} |
|
| 43 | ||
| 44 | ! |
if (lavoptions$se == "none") {
|
| 45 | ! |
return(out) |
| 46 |
} |
|
| 47 | ||
| 48 | ! |
if (lav_verbose()) {
|
| 49 | ! |
cat("Computing ", lavoptions$se, " standard errors ... ", sep = "")
|
| 50 |
} |
|
| 51 | ||
| 52 | ! |
if (lavoptions$se %in% c("naive", "twostep", "twostep.robust")) {
|
| 53 | ! |
INFO <- lavInspect(JOINT, "information") |
| 54 | ! |
I.12 <- INFO[step1.free.idx, step2.free.idx] |
| 55 | ! |
I.22 <- INFO[step2.free.idx, step2.free.idx] |
| 56 | ! |
I.21 <- INFO[step2.free.idx, step1.free.idx] |
| 57 |
} |
|
| 58 | ||
| 59 |
# V2 |
|
| 60 | ! |
if (nlevels > 1L) {
|
| 61 |
# FIXME: not ok for multigroup multilevel |
|
| 62 | ! |
N <- FIT@Data@Lp[[1]]$nclusters[[2]] # first group only |
| 63 |
} else {
|
|
| 64 | ! |
N <- nobs(FIT) |
| 65 |
} |
|
| 66 | ||
| 67 |
# total number of free parameters STRUC |
|
| 68 | ! |
if (FIT.PA@Model@ceq.simple.only) {
|
| 69 | ! |
npar <- FIT.PA@Model@nx.unco |
| 70 | ! |
PTS.free <- FIT.PA@ParTable$free |
| 71 | ! |
PTS.free[PTS.free > 0] <- seq_len(npar) |
| 72 |
} else {
|
|
| 73 | ! |
npar <- FIT.PA@Model@nx.free |
| 74 | ! |
PTS.free <- FIT.PA@ParTable$free |
| 75 |
} |
|
| 76 | ||
| 77 |
# do we have 'extra' free parameter in FIT.PA that are not free in JOINT? |
|
| 78 | ! |
step2.rm.idx <- integer(0L) |
| 79 | ! |
if (length(extra.id) > 0L) {
|
| 80 | ! |
id.idx <- which(FIT.PA@ParTable$id %in% extra.id & |
| 81 | ! |
FIT.PA@ParTable$free > 0L) |
| 82 | ! |
step2.rm.idx <- PTS.free[id.idx] |
| 83 |
} |
|
| 84 | ||
| 85 |
# Fix for EFA/ESEM: when rotation is used, FIT.PA@Model@con.jac includes |
|
| 86 |
# columns for rotation identification constraints that are not part of |
|
| 87 |
# step2.free.idx. These extra columns cause dimension mismatch in |
|
| 88 |
# lav_model_information_augment_invert(). Remove them via rm.idx. |
|
| 89 | ! |
if (nrow(FIT.PA@Model@con.jac) > 0L) {
|
| 90 | ! |
n_jac_cols <- ncol(FIT.PA@Model@con.jac) |
| 91 | ! |
n_step2 <- length(step2.free.idx) |
| 92 | ! |
if (n_jac_cols > n_step2) {
|
| 93 | ! |
step2.rm.idx <- union(step2.rm.idx, (n_step2 + 1):n_jac_cols) |
| 94 |
} |
|
| 95 |
} |
|
| 96 | ||
| 97 |
# invert augmented information, for I.22 block only |
|
| 98 |
# new in 0.6-16 (otherwise, eq constraints in struc part are ignored) |
|
| 99 | ! |
if (lavoptions$se %in% c("standard", "twostep", "twostep.robust")) {
|
| 100 | ! |
I.22.inv <- |
| 101 | ! |
lav_model_information_augment_invert( |
| 102 | ! |
lavmodel = FIT.PA@Model, |
| 103 | ! |
information = I.22, |
| 104 | ! |
inverted = TRUE, |
| 105 | ! |
use.ginv = FALSE, # if interaction, SEs end up smaller than naive... |
| 106 | ! |
rm.idx = step2.rm.idx |
| 107 |
) |
|
| 108 | ! |
if (inherits(I.22.inv, "try-error")) {
|
| 109 |
# hm, not good |
|
| 110 | ! |
if (lavoptions$se != "naive") {
|
| 111 | ! |
lav_msg_warn(gettext( |
| 112 | ! |
"problem inverting information matrix (I.22); -> switching |
| 113 | ! |
to naive standard errors!" |
| 114 |
)) |
|
| 115 | ! |
lavoptions$se <- "naive" |
| 116 |
} |
|
| 117 |
} |
|
| 118 |
} # se needs I.22.inv |
|
| 119 | ||
| 120 |
# method below has the advantage that we can use a 'robust' vcov |
|
| 121 |
# for the joint model; |
|
| 122 |
# but does not work if we have equality constraints in the MM! |
|
| 123 |
# -> D will be singular |
|
| 124 |
# A <- JOINT@vcov$vcov[ step2.free.idx, step2.free.idx] |
|
| 125 |
# B <- JOINT@vcov$vcov[ step2.free.idx, -step2.free.idx] |
|
| 126 |
# C <- JOINT@vcov$vcov[-step2.free.idx, step2.free.idx] |
|
| 127 |
# D <- JOINT@vcov$vcov[-step2.free.idx, -step2.free.idx] |
|
| 128 |
# I.22.inv <- A - B %*% solve(D) %*% C |
|
| 129 | ||
| 130 |
# se = "standard" |
|
| 131 | ! |
if (lavoptions$se == "standard") {
|
| 132 | ! |
VCOV <- 1 / N * I.22.inv |
| 133 | ! |
out$VCOV <- VCOV |
| 134 | ||
| 135 |
# se = "naive" or "local": grab VCOV directly from FIT.PA |
|
| 136 | ! |
} else if (lavoptions$se %in% c("naive", "local", "local.nt")) {
|
| 137 | ! |
if (is.null(FIT.PA@vcov$vcov)) {
|
| 138 | ! |
FIT.PA@Options$se <- "standard" |
| 139 | ! |
VCOV <- lavTech(FIT.PA, "vcov") |
| 140 |
} else {
|
|
| 141 | ! |
VCOV <- FIT.PA@vcov$vcov |
| 142 |
} |
|
| 143 | ! |
if (length(step2.rm.idx) > 0L) {
|
| 144 | ! |
VCOV <- VCOV[-step2.rm.idx, -step2.rm.idx] |
| 145 |
} |
|
| 146 |
# order rows/cols of VCOV, so that they correspond with the (step 2) |
|
| 147 |
# parameters of the JOINT model |
|
| 148 | ! |
idx <- sort.int(STEP2$pt.idx, index.return = TRUE)$ix |
| 149 | ! |
VCOV <- VCOV[idx, idx] |
| 150 | ||
| 151 | ! |
out$VCOV <- VCOV |
| 152 | ||
| 153 |
# se = "twostep" or "twostep.robust" |
|
| 154 | ! |
} else if (lavoptions$se == "twostep" || lavoptions$se == "twostep.robust") {
|
| 155 | ||
| 156 | ! |
if (lavoptions$se == "twostep") {
|
| 157 | ! |
V2 <- 1 / N * I.22.inv # not the same as FIT.PA@vcov$vcov!! |
| 158 | ! |
V1 <- I.22.inv %*% I.21 %*% Sigma.11 %*% I.12 %*% I.22.inv |
| 159 | ! |
} else if(lavoptions$se == "twostep.robust") {
|
| 160 |
# following Yuan & Chan 2002, eqs 4, 10, 11, 12, 13 and 14 |
|
| 161 |
# but for V11, V12, V21, V22: we use index '1' for step1, and '2' |
|
| 162 |
# for step 2!! |
|
| 163 | ||
| 164 | ! |
A <- -1 * INFO[step2.free.idx, step2.free.idx, drop = FALSE] |
| 165 | ! |
B <- -1 * INFO[step2.free.idx, step1.free.idx, drop = FALSE] |
| 166 | ||
| 167 |
# get P (for a single group!! for now) |
|
| 168 | ! |
P <- lav_sam_step1_local_jac(STEP1 = STEP1, FIT = FIT, P.only = TRUE) |
| 169 | ||
| 170 |
# get V22 |
|
| 171 | ! |
if (is.null(JOINT@SampleStats@NACOV[[1]])) {
|
| 172 | ! |
JOINT@SampleStats@NACOV <- lavTech(JOINT, "gamma") |
| 173 |
} |
|
| 174 | ! |
tmp <- lav_model_nvcov_robust_sem( |
| 175 | ! |
lavmodel = JOINT@Model, lavsamplestats = JOINT@SampleStats, |
| 176 | ! |
lavcache = JOINT@cache, lavdata = JOINT@Data, |
| 177 | ! |
lavimplied = JOINT@implied, lavh1 = JOINT@h1, |
| 178 | ! |
lavoptions = JOINT@Options, use.ginv = FALSE, |
| 179 | ! |
attr.Delta = TRUE, attr.tDVGVD = TRUE, attr.E.inv = TRUE, |
| 180 | ! |
attr.WLS.V = TRUE) |
| 181 | ! |
NVarCov <- tmp[,] # remove attributes |
| 182 | ! |
Delta <- attr(tmp, "Delta") |
| 183 | ! |
E.inv <- attr(tmp, "E.inv") |
| 184 | ! |
WLS.V <- attr(tmp, "WLS.V") |
| 185 | ! |
tDVGVD <- attr(tmp, "tDVGVD") |
| 186 | ||
| 187 | ! |
V22 <- tDVGVD[ step2.free.idx, step2.free.idx, drop = FALSE] # ok |
| 188 | ||
| 189 |
# FIXME: for a single group only: |
|
| 190 | ! |
V11 <- P %*% lavTech(JOINT, "gamma")[[1]] %*% t(P) |
| 191 | ! |
V21 <- t(Delta[[1]][, step2.free.idx]) %*% WLS.V[[1]] %*% lavTech(JOINT, "gamma")[[1]] %*% t(P) |
| 192 | ! |
V12 <- t(V21) |
| 193 | ||
| 194 |
#V11 <- NVarCov[step1.free.idx, step1.free.idx, drop = FALSE] |
|
| 195 |
#V21 <- tmp2[ step2.free.idx, step1.free.idx, drop = FALSE] |
|
| 196 |
#PI <- V22 + B %*% V12 + V21 %*% t(B) + B %*% V11 %*% t(B) |
|
| 197 |
#A.inv <- solve(A) |
|
| 198 | ! |
A.inv <- -1 * I.22.inv |
| 199 |
#VCOV <- A.inv %*% PI %*% t(A.inv) |
|
| 200 | ! |
V2 <- 1/N * (A.inv %*% V22 %*% A.inv) |
| 201 | ! |
V1 <- 1/N * (A.inv %*% (B %*% V12 + V21 %*% t(B) + B %*% V11 %*% t(B)) %*% A.inv) |
| 202 |
} |
|
| 203 | ||
| 204 |
# V for second step |
|
| 205 | ! |
if (!is.null(local.options$alpha.correction) && |
| 206 | ! |
local.options$alpha.correction > 0) {
|
| 207 | ! |
alpha.N1 <- local.options$alpha.correction / (N - 1) |
| 208 | ! |
if (alpha.N1 > 1.0) {
|
| 209 | ! |
alpha.N1 <- 1.0 |
| 210 | ! |
} else if (alpha.N1 < 0.0) {
|
| 211 | ! |
alpha.N1 <- 0.0 |
| 212 |
} |
|
| 213 | ! |
if (is.null(FIT.PA@vcov$vcov)) {
|
| 214 | ! |
FIT.PA@Options$se <- "standard" |
| 215 | ! |
VCOV.naive <- lavTech(FIT.PA, "vcov") |
| 216 |
} else {
|
|
| 217 | ! |
VCOV.naive <- FIT.PA@vcov$vcov |
| 218 |
} |
|
| 219 | ! |
if (length(step2.rm.idx) > 0L) {
|
| 220 | ! |
VCOV.naive <- VCOV.naive[-step2.rm.idx, -step2.rm.idx] |
| 221 |
} |
|
| 222 | ! |
VCOV.corrected <- V2 + V1 |
| 223 | ! |
VCOV <- alpha.N1 * VCOV.naive + (1 - alpha.N1) * VCOV.corrected |
| 224 |
} else {
|
|
| 225 |
# no alpha correction |
|
| 226 | ! |
VCOV <- V2 + V1 |
| 227 |
} |
|
| 228 | ||
| 229 |
# store in out |
|
| 230 | ! |
out$V2 <- V2 |
| 231 | ! |
out$V1 <- V1 |
| 232 | ! |
out$VCOV <- VCOV |
| 233 |
} # twostep |
|
| 234 | ||
| 235 |
# store se |
|
| 236 | ! |
out$se <- lavoptions$se # in case it changed |
| 237 | ||
| 238 | ! |
if (lav_verbose()) {
|
| 239 | ! |
cat("done.\n")
|
| 240 |
} |
|
| 241 | ||
| 242 | ! |
out |
| 243 |
} |
| 1 |
# summary information for a single (lavaan) efa model |
|
| 2 |
# |
|
| 3 |
# workflow: |
|
| 4 |
# - summary() first calls lav_efalist_summary() |
|
| 5 |
# - for each model, lav_efalist_summary() calls lav_object_summary() with |
|
| 6 |
# efa = TRUE and efa.args |
|
| 7 |
# - for each model, lav_object_summary() calls |
|
| 8 |
# lav_efa_summary(object, efa.args = efa.args) to populate the $efa slot |
|
| 9 | ||
| 10 | ||
| 11 |
# efa summary for a single lavaan object |
|
| 12 |
lav_efa_summary <- function(object, |
|
| 13 |
efa.args = list( |
|
| 14 |
lambda = TRUE, |
|
| 15 |
theta = TRUE, |
|
| 16 |
psi = TRUE, |
|
| 17 |
eigenvalues = TRUE, |
|
| 18 |
sumsq.table = TRUE, |
|
| 19 |
lambda.structure = FALSE, |
|
| 20 |
fs.determinacy = FALSE, |
|
| 21 |
se = FALSE, |
|
| 22 |
zstat = FALSE, |
|
| 23 |
pvalue = FALSE |
|
| 24 |
)) {
|
|
| 25 | 4x |
stopifnot(inherits(object, "lavaan")) |
| 26 | ||
| 27 | 4x |
nblocks <- object@Model@nblocks |
| 28 | 4x |
orthogonal.flag <- object@Options$rotation.args$orthogonal |
| 29 | ||
| 30 |
# get standardized solution |
|
| 31 | 4x |
LAMBDA <- THETA <- PSI <- NULL |
| 32 | 4x |
STD <- lavTech(object, "std", |
| 33 | 4x |
add.class = TRUE, add.labels = TRUE, |
| 34 | 4x |
list.by.group = FALSE |
| 35 |
) |
|
| 36 | 4x |
lambda.idx <- which(names(STD) == "lambda") |
| 37 | 4x |
theta.idx <- which(names(STD) == "theta") |
| 38 | 4x |
psi.idx <- which(names(STD) == "psi") |
| 39 | ||
| 40 |
# LAMBDA |
|
| 41 | 4x |
LAMBDA <- STD[lambda.idx] |
| 42 | 4x |
names(LAMBDA) <- NULL |
| 43 | ||
| 44 |
# THETA |
|
| 45 | 4x |
THETA <- STD[theta.idx] |
| 46 |
# make THETA diagonal |
|
| 47 | 4x |
THETA <- lapply(seq_len(nblocks), function(b) {
|
| 48 | 4x |
tmp <- diag(THETA[[b]]) |
| 49 | 4x |
class(tmp) <- c("lavaan.vector", "numeric")
|
| 50 | 4x |
tmp |
| 51 |
}) |
|
| 52 | ||
| 53 |
# PSI |
|
| 54 | 4x |
PSI <- STD[psi.idx] |
| 55 | 4x |
names(PSI) <- NULL |
| 56 | ||
| 57 |
# eigenvalues correlation matrix |
|
| 58 | 4x |
std.ov <- object@Options$rotation.args$std.ov |
| 59 | 4x |
COV <- object@h1$implied$cov # h1 |
| 60 | 4x |
if (std.ov) {
|
| 61 | 4x |
COV <- lapply(COV, cov2cor) |
| 62 |
} |
|
| 63 | 4x |
eigvals <- NULL |
| 64 | 4x |
if (efa.args$eigenvalues) {
|
| 65 | 4x |
eigvals <- lapply(seq_len(nblocks), function(b) {
|
| 66 | 4x |
tmp <- eigen(COV[[b]], only.values = TRUE)$values |
| 67 | 4x |
names(tmp) <- paste("ev", 1:nrow(LAMBDA[[b]]), sep = "")
|
| 68 | 4x |
class(tmp) <- c("lavaan.vector", "numeric")
|
| 69 | 4x |
tmp |
| 70 |
}) |
|
| 71 |
} |
|
| 72 | ||
| 73 | 4x |
fs.determinacy <- NULL |
| 74 |
# Note: these 'determinacy' values are only properly defined for the |
|
| 75 |
# 'regression' factor scores! (If we would apply the same formulas |
|
| 76 |
# for Bartlett factor scores, we would obtain 1's! |
|
| 77 | 4x |
if (efa.args$fs.determinacy) {
|
| 78 | ! |
fs.determinacy <- lapply(seq_len(nblocks), function(b) {
|
| 79 | ! |
COR <- cov2cor(COV[[b]]) # just in case |
| 80 | ! |
COR.inv <- try(solve(COR), silent = TRUE) |
| 81 | ! |
if (inherits(COR.inv, "try-error")) {
|
| 82 | ! |
return(rep(as.numeric(NA), nrow(PSI[[b]]))) |
| 83 |
} |
|
| 84 | ! |
fs <- LAMBDA[[b]] %*% PSI[[b]] # factor structure |
| 85 | ! |
out <- sqrt(diag(t(fs) %*% COR.inv %*% fs)) |
| 86 | ! |
class(out) <- c("lavaan.vector", "numeric")
|
| 87 | ! |
out |
| 88 |
}) |
|
| 89 |
} |
|
| 90 | ||
| 91 |
# sum-of-squares table |
|
| 92 | 4x |
sumsq.table <- NULL |
| 93 | 4x |
if (efa.args$sumsq.table) {
|
| 94 | 4x |
sumsq.table <- lapply(seq_len(nblocks), function(b) {
|
| 95 | 4x |
nvar <- nrow(LAMBDA[[b]]) |
| 96 | 4x |
nfactor <- ncol(LAMBDA[[b]]) |
| 97 | ||
| 98 |
# sum of squares: |
|
| 99 |
# - if orthogonal, this is really the sum of the squared factor |
|
| 100 |
# loadings |
|
| 101 |
# - if oblique, we need to take the correlation into account |
|
| 102 | 4x |
sumsq <- diag(PSI[[b]] %*% crossprod(LAMBDA[[b]])) |
| 103 | ||
| 104 |
# reorder |
|
| 105 | 4x |
if (nfactor > 1L) {
|
| 106 |
# determine order |
|
| 107 | 3x |
order.idx <- sort.int(sumsq, decreasing = TRUE, index.return = TRUE)$ix |
| 108 |
# re-order from large to small |
|
| 109 | 3x |
sumsq <- sumsq[order.idx] |
| 110 |
} |
|
| 111 | ||
| 112 |
# Proportion 'explained' (= proportion of total sumsq) |
|
| 113 |
# note: sum(sumsq) == sum(communalities) |
|
| 114 | 4x |
propexpl <- sumsq / sum(sumsq) |
| 115 | ||
| 116 |
# Proportion var (= sumsq/nvar) |
|
| 117 | 4x |
propvar <- sumsq / nrow(LAMBDA[[b]]) |
| 118 | ||
| 119 |
# Cumulative var |
|
| 120 | 4x |
cumvar <- cumsum(propvar) |
| 121 | ||
| 122 |
# construct table |
|
| 123 | 4x |
tmp <- rbind(sumsq, propexpl, propvar, cumvar) |
| 124 | ||
| 125 |
# total + colnames |
|
| 126 | 4x |
if (nfactor > 1L) {
|
| 127 |
# add total column |
|
| 128 | 3x |
tmp <- cbind(tmp, rowSums(tmp)) |
| 129 | 3x |
tmp[4, ncol(tmp)] <- tmp[3, ncol(tmp)] |
| 130 | 3x |
colnames(tmp) <- |
| 131 | 3x |
c( |
| 132 | 3x |
colnames(LAMBDA[[b]])[order.idx], |
| 133 | 3x |
"total" |
| 134 |
) |
|
| 135 |
} else {
|
|
| 136 | 1x |
colnames(tmp) <- colnames(LAMBDA[[b]])[1] |
| 137 |
} |
|
| 138 | ||
| 139 |
# rownames |
|
| 140 | 4x |
if (nfactor == 1L) {
|
| 141 | 1x |
ssq.label <- "Sum of squared loadings" |
| 142 | 3x |
} else if (orthogonal.flag) {
|
| 143 | ! |
ssq.label <- "Sum of sq (ortho) loadings" |
| 144 |
} else {
|
|
| 145 | 3x |
ssq.label <- "Sum of sq (obliq) loadings" |
| 146 |
} |
|
| 147 | 4x |
rownames(tmp) <- c( |
| 148 | 4x |
ssq.label, |
| 149 | 4x |
"Proportion of total", |
| 150 | 4x |
"Proportion var", |
| 151 | 4x |
"Cumulative var" |
| 152 |
) |
|
| 153 | ||
| 154 |
# class |
|
| 155 | 4x |
class(tmp) <- c("lavaan.matrix", "matrix")
|
| 156 | ||
| 157 | 4x |
tmp |
| 158 |
}) |
|
| 159 |
} # sumsq.table |
|
| 160 | ||
| 161 |
# (factor) structure coefficients |
|
| 162 | 4x |
if (efa.args$lambda.structure) {
|
| 163 | ! |
lambda.structure <- lapply(seq_len(nblocks), function(b) {
|
| 164 | ! |
tmp <- LAMBDA[[b]] %*% PSI[[b]] |
| 165 | ! |
class(tmp) <- c("lavaan.matrix", "matrix")
|
| 166 | ! |
tmp |
| 167 |
}) |
|
| 168 |
} else {
|
|
| 169 | 4x |
lambda.structure <- NULL |
| 170 |
} |
|
| 171 | ||
| 172 |
# standard errors (if any) |
|
| 173 | 4x |
lambda.se <- theta.se <- psi.se <- NULL |
| 174 | 4x |
lambda.zstat <- theta.zstat <- psi.zstat <- NULL |
| 175 | 4x |
lambda.pval <- theta.pval <- psi.pval <- NULL |
| 176 | 4x |
if (object@Options$se != "none") {
|
| 177 | 4x |
SE <- lavTech(object, "std.se", |
| 178 | 4x |
add.class = TRUE, add.labels = TRUE, |
| 179 | 4x |
list.by.group = FALSE |
| 180 |
) |
|
| 181 | ||
| 182 | 4x |
se.flag <- (efa.args$se || efa.args$zstat || efa.args$pvalue) |
| 183 | ||
| 184 |
# ALWAYS use lambda.se |
|
| 185 | 4x |
if (efa.args$lambda) {
|
| 186 | 4x |
lambda.se <- SE[lambda.idx] |
| 187 | 4x |
names(lambda.se) <- NULL |
| 188 |
} |
|
| 189 | ||
| 190 |
# theta.se |
|
| 191 | 4x |
if (se.flag && efa.args$theta) {
|
| 192 | ! |
theta.se <- SE[theta.idx] |
| 193 |
# make theta.se diagonal |
|
| 194 | ! |
theta.se <- lapply(seq_len(nblocks), function(b) {
|
| 195 | ! |
tmp <- diag(theta.se[[b]]) |
| 196 | ! |
class(tmp) <- c("lavaan.vector", "numeric")
|
| 197 | ! |
tmp |
| 198 |
}) |
|
| 199 |
} |
|
| 200 | ||
| 201 |
# ALWAYS use psi.se |
|
| 202 | 4x |
if (efa.args$psi) {
|
| 203 | 4x |
psi.se <- SE[psi.idx] |
| 204 | 4x |
names(psi.se) <- NULL |
| 205 |
} |
|
| 206 | ||
| 207 |
# compute zstat |
|
| 208 | 4x |
if (efa.args$zstat || efa.args$pvalue) {
|
| 209 | ! |
if (efa.args$lambda) {
|
| 210 | ! |
lambda.zstat <- lapply(seq_len(nblocks), function(b) {
|
| 211 | ! |
tmp.se <- lambda.se[[b]] |
| 212 | ! |
tmp.se[tmp.se < sqrt(.Machine$double.eps)] <- |
| 213 | ! |
as.numeric(NA) |
| 214 | ! |
tmp <- LAMBDA[[b]] / tmp.se |
| 215 | ! |
class(tmp) <- c("lavaan.matrix", "matrix")
|
| 216 | ! |
tmp |
| 217 |
}) |
|
| 218 |
} |
|
| 219 | ! |
if (efa.args$theta) {
|
| 220 | ! |
theta.zstat <- lapply(seq_len(nblocks), function(b) {
|
| 221 | ! |
tmp.se <- theta.se[[b]] |
| 222 | ! |
tmp.se[tmp.se < sqrt(.Machine$double.eps)] <- |
| 223 | ! |
as.numeric(NA) |
| 224 | ! |
tmp <- THETA[[b]] / tmp.se |
| 225 | ! |
class(tmp) <- c("lavaan.vector", "numeric")
|
| 226 | ! |
tmp |
| 227 |
}) |
|
| 228 |
} |
|
| 229 | ! |
if (efa.args$psi) {
|
| 230 | ! |
psi.zstat <- lapply(seq_len(nblocks), function(b) {
|
| 231 | ! |
tmp.se <- psi.se[[b]] |
| 232 | ! |
tmp.se[tmp.se < sqrt(.Machine$double.eps)] <- |
| 233 | ! |
as.numeric(NA) |
| 234 | ! |
tmp <- PSI[[b]] / tmp.se |
| 235 | ! |
class(tmp) <- c( |
| 236 | ! |
"lavaan.matrix.symmetric", |
| 237 | ! |
"matrix" |
| 238 |
) |
|
| 239 | ! |
tmp |
| 240 |
}) |
|
| 241 |
} |
|
| 242 |
} |
|
| 243 | ||
| 244 |
# compute pval |
|
| 245 | 4x |
if (efa.args$pvalue) {
|
| 246 | ! |
if (efa.args$lambda) {
|
| 247 | ! |
lambda.pval <- lapply(seq_len(nblocks), function(b) {
|
| 248 | ! |
tmp <- 2 * (1 - pnorm(abs(lambda.zstat[[b]]))) |
| 249 | ! |
class(tmp) <- c("lavaan.matrix", "matrix")
|
| 250 | ! |
tmp |
| 251 |
}) |
|
| 252 |
} |
|
| 253 | ! |
if (efa.args$theta) {
|
| 254 | ! |
theta.pval <- lapply(seq_len(nblocks), function(b) {
|
| 255 | ! |
tmp <- 2 * (1 - pnorm(abs(theta.zstat[[b]]))) |
| 256 | ! |
class(tmp) <- c("lavaan.vector", "numeric")
|
| 257 | ! |
tmp |
| 258 |
}) |
|
| 259 |
} |
|
| 260 | ! |
if (efa.args$psi) {
|
| 261 | ! |
psi.pval <- lapply(seq_len(nblocks), function(b) {
|
| 262 | ! |
tmp <- 2 * (1 - pnorm(abs(psi.zstat[[b]]))) |
| 263 | ! |
class(tmp) <- c( |
| 264 | ! |
"lavaan.matrix.symmetric", |
| 265 | ! |
"matrix" |
| 266 |
) |
|
| 267 | ! |
tmp |
| 268 |
}) |
|
| 269 |
} |
|
| 270 |
} |
|
| 271 |
} # se/zstat/pvalue |
|
| 272 | ||
| 273 |
# block.label |
|
| 274 | 4x |
block.label <- object@Data@block.label |
| 275 | ||
| 276 |
# we remove them here; we may have needed them for other parts |
|
| 277 | 4x |
if (!efa.args$lambda) {
|
| 278 | ! |
LAMBDA <- NULL |
| 279 |
} |
|
| 280 | 4x |
if (!efa.args$theta) {
|
| 281 | ! |
THETA <- NULL |
| 282 |
} |
|
| 283 | 4x |
if (!efa.args$psi) {
|
| 284 | ! |
PSI <- NULL |
| 285 |
} |
|
| 286 | 4x |
if (!efa.args$se) {
|
| 287 |
# always keep lambda.se and psi.se (for the signif stars) |
|
| 288 | 4x |
theta.se <- NULL |
| 289 |
} |
|
| 290 | 4x |
if (!efa.args$zstat) {
|
| 291 | 4x |
lambda.zstat <- theta.zstat <- psi.zstat <- NULL |
| 292 |
} |
|
| 293 | ||
| 294 | 4x |
res <- list( |
| 295 | 4x |
nblocks = nblocks, |
| 296 | 4x |
block.label = block.label, |
| 297 | 4x |
std.ov = std.ov, |
| 298 | 4x |
eigvals = eigvals, |
| 299 | 4x |
sumsq.table = sumsq.table, |
| 300 | 4x |
orthogonal = object@Options$rotation.args$orthogonal, |
| 301 | 4x |
lambda.structure = lambda.structure, |
| 302 | 4x |
fs.determinacy = fs.determinacy, |
| 303 | 4x |
lambda = LAMBDA, |
| 304 | 4x |
theta = THETA, |
| 305 | 4x |
psi = PSI, |
| 306 | 4x |
lambda.se = lambda.se, |
| 307 | 4x |
lambda.zstat = lambda.zstat, |
| 308 | 4x |
lambda.pvalue = lambda.pval, |
| 309 | 4x |
psi.se = psi.se, |
| 310 | 4x |
psi.zstat = psi.zstat, |
| 311 | 4x |
psi.pvalue = psi.pval, |
| 312 | 4x |
theta.se = theta.se, |
| 313 | 4x |
theta.zstat = theta.zstat, |
| 314 | 4x |
theta.pvalue = theta.pval |
| 315 |
) |
|
| 316 | ||
| 317 | 4x |
res |
| 318 |
} |
|
| 319 | ||
| 320 | ||
| 321 |
# summary efaList |
|
| 322 |
lav_efalist_summary <- function(object, nd = 3L, cutoff = 0.3, dot.cutoff = 0.1, |
|
| 323 |
alpha.level = 0.01, |
|
| 324 |
lambda = TRUE, theta = TRUE, psi = TRUE, |
|
| 325 |
fit.table = TRUE, fs.determinacy = FALSE, |
|
| 326 |
eigenvalues = TRUE, sumsq.table = TRUE, |
|
| 327 |
lambda.structure = FALSE, se = FALSE, |
|
| 328 |
zstat = FALSE, pvalue = FALSE, ...) {
|
|
| 329 |
# kill object$loadings if present |
|
| 330 | 1x |
object[["loadings"]] <- NULL |
| 331 | ||
| 332 |
# unclass the object |
|
| 333 | 1x |
y <- unclass(object) |
| 334 | ||
| 335 |
# construct efa.args |
|
| 336 | 1x |
efa.args <- list( |
| 337 | 1x |
lambda = lambda, theta = theta, psi = psi, |
| 338 | 1x |
eigenvalues = eigenvalues, sumsq.table = sumsq.table, |
| 339 | 1x |
lambda.structure = lambda.structure, |
| 340 | 1x |
fs.determinacy = fs.determinacy, |
| 341 | 1x |
se = se, zstat = zstat, pvalue = pvalue |
| 342 |
) |
|
| 343 | ||
| 344 |
# extract useful info from first model |
|
| 345 | 1x |
out <- lav_object_summary(y[[1]], |
| 346 | 1x |
header = TRUE, estimates = FALSE, |
| 347 | 1x |
efa = FALSE |
| 348 |
) |
|
| 349 | ||
| 350 |
# header information |
|
| 351 | 1x |
lavaan.version <- out$header$lavaan.version |
| 352 | 1x |
converged.flag <- all(sapply(y, lavInspect, "converged")) |
| 353 | ||
| 354 |
# estimator |
|
| 355 | 1x |
estimator <- out$optim$estimator |
| 356 | 1x |
estimator.args <- out$optim$estimator.args |
| 357 | ||
| 358 |
# rotation |
|
| 359 | 1x |
rotation <- out$rotation$rotation |
| 360 | 1x |
rotation.args <- out$rotation$rotation.args |
| 361 | ||
| 362 |
# data |
|
| 363 | 1x |
lavdata <- out$data |
| 364 | ||
| 365 |
# main part: lav_object_summary information per model |
|
| 366 | 1x |
RES <- lapply(y, lav_object_summary, |
| 367 | 1x |
header = FALSE, |
| 368 | 1x |
fit.measures = FALSE, estimates = TRUE, efa = TRUE, |
| 369 | 1x |
efa.args = efa.args |
| 370 |
) |
|
| 371 | ||
| 372 |
# number of factors (for ALL blocks) |
|
| 373 | 1x |
nfactors <- sapply(y, function(x) x@pta$nfac[[1]]) |
| 374 | ||
| 375 |
# fit.measures |
|
| 376 | 1x |
Table <- NULL |
| 377 | 1x |
if (fit.table) {
|
| 378 |
# first, create standard table |
|
| 379 | 1x |
FIT <- fitMeasures(object, fit.measures = "default") |
| 380 | 1x |
NAMES <- rownames(FIT) |
| 381 | 1x |
idx <- integer(0L) |
| 382 | ||
| 383 |
# AIC/BIC |
|
| 384 | 1x |
if (all(c("aic", "bic", "bic2") %in% NAMES)) {
|
| 385 | 1x |
this.idx <- match(c("aic", "bic", "bic2"), NAMES)
|
| 386 | 1x |
idx <- c(idx, this.idx) |
| 387 |
} |
|
| 388 | ||
| 389 |
# chi-square |
|
| 390 | 1x |
if (all(c("chisq.scaled", "df.scaled", "pvalue.scaled") %in% NAMES)) {
|
| 391 | ! |
this.idx <- match( |
| 392 | ! |
c("chisq.scaled", "df.scaled", "pvalue.scaled"),
|
| 393 | ! |
NAMES |
| 394 |
) |
|
| 395 | ! |
idx <- c(idx, this.idx) |
| 396 |
} else {
|
|
| 397 | 1x |
this.idx <- match(c("chisq", "df", "pvalue"), NAMES)
|
| 398 | 1x |
idx <- c(idx, this.idx) |
| 399 |
} |
|
| 400 | ||
| 401 |
# CFI |
|
| 402 | 1x |
if ("cfi.robust" %in% NAMES && !all(is.na(FIT["cfi.robust", ]))) {
|
| 403 | ! |
this.idx <- match("cfi.robust", NAMES)
|
| 404 | ! |
idx <- c(idx, this.idx) |
| 405 | 1x |
} else if ("cfi.scaled" %in% NAMES) {
|
| 406 | ! |
this.idx <- match("cfi.scaled", NAMES)
|
| 407 | ! |
idx <- c(idx, this.idx) |
| 408 | 1x |
} else if ("cfi" %in% NAMES) {
|
| 409 | 1x |
this.idx <- match("cfi", NAMES)
|
| 410 | 1x |
idx <- c(idx, this.idx) |
| 411 |
} |
|
| 412 | ||
| 413 |
# RMSEA |
|
| 414 | 1x |
if ("rmsea.robust" %in% NAMES && !all(is.na(FIT["rmsea.robust", ]))) {
|
| 415 | ! |
this.idx <- match("rmsea.robust", NAMES)
|
| 416 | ! |
idx <- c(idx, this.idx) |
| 417 | 1x |
} else if ("rmsea.scaled" %in% NAMES) {
|
| 418 | ! |
this.idx <- match("rmsea.scaled", NAMES)
|
| 419 | ! |
idx <- c(idx, this.idx) |
| 420 | 1x |
} else if ("rmsea" %in% NAMES) {
|
| 421 | 1x |
this.idx <- match("rmsea", NAMES)
|
| 422 | 1x |
idx <- c(idx, this.idx) |
| 423 |
} |
|
| 424 | ||
| 425 |
# table with fitmeasures |
|
| 426 | 1x |
if (length(idx) > 0L) {
|
| 427 | 1x |
Table <- t(FIT[idx, , drop = FALSE]) |
| 428 | 1x |
tmp <- NAMES[idx] |
| 429 |
# strip '.scaled' |
|
| 430 | 1x |
tmp <- gsub(".scaled", "", tmp)
|
| 431 |
# replace 'robust' by 'r' (if any) |
|
| 432 | 1x |
tmp <- gsub(".robust", "", tmp)
|
| 433 |
# rename "bic2" -> "sabic" |
|
| 434 | 1x |
bic2.idx <- which(tmp == "bic2") |
| 435 | 1x |
if (length(bic2.idx) > 0L) {
|
| 436 | 1x |
tmp[bic2.idx] <- "sabic" |
| 437 |
} |
|
| 438 | 1x |
colnames(Table) <- tmp |
| 439 |
} else {
|
|
| 440 | ! |
Table <- matrix(0, nrow = nfactors, ncol = 0L) |
| 441 |
} |
|
| 442 | 1x |
rownames(Table) <- paste("nfactors = ", nfactors, sep = "")
|
| 443 | 1x |
class(Table) <- c("lavaan.matrix", "matrix")
|
| 444 |
} |
|
| 445 | ||
| 446 |
# create return object |
|
| 447 | 1x |
out <- list( |
| 448 | 1x |
lavaan.version = lavaan.version, |
| 449 | 1x |
converged.flag = converged.flag, |
| 450 | 1x |
estimator = estimator, |
| 451 | 1x |
estimator.args = estimator.args, |
| 452 | 1x |
rotation = rotation, |
| 453 | 1x |
rotation.args = rotation.args, |
| 454 | 1x |
lavdata = lavdata, |
| 455 | 1x |
fit.table = Table, |
| 456 | 1x |
nfactors = nfactors, |
| 457 | 1x |
model.list = RES |
| 458 |
) |
|
| 459 | ||
| 460 |
# add nd, cutoff, dot.cutoff, ... as attributes (for printing) |
|
| 461 | 1x |
attr(out, "nd") <- nd |
| 462 | 1x |
attr(out, "cutoff") <- cutoff |
| 463 | 1x |
attr(out, "dot.cutoff") <- dot.cutoff |
| 464 | 1x |
attr(out, "alpha.level") <- alpha.level |
| 465 | ||
| 466 |
# create class |
|
| 467 | 1x |
class(out) <- c("efaList.summary", "list")
|
| 468 | ||
| 469 | 1x |
out |
| 470 |
} |
| 1 |
lav_label_code <- function(label = "", value = "", show = FALSE, |
|
| 2 |
idx.font.size = 20L, dy = 7L, |
|
| 3 |
italic = TRUE, auto.subscript = TRUE) {
|
|
| 4 | ! |
latexsymbols <- c("varepsilon",
|
| 5 | ! |
"Alpha", "Beta", "Gamma", "Delta", "Epsilon", "Zeta", "Eta", "Theta", |
| 6 | ! |
"Iota", "Kappa", "Lambda", "Mu", "Nu", "Xi", "Omicron", "Pi", |
| 7 | ! |
"Rho", "Sigma", "Tau", "Upsilon", "Phi", "Chi", "Psi", "Omega", |
| 8 | ! |
"alpha", "beta", "gamma", "delta", "epsilon", "zeta", "eta", "theta", |
| 9 | ! |
"iota", "kappa", "lambda", "mu", "nu", "xi", "omicron", "pi", |
| 10 | ! |
"rho", "sigma", "tau", "upsilon", "phi", "chi", "psi", "omega" |
| 11 |
) |
|
| 12 | ! |
unicodes <- c("1013",
|
| 13 | ! |
"913", "914", "915", "916", "917", "918", "919", "920", |
| 14 | ! |
"921", "922", "923", "924", "925", "926", "927", "928", |
| 15 | ! |
"929", "931", "932", "933", "934", "935", "936", "937", |
| 16 | ! |
"945", "946", "947", "948", "949", "950", "951", "952", |
| 17 | ! |
"953", "954", "955", "956", "957", "958", "959", "960", |
| 18 | ! |
"961", "963", "964", "965", "966", "967", "968", "969" |
| 19 |
) |
|
| 20 | ! |
if (label == "" && value == "") return(list(svg = "", tikz = "", r = "")) |
| 21 | ! |
if (auto.subscript) {
|
| 22 | ! |
label <- gsub("^([a-zA-Z]+)([0-9]+)", "\\1_\\2", label)
|
| 23 |
} |
|
| 24 | ! |
rexpression <- FALSE |
| 25 | ! |
if (grepl("1van", label)) label <- "1"
|
| 26 | ! |
if (value == "") {
|
| 27 | ! |
splitted <- strsplit(label, "=", fixed = TRUE)[[1L]] |
| 28 | ! |
if (length(splitted) > 1L) {
|
| 29 | ! |
label <- splitted[1L] |
| 30 | ! |
value <- splitted[2L] |
| 31 |
} |
|
| 32 |
} |
|
| 33 | ! |
if (label == "") {
|
| 34 | ! |
label <- value |
| 35 | ! |
value <- "" |
| 36 |
} |
|
| 37 | ! |
svgpart <- tikzpart <- rpart <- character(3) |
| 38 | ! |
rpart[3L] <- tikzpart[3L] <- svgpart[3L] <- value |
| 39 | ! |
if (label != "") {
|
| 40 |
# separate label and value by equal sign |
|
| 41 | ! |
if (svgpart[3L] != "") svgpart[3L] <- paste0("=", svgpart[3L])
|
| 42 | ! |
if (tikzpart[3L] != "") tikzpart[3L] <- paste0("=", tikzpart[3L])
|
| 43 | ! |
if (rpart[3L] != "") {
|
| 44 | ! |
rpart[3L] <- paste0(" == ", rpart[3L])
|
| 45 | ! |
rexpression <- TRUE |
| 46 |
} |
|
| 47 |
# subscript and Greek character set handling |
|
| 48 | ! |
splitunderscore <- strsplit(label, "_", TRUE)[[1L]] |
| 49 | ! |
svgpart[1] <- tikzpart[1] <- rpart[1] <- splitunderscore[1L] |
| 50 | ! |
if (rpart[1] %in% latexsymbols) {
|
| 51 | ! |
rexpression <- TRUE |
| 52 | ! |
svgpart[1] <- paste0("&#", unicodes[latexsymbols == svgpart[1]], ";")
|
| 53 | ! |
tikzpart[1] <- paste0("\\", tikzpart[1])
|
| 54 | ! |
if (rpart[1] == "varepsilon") rpart[1] <- "epsilon" |
| 55 | ! |
rpart[1] <- str2expression(rpart[1]) |
| 56 |
} |
|
| 57 | ! |
if (length(splitunderscore) > 1L) {
|
| 58 | ! |
rexpression <- TRUE |
| 59 | ! |
svgpart[2L] <- paste0("<tspan dy=\"", dy ,"\" font-size=\"",
|
| 60 | ! |
idx.font.size, "\">", splitunderscore[2L], "</tspan>") |
| 61 | ! |
if (svgpart[3L] != "") {
|
| 62 | ! |
svgpart[3L] <- paste0("<tspan dy=\"-", dy, "\">",
|
| 63 | ! |
svgpart[3L], "</tspan>") |
| 64 |
} |
|
| 65 | ! |
tikzpart[2L] <- paste0("_{", splitunderscore[2L], "}")
|
| 66 | ! |
rpart[2L] <- paste0("[\"", splitunderscore[2L], "\"]")
|
| 67 |
} |
|
| 68 | ! |
if (!italic) tikzpart <- c("\\mathrm{", tikzpart, "}")
|
| 69 |
} |
|
| 70 | ! |
if (show) {
|
| 71 | ! |
plot(c(0,3), c(0,2), type = "n") |
| 72 | ! |
if (rexpression) {
|
| 73 | ! |
text(1, 1, str2expression(paste(rpart, collapse = ""))) |
| 74 |
} else {
|
|
| 75 | ! |
text(1, 1, paste(rpart, collapse = ""), font = ifelse(italic, 3L, 1L)) |
| 76 |
} |
|
| 77 |
} |
|
| 78 | ! |
list(svg = paste(svgpart, collapse = ""), |
| 79 | ! |
tikz = paste(c("$", tikzpart, "$"), collapse = ""),
|
| 80 | ! |
r = ifelse(rexpression, |
| 81 | ! |
str2expression(paste(rpart, collapse = "")), |
| 82 | ! |
paste(rpart, collapse = "")) |
| 83 |
) |
|
| 84 |
} |
| 1 |
# the weighted bivariate ordinal/linear model |
|
| 2 |
# YR 08 March 2020 (replacing the old lav_polyserial.R routines) |
|
| 3 |
# |
|
| 4 |
# - polyserial (and biserial) correlations |
|
| 5 |
# - bivariate ordinal/linear regression |
|
| 6 |
# - using sampling weights wt |
|
| 7 | ||
| 8 | ||
| 9 |
# polyserial correlation |
|
| 10 |
# |
|
| 11 |
# Y1 = linear |
|
| 12 |
# Y2 = ordinal |
|
| 13 |
lav_bvmix_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 14 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 15 |
Y1.name = NULL, Y2.name = NULL, |
|
| 16 |
optim.method = "nlminb1", # 0.6-7 |
|
| 17 |
optim.scale = 1.0, |
|
| 18 |
init.theta = NULL, |
|
| 19 |
control = list()) {
|
|
| 20 | 80x |
if (is.null(fit.y1)) {
|
| 21 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 22 |
} |
|
| 23 | 80x |
if (is.null(fit.y2)) {
|
| 24 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 25 |
} |
|
| 26 | ||
| 27 |
# create cache environment |
|
| 28 | 80x |
cache <- lav_bvmix_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt) |
| 29 | ||
| 30 |
# optim.method |
|
| 31 | 80x |
minObjective <- lav_bvmix_min_objective |
| 32 | 80x |
minGradient <- lav_bvmix_min_gradient |
| 33 | 80x |
minHessian <- lav_bvmix_min_hessian |
| 34 | 80x |
if (optim.method == "nlminb" || optim.method == "nlminb2") {
|
| 35 |
# nothing to do |
|
| 36 | 80x |
} else if (optim.method == "nlminb0") {
|
| 37 | ! |
minGradient <- minHessian <- NULL |
| 38 | 80x |
} else if (optim.method == "nlminb1") {
|
| 39 | 80x |
minHessian <- NULL |
| 40 |
} |
|
| 41 | ||
| 42 |
# optimize |
|
| 43 | 80x |
if (is.null(control$trace)) {
|
| 44 | 80x |
control$trace <- ifelse(lav_verbose(), 1, 0) |
| 45 |
} |
|
| 46 | ||
| 47 |
# init theta? |
|
| 48 | 80x |
if (!is.null(init.theta)) {
|
| 49 | ! |
start.x <- init.theta |
| 50 |
} else {
|
|
| 51 | 80x |
start.x <- cache$theta |
| 52 |
} |
|
| 53 | ||
| 54 |
# try 1 |
|
| 55 | 80x |
optim <- nlminb( |
| 56 | 80x |
start = start.x, objective = minObjective, |
| 57 | 80x |
gradient = minGradient, hessian = minHessian, |
| 58 | 80x |
control = control, |
| 59 | 80x |
scale = optim.scale, lower = -0.995, upper = +0.995, |
| 60 | 80x |
cache = cache |
| 61 |
) |
|
| 62 | ||
| 63 |
# try 2 |
|
| 64 | 80x |
if (optim$convergence != 0L) {
|
| 65 | ! |
optim <- nlminb( |
| 66 | ! |
start = start.x, objective = minObjective, |
| 67 | ! |
gradient = NULL, hessian = NULL, |
| 68 | ! |
control = control, |
| 69 | ! |
scale = optim.scale, lower = -0.995, upper = +0.995, |
| 70 | ! |
cache = cache |
| 71 |
) |
|
| 72 |
} |
|
| 73 | ||
| 74 |
# try 3 |
|
| 75 | 80x |
if (optim$convergence != 0L) {
|
| 76 | ! |
optim <- nlminb( |
| 77 | ! |
start = 0, objective = minObjective, |
| 78 | ! |
gradient = NULL, hessian = NULL, |
| 79 | ! |
control = control, |
| 80 | ! |
scale = 10, lower = -0.995, upper = +0.995, |
| 81 | ! |
cache = cache |
| 82 |
) |
|
| 83 |
} |
|
| 84 | ||
| 85 |
# try 4 -- new in 0.6-8 |
|
| 86 | 80x |
if (optim$convergence != 0L) {
|
| 87 | ! |
optim <- optimize( |
| 88 | ! |
f = minObjective, interval = c(-0.995, +0.995), |
| 89 | ! |
cache = cache, tol = .Machine$double.eps |
| 90 |
) |
|
| 91 | ! |
if (is.finite(optim$minimum)) {
|
| 92 | ! |
optim$convergence <- 0L |
| 93 | ! |
optim$par <- optim$minimum |
| 94 |
} |
|
| 95 |
} |
|
| 96 | ||
| 97 |
# check convergence |
|
| 98 | 80x |
if (optim$convergence != 0L) {
|
| 99 | ! |
if (!is.null(Y1.name) && !is.null(Y2.name)) {
|
| 100 | ! |
lav_msg_warn(gettextf( |
| 101 | ! |
"estimation polyserial correlation did not converge |
| 102 | ! |
for variables %1$s and %2$s", Y1.name, Y2.name)) |
| 103 |
} else {
|
|
| 104 | ! |
lav_msg_warn(gettext( |
| 105 | ! |
"estimation polyserial correlation(s) did not always converge")) |
| 106 |
} |
|
| 107 | ! |
rho <- cache$theta # starting value |
| 108 |
} else {
|
|
| 109 | 80x |
rho <- optim$par |
| 110 |
} |
|
| 111 | ||
| 112 | 80x |
rho |
| 113 |
} |
|
| 114 | ||
| 115 | ||
| 116 |
# Y1 = linear |
|
| 117 |
# Y2 = ordinal |
|
| 118 |
lav_bvmix_init_cache <- function(fit.y1 = NULL, |
|
| 119 |
fit.y2 = NULL, |
|
| 120 |
wt = NULL, |
|
| 121 |
scores = FALSE, |
|
| 122 |
parent = parent.frame()) {
|
|
| 123 |
# data |
|
| 124 | 160x |
Y1 <- fit.y1$y |
| 125 | 160x |
Y2 <- fit.y2$y |
| 126 | 160x |
eXo <- fit.y1$X |
| 127 | ||
| 128 |
# extract parameters |
|
| 129 | ||
| 130 |
# Y1 |
|
| 131 | 160x |
y1.VAR <- fit.y1$theta[fit.y1$var.idx] |
| 132 | 160x |
y1.SD <- sqrt(y1.VAR) |
| 133 | 160x |
y1.ETA <- fit.y1$yhat |
| 134 | 160x |
Z <- (Y1 - y1.ETA) / y1.SD |
| 135 | ||
| 136 |
# Y2 |
|
| 137 | 160x |
th.y2 <- fit.y2$theta[fit.y2$th.idx] |
| 138 | ||
| 139 |
# exo? |
|
| 140 | 160x |
if (is.null(eXo)) {
|
| 141 | ! |
nexo <- 0L |
| 142 |
} else {
|
|
| 143 | 160x |
nexo <- ncol(eXo) |
| 144 |
} |
|
| 145 | ||
| 146 |
# nobs |
|
| 147 | 160x |
if (is.null(wt)) {
|
| 148 | 160x |
N <- length(Y1) |
| 149 |
} else {
|
|
| 150 | ! |
N <- sum(wt) |
| 151 |
} |
|
| 152 | ||
| 153 |
# starting value -- Olsson 1982 eq 38 |
|
| 154 | 160x |
if (nexo > 0L) {
|
| 155 |
# exo |
|
| 156 | 160x |
if (is.null(wt)) {
|
| 157 | 160x |
COR <- cor(Z, Y2, use = "pairwise.complete.obs") |
| 158 | 160x |
SD <- sd(Y2, na.rm = TRUE) * sqrt((N - 1) / N) |
| 159 |
} else {
|
|
| 160 | ! |
tmp <- na.omit(cbind(Z, Y2, wt)) |
| 161 | ! |
COR <- cov.wt(x = tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1] |
| 162 | ! |
SD <- sqrt(lav_matrix_var_wt(tmp[, 2], wt = tmp[, 3])) |
| 163 |
} |
|
| 164 | 160x |
rho.init <- (COR * SD / sum(dnorm(th.y2))) |
| 165 |
} else {
|
|
| 166 |
# no exo |
|
| 167 | ! |
if (is.null(wt)) {
|
| 168 | ! |
COR <- cor(Y1, Y2, use = "pairwise.complete.obs") |
| 169 | ! |
SD <- sd(Y2, na.rm = TRUE) * sqrt((N - 1) / N) |
| 170 |
} else {
|
|
| 171 | ! |
tmp <- na.omit(cbind(Y1, Y2, wt)) |
| 172 | ! |
COR <- cov.wt(x = tmp[, 1:2], wt = tmp[, 3], cor = TRUE)$cor[2, 1] |
| 173 | ! |
SD <- sqrt(lav_matrix_var_wt(tmp[, 2], wt = tmp[, 3])) |
| 174 |
} |
|
| 175 | ! |
rho.init <- (COR * SD / sum(dnorm(th.y2))) |
| 176 |
} |
|
| 177 | ||
| 178 |
# sanity check |
|
| 179 | 160x |
if (is.na(rho.init)) {
|
| 180 | ! |
rho.init <- 0.0 |
| 181 | 160x |
} else if (abs(rho.init) > 0.9) {
|
| 182 | ! |
rho.init <- rho.init / 2 |
| 183 |
} |
|
| 184 | ||
| 185 |
# parameter vector |
|
| 186 | 160x |
theta <- rho.init # only |
| 187 | ||
| 188 |
# different cache if scores or not |
|
| 189 | 160x |
if (scores) {
|
| 190 | 80x |
out <- list2env( |
| 191 | 80x |
list( |
| 192 | 80x |
nexo = nexo, theta = theta, N = N, |
| 193 | 80x |
y1.VAR = y1.VAR, eXo = eXo, |
| 194 | 80x |
y2.Y1 = fit.y2$Y1, y2.Y2 = fit.y2$Y2, |
| 195 | 80x |
Y1 = Y1, y1.SD = y1.SD, y1.ETA = y1.ETA, Z = Z, |
| 196 | 80x |
fit.y2.z1 = fit.y2$z1, fit.y2.z2 = fit.y2$z2 |
| 197 |
), |
|
| 198 | 80x |
parent = parent |
| 199 |
) |
|
| 200 |
} else {
|
|
| 201 | 80x |
out <- list2env( |
| 202 | 80x |
list( |
| 203 | 80x |
nexo = nexo, theta = theta, N = N, |
| 204 | 80x |
Y1 = Y1, y1.SD = y1.SD, y1.ETA = y1.ETA, Z = Z, |
| 205 | 80x |
fit.y2.z1 = fit.y2$z1, fit.y2.z2 = fit.y2$z2 |
| 206 |
), |
|
| 207 | 80x |
parent = parent |
| 208 |
) |
|
| 209 |
} |
|
| 210 | ||
| 211 | 160x |
out |
| 212 |
} |
|
| 213 | ||
| 214 | ||
| 215 |
# casewise likelihoods, unweighted! |
|
| 216 |
lav_bvmix_lik_cache <- function(cache = NULL) {
|
|
| 217 | 478x |
with(cache, {
|
| 218 | 478x |
rho <- theta[1L] |
| 219 | 478x |
R <- sqrt(1 - rho * rho) |
| 220 | ||
| 221 |
# p(Y2|Y1) |
|
| 222 | 478x |
tauj.star <- (fit.y2.z1 - rho * Z) / R |
| 223 | 478x |
tauj1.star <- (fit.y2.z2 - rho * Z) / R |
| 224 | 478x |
py2y1 <- pnorm(tauj.star) - pnorm(tauj1.star) |
| 225 |
# TODO, check when to use 1 - pnorm() |
|
| 226 | 478x |
py2y1[py2y1 < .Machine$double.eps] <- .Machine$double.eps |
| 227 | ||
| 228 |
# p(Y1) |
|
| 229 | 478x |
py1 <- dnorm(Y1, mean = y1.ETA, sd = y1.SD) |
| 230 | ||
| 231 |
# lik |
|
| 232 | 478x |
lik <- py1 * py2y1 |
| 233 | ||
| 234 |
# catch very small values |
|
| 235 | 478x |
lik.toosmall.idx <- which(lik < sqrt(.Machine$double.eps)) |
| 236 | 478x |
lik[lik.toosmall.idx] <- as.numeric(NA) |
| 237 | ||
| 238 | 478x |
return(lik) |
| 239 |
}) |
|
| 240 |
} |
|
| 241 | ||
| 242 |
lav_bvmix_logl_cache <- function(cache = NULL) {
|
|
| 243 | 478x |
with(cache, {
|
| 244 | 478x |
lik <- lav_bvmix_lik_cache(cache) # unweighted! |
| 245 | ||
| 246 | 478x |
if (!is.null(wt)) {
|
| 247 | ! |
logl <- sum(wt * log(lik), na.rm = TRUE) |
| 248 |
} else {
|
|
| 249 | 478x |
logl <- sum(log(lik), na.rm = TRUE) |
| 250 |
} |
|
| 251 | ||
| 252 | 478x |
return(logl) |
| 253 |
}) |
|
| 254 |
} |
|
| 255 | ||
| 256 |
lav_bvmix_gradient_cache <- function(cache = NULL) {
|
|
| 257 | 388x |
with(cache, {
|
| 258 | 388x |
rho <- theta[1L] |
| 259 | ||
| 260 | 388x |
y.Z1 <- dnorm(tauj.star) |
| 261 | 388x |
y.Z2 <- dnorm(tauj1.star) |
| 262 | 388x |
pyx.inv.R3 <- 1 / (py2y1 * R * R * R) |
| 263 | ||
| 264 |
# rho |
|
| 265 | 388x |
d1 <- fit.y2.z1 * rho - Z |
| 266 | 388x |
d2 <- fit.y2.z2 * rho - Z |
| 267 | 388x |
dx <- pyx.inv.R3 * (y.Z1 * d1 - y.Z2 * d2) |
| 268 | ||
| 269 |
# to be consistent with (log)lik_cache |
|
| 270 | 388x |
if (length(lik.toosmall.idx) > 0L) {
|
| 271 | 84x |
dx[lik.toosmall.idx] <- as.numeric(NA) |
| 272 |
} |
|
| 273 | ||
| 274 | 388x |
if (is.null(wt)) {
|
| 275 | 388x |
dx.rho <- sum(dx, na.rm = TRUE) |
| 276 |
} else {
|
|
| 277 | ! |
dx.rho <- sum(wt * dx, na.rm = TRUE) |
| 278 |
} |
|
| 279 | ||
| 280 | 388x |
return(dx.rho) |
| 281 |
}) |
|
| 282 |
} |
|
| 283 | ||
| 284 |
# YR 29 March 2020 |
|
| 285 |
# obtained by using 'Deriv' (from package Deriv) on the |
|
| 286 |
# gradient function, and cleaning up |
|
| 287 |
# correct, but not good enough |
|
| 288 |
lav_bvmix_hessian_cache <- function(cache = NULL) {
|
|
| 289 | ! |
with(cache, {
|
| 290 | ! |
rho <- theta[1L] |
| 291 | ! |
R2 <- R * R |
| 292 | ||
| 293 | ! |
t1 <- Z - rho * tauj.star / R |
| 294 | ! |
t2 <- Z - rho * tauj1.star / R |
| 295 | ||
| 296 | ! |
tmp <- (y.Z1 * (d1 * ((3 * rho / R2) + tauj.star * t1 / R) |
| 297 | ! |
+ fit.y2.z1 + dx * R2 * t1) |
| 298 | ||
| 299 | ! |
- y.Z2 * (d2 * ((3 * rho / R2) + tauj1.star * t2 / R) |
| 300 | ! |
+ fit.y2.z2 + dx * R2 * t2) |
| 301 |
) |
|
| 302 | ||
| 303 |
# to be consistent with (log)lik_cache |
|
| 304 | ! |
if (length(lik.toosmall.idx) > 0L) {
|
| 305 | ! |
tmp[lik.toosmall.idx] <- as.numeric(NA) |
| 306 |
} |
|
| 307 | ||
| 308 | ! |
if (is.null(wt)) {
|
| 309 | ! |
H <- sum(tmp * pyx.inv.R3, na.rm = TRUE) |
| 310 |
} else {
|
|
| 311 | ! |
H <- sum(wt * (tmp * pyx.inv.R3), na.rm = TRUE) |
| 312 |
} |
|
| 313 | ! |
dim(H) <- c(1L, 1L) # for nlminb |
| 314 | ||
| 315 | ! |
return(H) |
| 316 |
}) |
|
| 317 |
} |
|
| 318 | ||
| 319 |
# compute total (log)likelihood, for specific 'x' (nlminb) |
|
| 320 |
lav_bvmix_min_objective <- function(x, cache = NULL) {
|
|
| 321 | 478x |
cache$theta <- x |
| 322 | 478x |
-1 * lav_bvmix_logl_cache(cache = cache) / cache$N |
| 323 |
} |
|
| 324 | ||
| 325 |
# compute gradient, for specific 'x' (nlminb) |
|
| 326 |
lav_bvmix_min_gradient <- function(x, cache = NULL) {
|
|
| 327 |
# check if x has changed |
|
| 328 | 388x |
if (!all(x == cache$theta)) {
|
| 329 | ! |
cache$theta <- x |
| 330 | ! |
tmp <- lav_bvmix_logl_cache(cache = cache) |
| 331 |
} |
|
| 332 | 388x |
-1 * lav_bvmix_gradient_cache(cache = cache) / cache$N |
| 333 |
} |
|
| 334 | ||
| 335 |
# compute hessian, for specific 'x' (nlminb) |
|
| 336 |
lav_bvmix_min_hessian <- function(x, cache = NULL) {
|
|
| 337 |
# check if x has changed |
|
| 338 | ! |
if (!all(x == cache$theta)) {
|
| 339 | ! |
tmp <- lav_bvmix_logl_cache(cache = cache) |
| 340 | ! |
tmp <- lav_bvmix_gradient_cache(cache = cache) |
| 341 |
} |
|
| 342 | ! |
-1 * lav_bvmix_hessian_cache(cache = cache) / cache$N |
| 343 |
} |
|
| 344 | ||
| 345 | ||
| 346 |
lav_bvmix_cor_scores_cache <- function(cache = NULL, |
|
| 347 |
sigma.correction = FALSE, |
|
| 348 |
na.zero = FALSE) {
|
|
| 349 | 80x |
with(cache, {
|
| 350 | 80x |
rho <- theta[1L] |
| 351 | 80x |
R <- sqrt(1 - rho * rho) |
| 352 | ||
| 353 | 80x |
tauj.star <- (fit.y2.z1 - rho * Z) / R |
| 354 | 80x |
tauj1.star <- (fit.y2.z2 - rho * Z) / R |
| 355 | 80x |
y.Z1 <- dnorm(tauj.star) |
| 356 | 80x |
y.Z2 <- dnorm(tauj1.star) |
| 357 | ||
| 358 |
# p(Y2|Y1) |
|
| 359 | 80x |
py2y1 <- pnorm(tauj.star) - pnorm(tauj1.star) |
| 360 | 80x |
py2y1[py2y1 < .Machine$double.eps] <- .Machine$double.eps |
| 361 | 80x |
pyx.inv <- 1 / py2y1 |
| 362 | ||
| 363 |
# mu.y1 |
|
| 364 | 80x |
y.Z1.y.Z2 <- y.Z1 - y.Z2 |
| 365 | 80x |
dx.mu.y1 <- 1 / y1.SD * (Z + (pyx.inv * (rho / R) * y.Z1.y.Z2)) |
| 366 | 80x |
if (!is.null(wt)) {
|
| 367 | ! |
dx.mu.y1 <- wt * dx.mu.y1 |
| 368 |
} |
|
| 369 | ||
| 370 |
# var.y1 |
|
| 371 | 80x |
dx.var.y1 <- 1 / (2 * y1.VAR) * (((Z * Z) - 1) + |
| 372 | 80x |
(pyx.inv * rho * Z / R) * y.Z1.y.Z2) |
| 373 | 80x |
if (!is.null(wt)) {
|
| 374 | ! |
dx.var.y1 <- wt * dx.var.y1 |
| 375 |
} |
|
| 376 | ||
| 377 |
# th.y2 |
|
| 378 | 80x |
dx.th.y2 <- (y2.Y1 * y.Z1 - y2.Y2 * y.Z2) * 1 / R * pyx.inv |
| 379 | 80x |
if (!is.null(wt)) {
|
| 380 | ! |
dx.th.y2 <- wt * dx.th.y2 |
| 381 |
} |
|
| 382 | ||
| 383 |
# sl.y1 |
|
| 384 | 80x |
dx.sl.y1 <- NULL |
| 385 | 80x |
if (nexo > 0L) {
|
| 386 | 80x |
dx.sl.y1 <- dx.mu.y1 * eXo |
| 387 |
# if(!is.null(wt)) {
|
|
| 388 |
# dx.mu.y1 had already been weighted |
|
| 389 |
# } |
|
| 390 |
} |
|
| 391 | ||
| 392 |
# sl.y2 |
|
| 393 | 80x |
dx.sl.y2 <- NULL |
| 394 | 80x |
if (nexo > 0L) {
|
| 395 | 80x |
dx.sl.y2 <- (y.Z2 - y.Z1) * eXo * 1 / R * pyx.inv |
| 396 | 80x |
if (!is.null(wt)) {
|
| 397 | ! |
dx.sl.y2 <- wt * dx.sl.y2 |
| 398 |
} |
|
| 399 |
} |
|
| 400 | ||
| 401 |
# rho |
|
| 402 | 80x |
TAUj <- y.Z1 * (fit.y2.z1 * rho - Z) |
| 403 | 80x |
TAUj1 <- y.Z2 * (fit.y2.z2 * rho - Z) |
| 404 | 80x |
dx.rho <- pyx.inv * 1 / (R * R * R) * (TAUj - TAUj1) |
| 405 | 80x |
if (!is.null(wt)) {
|
| 406 | ! |
dx.rho <- wt * dx.rho |
| 407 |
} |
|
| 408 | ||
| 409 |
# FIXME: only tested for non_exo! |
|
| 410 |
# used by lav_pml_dploglik_dimplied() |
|
| 411 | 80x |
if (sigma.correction) {
|
| 412 | ! |
dx.rho.orig <- dx.rho |
| 413 | ! |
dx.var.y1.orig <- dx.var.y1 |
| 414 | ||
| 415 |
# sigma |
|
| 416 | ! |
dx.rho <- dx.rho.orig / y1.SD |
| 417 | ||
| 418 |
# var |
|
| 419 | ! |
COV <- rho * y1.SD |
| 420 | ! |
dx.var.y1 <- (dx.var.y1.orig - |
| 421 | ! |
1 / 2 * COV / y1.VAR * 1 / y1.SD * dx.rho.orig) |
| 422 |
} |
|
| 423 | ||
| 424 | 80x |
out <- list( |
| 425 | 80x |
dx.mu.y1 = dx.mu.y1, dx.var.y1 = dx.var.y1, |
| 426 | 80x |
dx.th.y2 = dx.th.y2, |
| 427 | 80x |
dx.sl.y1 = dx.sl.y1, dx.sl.y2 = dx.sl.y2, |
| 428 | 80x |
dx.rho = dx.rho |
| 429 |
) |
|
| 430 | ||
| 431 | 80x |
return(out) |
| 432 |
}) |
|
| 433 |
} |
|
| 434 | ||
| 435 | ||
| 436 |
# casewise scores |
|
| 437 |
# |
|
| 438 |
# Y1 = linear |
|
| 439 |
# Y2 = ordinal |
|
| 440 |
lav_bvmix_cor_scores <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 441 |
rho = NULL, |
|
| 442 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 443 |
evar.y1 = NULL, beta.y1 = NULL, |
|
| 444 |
th.y2 = NULL, sl.y2 = NULL, |
|
| 445 |
sigma.correction = FALSE, |
|
| 446 |
na.zero = FALSE) {
|
|
| 447 | 80x |
if (is.null(fit.y1)) {
|
| 448 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 449 |
} |
|
| 450 | 80x |
if (is.null(fit.y2)) {
|
| 451 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 452 |
} |
|
| 453 | ||
| 454 |
# update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R) |
|
| 455 | 80x |
fit.y1 <- lav_uvreg_update_fit( |
| 456 | 80x |
fit.y = fit.y1, evar.new = evar.y1, |
| 457 | 80x |
beta.new = beta.y1 |
| 458 |
) |
|
| 459 | 80x |
fit.y2 <- lav_uvord_update_fit( |
| 460 | 80x |
fit.y = fit.y2, th.new = th.y2, |
| 461 | 80x |
sl.new = sl.y2 |
| 462 |
) |
|
| 463 | ||
| 464 |
# create cache environment |
|
| 465 | 80x |
cache <- lav_bvmix_init_cache( |
| 466 | 80x |
fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt, |
| 467 | 80x |
scores = TRUE |
| 468 |
) |
|
| 469 | 80x |
cache$theta <- rho |
| 470 | ||
| 471 | 80x |
SC <- lav_bvmix_cor_scores_cache( |
| 472 | 80x |
cache = cache, |
| 473 | 80x |
sigma.correction = sigma.correction, |
| 474 | 80x |
na.zero = na.zero |
| 475 |
) |
|
| 476 | ||
| 477 | 80x |
SC |
| 478 |
} |
|
| 479 | ||
| 480 |
# logl - no cache |
|
| 481 |
lav_bvmix_logl <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 482 |
rho = NULL, |
|
| 483 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 484 |
evar.y1 = NULL, beta.y1 = NULL, |
|
| 485 |
th.y2 = NULL, sl.y2 = NULL) {
|
|
| 486 | ! |
if (is.null(fit.y1)) {
|
| 487 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 488 |
} |
|
| 489 | ! |
if (is.null(fit.y2)) {
|
| 490 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 491 |
} |
|
| 492 | ||
| 493 |
# update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R) |
|
| 494 | ! |
fit.y1 <- lav_uvreg_update_fit( |
| 495 | ! |
fit.y = fit.y1, evar.new = evar.y1, |
| 496 | ! |
beta.new = beta.y1 |
| 497 |
) |
|
| 498 | ! |
fit.y2 <- lav_uvord_update_fit( |
| 499 | ! |
fit.y = fit.y2, th.new = th.y2, |
| 500 | ! |
sl.new = sl.y2 |
| 501 |
) |
|
| 502 | ||
| 503 |
# create cache environment |
|
| 504 | ! |
cache <- lav_bvmix_init_cache( |
| 505 | ! |
fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt, |
| 506 | ! |
scores = TRUE |
| 507 |
) |
|
| 508 | ! |
cache$theta <- rho |
| 509 | ||
| 510 | ! |
lav_bvmix_logl_cache(cache = cache) |
| 511 |
} |
|
| 512 | ||
| 513 |
# lik - no cache |
|
| 514 |
lav_bvmix_lik <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 515 |
rho = NULL, |
|
| 516 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 517 |
evar.y1 = NULL, beta.y1 = NULL, |
|
| 518 |
th.y2 = NULL, sl.y2 = NULL, |
|
| 519 |
.log = FALSE) {
|
|
| 520 | ! |
if (is.null(fit.y1)) {
|
| 521 | ! |
fit.y1 <- lav_uvreg_fit(y = Y1, X = eXo, wt = wt) |
| 522 |
} |
|
| 523 | ! |
if (is.null(fit.y2)) {
|
| 524 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 525 |
} |
|
| 526 | ||
| 527 |
# update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R) |
|
| 528 | ! |
fit.y1 <- lav_uvreg_update_fit( |
| 529 | ! |
fit.y = fit.y1, evar.new = evar.y1, |
| 530 | ! |
beta.new = beta.y1 |
| 531 |
) |
|
| 532 | ! |
fit.y2 <- lav_uvord_update_fit( |
| 533 | ! |
fit.y = fit.y2, th.new = th.y2, |
| 534 | ! |
sl.new = sl.y2 |
| 535 |
) |
|
| 536 | ||
| 537 |
# create cache environment |
|
| 538 | ! |
cache <- lav_bvmix_init_cache( |
| 539 | ! |
fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt, |
| 540 | ! |
scores = TRUE |
| 541 |
) |
|
| 542 | ! |
cache$theta <- rho |
| 543 | ||
| 544 | ! |
lik <- lav_bvmix_lik_cache(cache = cache) # unweighted |
| 545 | ! |
if (.log) {
|
| 546 | ! |
lik <- log(lik) |
| 547 |
} |
|
| 548 | ||
| 549 | ! |
if (!is.null(wt)) {
|
| 550 | ! |
if (.log) {
|
| 551 | ! |
lik <- wt * lik |
| 552 |
} else {
|
|
| 553 | ! |
tmp <- wt * log(lik) |
| 554 | ! |
lik <- exp(tmp) |
| 555 |
} |
|
| 556 |
} |
|
| 557 | ||
| 558 | ! |
lik |
| 559 |
} |
| 1 |
# lav_model utility functions |
|
| 2 | ||
| 3 |
# initial version: YR 25/03/2009: `methods' for the Model class |
|
| 4 |
# - YR 14 Jan 2014: rename object -> lavmodel, all functions as lav_model_* |
|
| 5 |
# - YR 20 Nov 2021: add lav_model_dmmdpar |
|
| 6 | ||
| 7 |
lav_model_get_parameters <- function(lavmodel = NULL, GLIST = NULL, |
|
| 8 |
type = "free", extra = TRUE) {
|
|
| 9 |
# type == "free": only non-redundant free parameters (x) |
|
| 10 |
# type == "user": all parameters listed in User model |
|
| 11 | ||
| 12 |
# state or final? |
|
| 13 | 2309x |
if (is.null(GLIST)) GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message |
| 14 | ||
| 15 | 2915x |
if (type == "free") {
|
| 16 | 727x |
N <- lavmodel@nx.free |
| 17 |
# } else if(type == "unco") {
|
|
| 18 |
# N <- lavmodel@nx.unco |
|
| 19 | 2188x |
} else if (type == "user") {
|
| 20 | 2188x |
N <- lavmodel@nx.user |
| 21 |
} |
|
| 22 | 2915x |
x <- numeric(N) |
| 23 | ||
| 24 | 2915x |
for (mm in 1:length(lavmodel@GLIST)) {
|
| 25 | 16615x |
if (type == "free") {
|
| 26 | 4784x |
m.idx <- lavmodel@m.free.idx[[mm]] |
| 27 | 4784x |
x.idx <- lavmodel@x.free.idx[[mm]] |
| 28 |
# } else if(type == "unco") {
|
|
| 29 |
# m.idx <- lavmodel@m.unco.idx[[mm]] |
|
| 30 |
# x.idx <- lavmodel@x.unco.idx[[mm]] |
|
| 31 | 11831x |
} else if (type == "user") {
|
| 32 | 11831x |
m.idx <- lavmodel@m.user.idx[[mm]] |
| 33 | 11831x |
x.idx <- lavmodel@x.user.idx[[mm]] |
| 34 |
} |
|
| 35 | 16615x |
x[x.idx] <- GLIST[[mm]][m.idx] |
| 36 |
} |
|
| 37 | ||
| 38 | 2915x |
if (type == "user" && extra && sum( |
| 39 | 2915x |
lavmodel@x.def.idx, |
| 40 | 2915x |
lavmodel@x.ceq.idx, |
| 41 | 2915x |
lavmodel@x.cin.idx |
| 42 | 2915x |
) > 0L) {
|
| 43 |
# we need 'free' x |
|
| 44 | 498x |
x.free <- lav_model_get_parameters( |
| 45 | 498x |
lavmodel = lavmodel, GLIST = GLIST, |
| 46 | 498x |
type = "free" |
| 47 |
) |
|
| 48 | 498x |
if (length(lavmodel@x.def.idx) > 0L) {
|
| 49 | 86x |
x[lavmodel@x.def.idx] <- lavmodel@def.function(x.free) |
| 50 |
} |
|
| 51 | 498x |
if (length(lavmodel@x.ceq.idx) > 0L) {
|
| 52 | 398x |
x[lavmodel@x.ceq.idx] <- lavmodel@ceq.function(x.free) |
| 53 |
} |
|
| 54 | 498x |
if (length(lavmodel@x.cin.idx) > 0L) {
|
| 55 | 14x |
tmp <- lavmodel@cin.function(x.free) |
| 56 |
# remove lower/upper bound values (if any) |
|
| 57 | 14x |
bound.idx <- attr(tmp, "bound.idx") |
| 58 | 14x |
if (length(bound.idx) > 0L) {
|
| 59 | ! |
tmp <- tmp[-bound.idx] |
| 60 |
} |
|
| 61 | 14x |
x[lavmodel@x.cin.idx] <- tmp |
| 62 |
} |
|
| 63 |
} |
|
| 64 | ||
| 65 | 2915x |
x |
| 66 |
} |
|
| 67 | ||
| 68 |
# warning: this will make a copy of lavmodel |
|
| 69 |
# warning: if categorical/correlation: 'delta' parameterization does |
|
| 70 |
# not work properly if we have 'mediators' (where x is not fixed) |
|
| 71 |
# that are observed (residuals are in PSI, and are not additive) |
|
| 72 |
# Note: fixed in 0.6-20 for recursive models |
|
| 73 |
lav_model_set_parameters <- function(lavmodel = NULL, x = NULL) {
|
|
| 74 | 3372x |
tmp <- lavmodel@GLIST |
| 75 | 3372x |
for (mm in 1:length(lavmodel@GLIST)) {
|
| 76 | 14792x |
m.free.idx <- lavmodel@m.free.idx[[mm]] |
| 77 | 14792x |
x.free.idx <- lavmodel@x.free.idx[[mm]] |
| 78 | 14792x |
tmp[[mm]][m.free.idx] <- x[x.free.idx] |
| 79 |
} |
|
| 80 | ||
| 81 | 3372x |
correlation <- lavmodel@correlation |
| 82 | ||
| 83 |
# categorical? set categorical theta elements (if any) |
|
| 84 | 3372x |
if (lavmodel@categorical || correlation) {
|
| 85 | 108x |
nmat <- lavmodel@nmat |
| 86 | 108x |
if (lavmodel@representation == "LISREL") {
|
| 87 | 108x |
for (g in 1:lavmodel@nblocks) {
|
| 88 |
# which mm belong to group g? |
|
| 89 | 108x |
mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g] |
| 90 | ||
| 91 | 108x |
if (lavmodel@estimator %in% c( |
| 92 | 108x |
"ML", "WLS", "GLS", "DWLS", "ULS", "PML", |
| 93 | 108x |
"catML" |
| 94 |
)) {
|
|
| 95 | 108x |
if (lavmodel@parameterization == "delta") {
|
| 96 | 108x |
tmp[mm.in.group] <- |
| 97 | 108x |
lav_lisrel_residual_variances( |
| 98 | 108x |
MLIST = tmp[mm.in.group], |
| 99 | 108x |
num.idx = lavmodel@num.idx[[g]], |
| 100 | 108x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 101 | 108x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]] |
| 102 |
) |
|
| 103 | ! |
} else if (lavmodel@parameterization == "theta") {
|
| 104 | ! |
tmp[mm.in.group] <- |
| 105 | ! |
lav_lisrel_delta( |
| 106 | ! |
MLIST = tmp[mm.in.group], |
| 107 | ! |
num.idx = lavmodel@num.idx[[g]] |
| 108 |
) |
|
| 109 |
} |
|
| 110 | ! |
} else if (lavmodel@estimator %in% c("MML", "FML")) {
|
| 111 |
# ttt <- diag(tmp[mm.in.group]$theta) |
|
| 112 |
# diag(tmp[mm.in.group]$theta) <- as.numeric(NA) |
|
| 113 |
# if(length(lavmodel@num.idx[[g]]) > 0L) {
|
|
| 114 |
# diag(tmp[mm.in.group]$theta)[ lavmodel@num.idx[[g]] ] <- |
|
| 115 |
# ttt[ lavmodel@num.idx[[g]] ] |
|
| 116 |
# } |
|
| 117 |
} |
|
| 118 |
} |
|
| 119 |
} else {
|
|
| 120 | ! |
cat("FIXME: deal with theta elements in the categorical case (RAM)")
|
| 121 |
} |
|
| 122 |
} |
|
| 123 | ||
| 124 | 3372x |
if (lavmodel@composites) {
|
| 125 |
# for package stdmod only! (vignette stdmod_lavaan uses old fit object) |
|
| 126 |
#if (.hasSlot(lavmodel, "composites") && lavmodel@composites) {
|
|
| 127 | ! |
nmat <- lavmodel@nmat |
| 128 | ! |
if (lavmodel@representation == "LISREL") {
|
| 129 | ! |
for (g in 1:lavmodel@nblocks) {
|
| 130 |
# which mm belong to group g? |
|
| 131 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g] |
| 132 | ||
| 133 | ! |
tmp[mm.in.group] <- |
| 134 | ! |
lav_lisrel_composites_variances(MLIST = tmp[mm.in.group]) |
| 135 |
} |
|
| 136 |
} else {
|
|
| 137 | ! |
cat("FIXME: deal with Composites if representation = RAM")
|
| 138 |
} |
|
| 139 |
} |
|
| 140 | ||
| 141 | 3372x |
lavmodel@GLIST <- tmp |
| 142 | ||
| 143 | 3372x |
lavmodel |
| 144 |
} |
|
| 145 | ||
| 146 |
# create a standalone GLIST, filled with (new) x values |
|
| 147 |
# (avoiding a copy of lavmodel) |
|
| 148 |
lav_model_x2glist <- function(lavmodel = NULL, x = NULL, |
|
| 149 |
type = "free", setDelta = TRUE, |
|
| 150 |
m.el.idx = NULL, x.el.idx = NULL) {
|
|
| 151 | 14632x |
correlation <- lavmodel@correlation |
| 152 | ||
| 153 | 14632x |
GLIST <- lavmodel@GLIST |
| 154 | 14632x |
for (mm in 1:length(GLIST)) {
|
| 155 |
# skip empty matrix |
|
| 156 | 121774x |
if (nrow(GLIST[[mm]]) == 0L) {
|
| 157 | 4262x |
next |
| 158 |
} |
|
| 159 | 117512x |
if (type == "free") {
|
| 160 | 117512x |
M.EL.IDX <- lavmodel@m.free.idx[[mm]] |
| 161 | 117512x |
X.EL.IDX <- lavmodel@x.free.idx[[mm]] |
| 162 | ! |
} else if (type == "unco") {
|
| 163 | ! |
M.EL.IDX <- lavmodel@m.free.idx[[mm]] |
| 164 | ! |
X.EL.IDX <- lavmodel@x.unco.idx[[mm]] |
| 165 | ! |
} else if (type == "full") {
|
| 166 | ! |
if (lavmodel@isSymmetric[mm]) {
|
| 167 | ! |
N <- ncol(GLIST[[mm]]) |
| 168 | ! |
M.EL.IDX <- lav_matrix_vech_idx(N) |
| 169 |
} else {
|
|
| 170 | ! |
M.EL.IDX <- seq_len(length(GLIST[[mm]])) |
| 171 |
} |
|
| 172 | ! |
X.EL.IDX <- seq_len(length(m.el.idx)) |
| 173 | ! |
if (mm > 1) X.EL.IDX <- X.EL.IDX + sum(lavmodel@mmSize[1:(mm - 1)]) |
| 174 | ! |
} else if (type == "custom") {
|
| 175 |
# nothing to do, m.el.idx and x.el.idx should be given |
|
| 176 | ! |
M.EL.IDX <- m.el.idx[[mm]] |
| 177 | ! |
X.EL.IDX <- x.el.idx[[mm]] |
| 178 |
} |
|
| 179 | ||
| 180 |
# assign |
|
| 181 | 117512x |
GLIST[[mm]][M.EL.IDX] <- x[X.EL.IDX] |
| 182 | ||
| 183 |
# make symmetric (if full) |
|
| 184 | 117512x |
if (type == "full" && lavmodel@isSymmetric[mm]) {
|
| 185 | ! |
T <- t(GLIST[[mm]]) |
| 186 | ! |
GLIST[[mm]][upper.tri(GLIST[[mm]])] <- T[upper.tri(T)] |
| 187 |
} |
|
| 188 |
} |
|
| 189 | ||
| 190 |
# # theta parameterization: delta must be reset! |
|
| 191 |
# if((lavmodel@categorical || correlation) && setDelta && |
|
| 192 |
# lavmodel@parameterization == "theta") {
|
|
| 193 |
# nmat <- lavmodel@nmat |
|
| 194 |
# for(g in 1:lavmodel@nblocks) {
|
|
| 195 |
# # which mm belong to group g? |
|
| 196 |
# mm.in.group <- 1:nmat[g] + cumsum(c(0L,nmat))[g] |
|
| 197 |
# GLIST[mm.in.group] <- |
|
| 198 |
# lav_lisrel_delta(MLIST = GLIST[mm.in.group], |
|
| 199 |
# num.idx = lavmodel@num.idx[[g]]) |
|
| 200 |
# } |
|
| 201 |
# } |
|
| 202 | ||
| 203 |
# in 0.6-13: we always set theta/delta |
|
| 204 | 14632x |
if ((lavmodel@categorical || correlation) && setDelta) {
|
| 205 | 5816x |
nmat <- lavmodel@nmat |
| 206 | 5816x |
if (lavmodel@representation == "LISREL") {
|
| 207 | 5816x |
for (g in 1:lavmodel@nblocks) {
|
| 208 |
# which mm belong to group g? |
|
| 209 | 5816x |
mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g] |
| 210 | ||
| 211 | 5816x |
if (lavmodel@parameterization == "delta") {
|
| 212 | 5816x |
GLIST[mm.in.group] <- |
| 213 | 5816x |
lav_lisrel_residual_variances( |
| 214 | 5816x |
MLIST = GLIST[mm.in.group], |
| 215 | 5816x |
num.idx = lavmodel@num.idx[[g]], |
| 216 | 5816x |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[g]], |
| 217 | 5816x |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[g]] |
| 218 |
) |
|
| 219 | ! |
} else if (lavmodel@parameterization == "theta") {
|
| 220 | ! |
GLIST[mm.in.group] <- |
| 221 | ! |
lav_lisrel_delta( |
| 222 | ! |
MLIST = GLIST[mm.in.group], |
| 223 | ! |
num.idx = lavmodel@num.idx[[g]] |
| 224 |
) |
|
| 225 |
} |
|
| 226 |
} # blocks |
|
| 227 |
} else {
|
|
| 228 | ! |
cat("FIXME: deal with theta elements in the categorical case (RAM)")
|
| 229 |
} |
|
| 230 |
} |
|
| 231 | ||
| 232 | 14632x |
if (lavmodel@composites) {
|
| 233 | ! |
nmat <- lavmodel@nmat |
| 234 | ! |
if (lavmodel@representation == "LISREL") {
|
| 235 | ! |
for (g in 1:lavmodel@nblocks) {
|
| 236 |
# which mm belong to group g? |
|
| 237 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g] |
| 238 | ||
| 239 | ! |
GLIST[mm.in.group] <- |
| 240 | ! |
lav_lisrel_composites_variances(MLIST = GLIST[mm.in.group]) |
| 241 |
} |
|
| 242 |
} else {
|
|
| 243 | ! |
cat("FIXME: deal with Composites when representation = RAM")
|
| 244 |
} |
|
| 245 |
} |
|
| 246 | ||
| 247 | 14632x |
GLIST |
| 248 |
} |
|
| 249 | ||
| 250 |
# derivative of model matrix (say, Psi, Theta) wrt the free elements |
|
| 251 |
# in that model matrix |
|
| 252 |
# returns a matrix with 0/1 entries |
|
| 253 |
# - rows are the nrow*ncol elements of the full matrix |
|
| 254 |
# - cols are the free parameters |
|
| 255 |
# |
|
| 256 |
# TOdo: use sparse matrices |
|
| 257 |
# |
|
| 258 |
lav_model_dmmdpar <- function(lavmodel, target = "theta", group = 1L) {
|
|
| 259 | ! |
stopifnot(group <= lavmodel@ngroups) |
| 260 | ||
| 261 |
# MLIST for this group |
|
| 262 | ! |
nmat <- lavmodel@nmat |
| 263 |
# which mm belong to group g? |
|
| 264 | ! |
mm.in.group <- 1:nmat[group] + cumsum(c(0L, nmat))[group] |
| 265 | ! |
MLIST <- lavmodel@GLIST[mm.in.group] |
| 266 | ||
| 267 |
# find target model matrix |
|
| 268 | ! |
mlist.idx <- which(names(MLIST) == target) |
| 269 | ! |
if (length(mlist.idx) == 0L) {
|
| 270 | ! |
lav_msg_stop(gettextf( |
| 271 | ! |
"model matrix \"%s\" not found. Available model matrices are:", target), |
| 272 | ! |
paste(names(MLIST), collapse = " ")) |
| 273 |
} |
|
| 274 | ||
| 275 |
# target idx in GLIST |
|
| 276 | ! |
target.idx <- cumsum(c(0L, nmat))[group] + mlist.idx |
| 277 | ||
| 278 |
# symmetric matrices (eg Psi, Theta) |
|
| 279 | ! |
if (lavmodel@isSymmetric[[target.idx]]) {
|
| 280 | ! |
TARGET <- lavmodel@GLIST[[target.idx]] |
| 281 | ! |
P <- nrow(TARGET) |
| 282 | ||
| 283 | ! |
unique.idx <- unique(lavmodel@x.free.idx[[target.idx]]) |
| 284 | ! |
row.idx <- match(lavmodel@x.free.idx[[target.idx]], unique.idx) |
| 285 | ! |
out <- matrix(0L, nrow = P * P, ncol = length(unique.idx)) |
| 286 | ! |
IDX <- cbind(lavmodel@m.free.idx[[target.idx]], row.idx) |
| 287 | ! |
out[IDX] <- 1L |
| 288 | ||
| 289 |
# non-symmetric matrices (eg Lambda, Beta) |
|
| 290 |
} else {
|
|
| 291 | ! |
TARGET <- lavmodel@GLIST[[target.idx]] |
| 292 | ! |
P <- nrow(TARGET) |
| 293 | ! |
M <- ncol(TARGET) |
| 294 | ||
| 295 | ! |
row.idx <- seq_len(length(lavmodel@x.free.idx[[target.idx]])) |
| 296 | ! |
out <- matrix(0L, nrow = P * M, ncol = length(row.idx)) |
| 297 | ! |
IDX <- cbind(lavmodel@m.free.idx[[target.idx]], row.idx) |
| 298 | ! |
out[IDX] <- 1L |
| 299 |
} |
|
| 300 | ||
| 301 | ! |
out |
| 302 |
} |
|
| 303 | ||
| 304 |
# backwards compatibility |
|
| 305 |
# getModelParameters <- lav_model_get_parameters |
|
| 306 |
# setModelParameters <- lav_model_set_parameters |
|
| 307 |
# x2GLIST <- lav_model_x2glist |
| 1 |
lav_lavaan_step00_parameters <- function(matchcall = NULL, |
|
| 2 |
syscall = NULL, |
|
| 3 |
dotdotdot = NULL) {
|
|
| 4 |
# 1. resolve a problem where parameter 'cl' is matched to 'cluster' |
|
| 5 |
# and shouldn't |
|
| 6 |
# 2. apply default options for cfa/sem/growth functions |
|
| 7 |
# 3. if dotdotdot$control present, copy to dotdotdot$... for |
|
| 8 |
# optim.method, |
|
| 9 |
# optim.force.converged, |
|
| 10 |
# gradient -> optim.gradient !!! overwritten by dotdotdot$gradient |
|
| 11 |
# if present |
|
| 12 |
# init_nelder_mead -> optim.init_nelder_mead |
|
| 13 | ||
| 14 | 140x |
mc <- matchcall |
| 15 | 140x |
sc <- syscall |
| 16 | 140x |
ddd <- dotdotdot |
| 17 | ||
| 18 |
# catch partial matching of 'cl' (expanded to cluster) |
|
| 19 | 140x |
if (!is.null(sc[["cl"]]) && |
| 20 | 140x |
is.null(sc[["cluster"]]) && |
| 21 | 140x |
!is.null(mc[["cluster"]])) {
|
| 22 | ! |
mc[["cl"]] <- mc[["cluster"]] |
| 23 | ! |
mc[["cluster"]] <- NULL |
| 24 | ! |
ddd$cl <- sc[["cl"]] |
| 25 |
} |
|
| 26 | 2x |
if (!is.null(mc$cluster)) mc$cluster <- eval(mc$cluster, parent.frame(2)) |
| 27 | ||
| 28 |
# default options |
|
| 29 | 140x |
if (any(ddd$model.type == c("sem", "cfa", "growth"))) {
|
| 30 |
# default options for sem/cfa or growth |
|
| 31 | 47x |
defaults <- list( |
| 32 | 47x |
int.ov.free = ddd$model.type != "growth", |
| 33 | 47x |
int.lv.free = ddd$model.type == "growth", |
| 34 | 47x |
auto.fix.first = TRUE, # (re)set in lav_options_set |
| 35 | 47x |
auto.fix.single = TRUE, |
| 36 | 47x |
auto.var = TRUE, |
| 37 | 47x |
auto.cov.lv.x = TRUE, |
| 38 | 47x |
auto.cov.y = TRUE, |
| 39 | 47x |
auto.th = TRUE, |
| 40 | 47x |
auto.delta = TRUE, |
| 41 | 47x |
auto.efa = TRUE |
| 42 |
) |
|
| 43 | 47x |
for (dflt.i in seq_along(defaults)) {
|
| 44 | 470x |
argname <- names(defaults)[dflt.i] |
| 45 | 470x |
if (is.null(mc[[argname]])) {
|
| 46 | 261x |
mc[[argname]] <- defaults[[dflt.i]] |
| 47 | 261x |
ddd[[argname]] <- defaults[[dflt.i]] |
| 48 |
} |
|
| 49 |
} |
|
| 50 |
} |
|
| 51 | ||
| 52 |
# backwards compatibility, control= argument (<0.5-23) |
|
| 53 | 140x |
if (!is.null(ddd$control)) {
|
| 54 |
# optim.method |
|
| 55 | 2x |
if (!is.null(ddd$control$optim.method)) {
|
| 56 | ! |
ddd$optim.method <- ddd$control$optim.method |
| 57 |
} |
|
| 58 |
# cor.optim.method |
|
| 59 | 2x |
if (!is.null(ddd$control$cor.optim.method)) {
|
| 60 |
# ignore it silently |
|
| 61 |
} |
|
| 62 |
# control$optim.force.converged |
|
| 63 | 2x |
if (!is.null(ddd$control$optim.force.converged)) {
|
| 64 | ! |
ddd$optim.force.converged <- ddd$control$optim.force.converged |
| 65 |
} |
|
| 66 |
# gradient |
|
| 67 | 2x |
if (!is.null(ddd$control$gradient)) {
|
| 68 | ! |
ddd$optim.gradient <- ddd$control$gradient |
| 69 |
} |
|
| 70 | 2x |
if (!is.null(ddd$gradient)) {
|
| 71 | ! |
ddd$optim.gradient <- ddd$gradient |
| 72 |
} |
|
| 73 |
# init_nelder_mead |
|
| 74 | 2x |
if (!is.null(ddd$control$init_nelder_mead)) {
|
| 75 | ! |
ddd$optim.init_nelder_mead <- ddd$control$init_nelder_mead |
| 76 |
} |
|
| 77 |
} |
|
| 78 | ||
| 79 | 140x |
list(mc = mc, dotdotdot = ddd) |
| 80 |
} |
|
| 81 | ||
| 82 |
lav_lavaan_step00_checkdata <- function(data = NULL, |
|
| 83 |
dotdotdot = NULL, |
|
| 84 |
sample.cov = NULL, |
|
| 85 |
sample.nobs = NULL, |
|
| 86 |
sample.mean = NULL, |
|
| 87 |
sample.th = NULL, |
|
| 88 |
NACOV = NULL, # nolint |
|
| 89 |
WLS.V = NULL, # nolint |
|
| 90 |
ov.order = NULL) {
|
|
| 91 |
# if data not NULL: |
|
| 92 |
# if it is an 'enriched' data.frame (e.g. a tibble), simplify to an |
|
| 93 |
# ordinary data.frame |
|
| 94 |
# if class is 'lavMoments': |
|
| 95 |
# check if it contains sample.cov and sample.nobs (***error*** if not) |
|
| 96 |
# if sample.mean, sample.th, NACOV and/or WLS.V present, |
|
| 97 |
# copy to corresponding arguments of the function |
|
| 98 |
# if lavOptions present in data, copy those that are not provided |
|
| 99 |
# in the function call to dotdotdot$... |
|
| 100 |
# set data to NULL |
|
| 101 |
# if it is a function --> ***error*** |
|
| 102 |
# TODO: other tests are present in lav_lavdata(), should we copy them here ??? |
|
| 103 |
# if NACOV or WLS.V not NULL, set ov.order to "data" |
|
| 104 | ||
| 105 | 140x |
if (!is.null(data)) {
|
| 106 | 35x |
if (inherits(data, "data.frame")) {
|
| 107 |
# just in case it is not a traditional data.frame |
|
| 108 | 35x |
data <- as.data.frame(data) |
| 109 | ! |
} else if (inherits(data, "lavMoments")) {
|
| 110 |
# This object must contain summary statistics |
|
| 111 |
# e.g., created by lavaan.mi::poolSat |
|
| 112 | ||
| 113 |
# set required-data arguments |
|
| 114 | ! |
if ("sample.cov" %in% names(data)) {
|
| 115 | ! |
sample.cov <- data$sample.cov |
| 116 |
} else {
|
|
| 117 | ! |
lav_msg_stop(gettext( |
| 118 | ! |
"When data= is of class lavMoments, it must contain sample.cov")) |
| 119 |
} |
|
| 120 | ||
| 121 | ! |
if ("sample.nobs" %in% names(data)) {
|
| 122 | ! |
sample.nobs <- data$sample.nobs |
| 123 |
} else {
|
|
| 124 | ! |
lav_msg_stop(gettext( |
| 125 | ! |
"When data= is of class lavMoments, it must contain sample.nobs")) |
| 126 |
} |
|
| 127 | ||
| 128 |
# check for optional-data arguments |
|
| 129 | ! |
if ("sample.mean" %in% names(data)) sample.mean <- data$sample.mean
|
| 130 | ! |
if ("sample.th" %in% names(data)) sample.th <- data$sample.th
|
| 131 | ! |
if ("NACOV" %in% names(data)) NACOV <- data$NACOV # nolint
|
| 132 | ! |
if ("WLS.V" %in% names(data)) WLS.V <- data$WLS.V # nolint
|
| 133 | ||
| 134 |
# set other args not included in dotdotdot |
|
| 135 | ! |
if (length(data$lavOptions)) {
|
| 136 | ! |
newdots <- setdiff(names(data$lavOptions), names(dotdotdot)) |
| 137 | ! |
if (length(newdots)) {
|
| 138 | ! |
for (dd in newdots) dotdotdot[[dd]] <- data$lavOptions[[dd]] |
| 139 |
} |
|
| 140 |
} |
|
| 141 | ||
| 142 |
# FIXME: Should WLS.V be an I(dentity) matrix when ULS is requested? |
|
| 143 |
# Unused for point estimates, but still used to scale/shift test |
|
| 144 |
# if (!is.null(dotdotdot$estimator)) {
|
|
| 145 |
# if (grepl(pattern = "ULS", x = toupper(dotdotdot$estimator[1L])) && |
|
| 146 |
# !is.null(WLS.V)) {
|
|
| 147 |
# # set to diagonal |
|
| 148 |
# if (is.list(WLS.V)) {
|
|
| 149 |
# WLS.V <- lapply(WLS.V, function(w) {diag(w) <- 1 ; return(w) })
|
|
| 150 |
# } else diag(WLS.V) <- 1 |
|
| 151 |
# } |
|
| 152 |
# } |
|
| 153 | ||
| 154 |
# get rid of data= argument |
|
| 155 | ! |
data <- NULL |
| 156 |
} |
|
| 157 | ||
| 158 | 35x |
if (is.function(data)) {
|
| 159 | ! |
lav_msg_stop(gettext("data is a function; it should be a data.frame"))
|
| 160 |
} |
|
| 161 |
} |
|
| 162 |
# new in 0.6-14: if NACOV and/or WLS.V are provided, we force |
|
| 163 |
# ov.order="data" for now |
|
| 164 |
# until we have reliable code to re-arrange/select col/rows for |
|
| 165 |
# of NACOV/WLS.V based on the model-based ov.names |
|
| 166 | 140x |
if (!is.null(NACOV) || !is.null(WLS.V)) {
|
| 167 | ! |
if (ov.order != "force.model") { # used by sam()
|
| 168 | ! |
ov.order <- "data" |
| 169 |
} else {
|
|
| 170 | ! |
ov.order <- "model" |
| 171 |
} |
|
| 172 |
} |
|
| 173 | ||
| 174 | 140x |
list( |
| 175 | 140x |
data = data, dotdotdot = dotdotdot, sample.cov = sample.cov, |
| 176 | 140x |
sample.nobs = sample.nobs, sample.mean = sample.mean, |
| 177 | 140x |
sample.th = sample.th, NACOV = NACOV, WLS.V = WLS.V, ov.order = ov.order |
| 178 |
) |
|
| 179 |
} |
| 1 |
# this function is written by Myrsini Katsikatsou |
|
| 2 | ||
| 3 |
############################## pairwiseTables FUNCTION ######################## |
|
| 4 |
# This function can be public. It gets as an input a raw data set of ordinal |
|
| 5 |
# variables and it returns a list of all pairwise frequency tables. |
|
| 6 |
# |
|
| 7 |
# The input arguments of the function: |
|
| 8 |
# data : matrix or data frame containing the data. The rows correspond to |
|
| 9 |
# different observations and the columns to different observed categorical |
|
| 10 |
# (ordinal or nominal) variables. No continuous variables or covariates |
|
| 11 |
# should be contained in data. If the variables contained in the data are |
|
| 12 |
# distinguished into indicators of exogenous latent variables (lv) and |
|
| 13 |
# indicators of endogenous latent variables, those for exogenous lv should |
|
| 14 |
# be presented first (in the first columns of data) followed by the |
|
| 15 |
# indicators for endogenous lv. |
|
| 16 |
# var.levels: NULL or vector or list, specifies the levels (response categories) |
|
| 17 |
# for each categorical variable contained in data. |
|
| 18 |
# If NULL, the levels encoutered in data are used. If a response |
|
| 19 |
# category is not observed in the data, then var.levels should be |
|
| 20 |
# defined. |
|
| 21 |
# If vector, that implies that all variables have the same levels as |
|
| 22 |
# given in the vector. |
|
| 23 |
# If list, the components of the list are vectors, as many as the |
|
| 24 |
# number of variables in data. Each vector gives the levels of |
|
| 25 |
# the corresponding categorical variable in data. |
|
| 26 |
# no.x : NULL or integer, gives the number of indicators for exogenous lv. |
|
| 27 |
# The default value is NULL indicating that data contains only |
|
| 28 |
# indicators of exogenous latent variables. |
|
| 29 |
# perc : TRUE/FALSE. If FALSE the observed frequencies are reported, otherwise |
|
| 30 |
# the observed percentages are given. |
|
| 31 |
# na.exclude : TRUE/FALSE. If TRUE, listwise deletion is applied to data. |
|
| 32 |
# Otherwise, cases with missing values are preserved and and an |
|
| 33 |
# extra level with label NA is included in the tables. |
|
| 34 | ||
| 35 |
# The output of the function: |
|
| 36 |
# It is a list of three components: $pairTables, $VarLevels and $Ncases_del. |
|
| 37 |
# pairTables : a list of so many tables as the number of variable pairs formed |
|
| 38 |
# by data. If there are indicators of both exogenous and endogenous |
|
| 39 |
# variables, then first all the matrices referring to pairs of |
|
| 40 |
# indicators of exogenous lv are reported, followed by all the |
|
| 41 |
# matrices referring to pairs of indicators of endogenous lv, which |
|
| 42 |
# in turn folowed by all the matrices of pairs: one indicator of an |
|
| 43 |
# exogenous - one indicator of an endogenous lv. |
|
| 44 |
# VarLevels : a list of as many vectors as the number of variables in the data. |
|
| 45 |
# Each vector gives the levels/ response categories of each variable |
|
| 46 |
# Ncases_del : An integer reporting the number of cases deleted by data because |
|
| 47 |
# of missing values (listwise deletion) when na.exclude=TRUE. |
|
| 48 | ||
| 49 | ||
| 50 | ||
| 51 |
pairwiseTables <- function(data, var.levels = NULL, no.x = NULL, |
|
| 52 |
perc = FALSE, na.exclude = TRUE) {
|
|
| 53 |
# data in right format? |
|
| 54 | ! |
if ((!is.matrix(data)) & (!is.data.frame(data))) {
|
| 55 | ! |
lav_msg_stop(gettext("data is neither a matrix nor a data.frame"))
|
| 56 |
} |
|
| 57 | ||
| 58 |
# at least two variables |
|
| 59 | ! |
no.var <- dim(data)[2] |
| 60 | ! |
if (no.var < 2) {
|
| 61 | ! |
lav_msg_stop(gettext("there are less than 2 variables"))
|
| 62 |
} |
|
| 63 | ||
| 64 |
# no.x < no.var ? |
|
| 65 | ! |
if (no.x > no.var) {
|
| 66 | ! |
lav_msg_stop(gettext( |
| 67 | ! |
"number of indicators for exogenous latent variables is larger than |
| 68 | ! |
the total number of variables in data")) |
| 69 |
} |
|
| 70 | ||
| 71 | ||
| 72 |
# if data as matrix, transforma as data.frame |
|
| 73 | ! |
if (is.matrix(data)) {
|
| 74 | ! |
data <- as.data.frame(data) |
| 75 |
} |
|
| 76 | ||
| 77 |
# listwise deletion |
|
| 78 | ! |
if (na.exclude) {
|
| 79 | ! |
old.data <- data |
| 80 | ! |
data <- na.omit(data) |
| 81 |
} |
|
| 82 | ||
| 83 |
# all columns of data.frame should be of class factor so that function levels |
|
| 84 |
# can be applied |
|
| 85 | ! |
if (!all(sapply(data, class) == "factor")) {
|
| 86 | ! |
if (nrow(data) > 1) {
|
| 87 | ! |
data <- data.frame(sapply(data, factor)) |
| 88 |
} else {
|
|
| 89 | ! |
data <- apply(data, 2, factor) |
| 90 | ! |
data <- as.data.frame(matrix(data, nrow = 1)) |
| 91 |
} |
|
| 92 |
} |
|
| 93 | ||
| 94 |
# the levels observed for each variable, obs.levels is a list |
|
| 95 | ! |
obs.levels <- lapply(data, levels) |
| 96 | ||
| 97 |
# number of variables in data same as number of vectors in var.levels |
|
| 98 | ! |
if (is.list(var.levels) && no.var != length(var.levels)) {
|
| 99 | ! |
lav_msg_stop(gettext( |
| 100 | ! |
"the length of var.levels does not match the number of variables of |
| 101 | ! |
the given data set")) |
| 102 |
} |
|
| 103 | ||
| 104 |
# create var.levels if a list is not given |
|
| 105 | ! |
old.var.levels <- var.levels |
| 106 | ! |
if (!is.list(old.var.levels)) {
|
| 107 | ! |
if (is.null(old.var.levels)) {
|
| 108 | ! |
var.levels <- obs.levels |
| 109 |
} else {
|
|
| 110 | ! |
var.levels <- vector("list", no.var)
|
| 111 | ! |
var.levels <- lapply(var.levels, function(x) {
|
| 112 | ! |
x <- old.var.levels |
| 113 |
}) |
|
| 114 |
} |
|
| 115 |
} |
|
| 116 | ! |
names(var.levels) <- names(data) |
| 117 | ||
| 118 |
# also check that obs.levels exist in the object var.levels given by the user, i.e. old.var.levels |
|
| 119 | ! |
if (is.list(old.var.levels)) {
|
| 120 | ! |
for (i in 1:no.var) {
|
| 121 | ! |
if (!all(obs.levels[[i]] %in% old.var.levels[[i]])) {
|
| 122 | ! |
lav_msg_stop(gettext( |
| 123 | ! |
"levels observed in data are not mentioned in var.levels")) |
| 124 |
} |
|
| 125 |
} |
|
| 126 | ! |
} else if (is.vector(old.var.levels)) {
|
| 127 | ! |
if (!all(apply(na.omit(data), 2, function(x) {
|
| 128 | ! |
x %in% old.var.levels |
| 129 |
}))) {
|
|
| 130 | ! |
lav_msg_stop(gettext("levels observed in data are not mentioned
|
| 131 | ! |
in var.levels")) |
| 132 |
} |
|
| 133 |
} |
|
| 134 | ||
| 135 | ! |
no.given.levels <- sapply(var.levels, length) |
| 136 | ||
| 137 |
# assign the right levels for each variable as given in object var.levels if it is not the case |
|
| 138 |
# it is not the case when the observed levels are a subgroup of the var.levels given |
|
| 139 | ! |
if (!is.null(old.var.levels)) {
|
| 140 | ! |
no.obs.levels <- sapply(obs.levels, length) |
| 141 | ! |
if (!all(no.obs.levels == no.given.levels)) {
|
| 142 | ! |
index <- c(1:no.var)[no.obs.levels != no.given.levels] |
| 143 | ! |
for (i in index) {
|
| 144 | ! |
data[, i] <- factor(data[, i], levels = var.levels[[i]]) |
| 145 |
} |
|
| 146 |
} |
|
| 147 |
} |
|
| 148 | ||
| 149 |
# compute the bivariate frequency tables |
|
| 150 |
# Split first into two cases: a) only indicators of exogenous latent variables |
|
| 151 |
# b) otherwise |
|
| 152 | ! |
if (is.null(no.x) || no.x == no.var) {
|
| 153 | ! |
pairs.index <- utils::combn(no.var, 2) |
| 154 | ! |
no.pairs <- dim(pairs.index)[2] |
| 155 | ! |
res <- vector("list", no.pairs)
|
| 156 | ! |
for (i in 1:no.pairs) {
|
| 157 | ! |
res[[i]] <- table(data[, pairs.index[, i]], useNA = "ifany") |
| 158 |
} |
|
| 159 |
} else {
|
|
| 160 | ! |
no.y <- no.var - no.x |
| 161 | ! |
pairs.xixj.index <- utils::combn(no.x, 2) # row 1 gives i index, row 2 j index, j runs faster than i |
| 162 | ! |
pairs.yiyj.index <- utils::combn(no.y, 2) |
| 163 | ! |
pairs.xiyj.index <- expand.grid(1:no.y, 1:no.x) |
| 164 | ! |
pairs.xiyj.index <- rbind(pairs.xiyj.index[, 2], pairs.xiyj.index[, 1]) # row 1 gives i index, row 2 j index, j runs faster than i |
| 165 | ||
| 166 | ! |
no.pairs.xixj <- dim(pairs.xixj.index)[2] |
| 167 | ! |
no.pairs.yiyj <- dim(pairs.yiyj.index)[2] |
| 168 | ! |
no.pairs.xiyj <- dim(pairs.xiyj.index)[2] |
| 169 | ! |
no.all.pairs <- no.pairs.xixj + no.pairs.yiyj + no.pairs.xiyj |
| 170 | ||
| 171 | ! |
data.x <- data[, 1:no.x] |
| 172 | ! |
data.y <- data[, (no.x + 1):no.var] |
| 173 | ||
| 174 | ! |
res <- vector("list", no.all.pairs)
|
| 175 | ! |
for (i in 1:no.pairs.xixj) {
|
| 176 | ! |
res[[i]] <- table(data.x[, pairs.xixj.index[, i]], useNA = "ifany") |
| 177 |
} |
|
| 178 | ||
| 179 | ! |
j <- 0 |
| 180 | ! |
for (i in (no.pairs.xixj + 1):(no.pairs.xixj + no.pairs.yiyj)) {
|
| 181 | ! |
j <- j + 1 |
| 182 | ! |
res[[i]] <- table(data.y[, pairs.yiyj.index[, j]], useNA = "ifany") |
| 183 |
} |
|
| 184 | ||
| 185 | ! |
j <- 0 |
| 186 | ! |
for (i in (no.pairs.xixj + no.pairs.yiyj + 1):no.all.pairs) {
|
| 187 | ! |
j <- j + 1 |
| 188 | ! |
res[[i]] <- table( |
| 189 | ! |
cbind( |
| 190 | ! |
data.x[, pairs.xiyj.index[1, j], drop = FALSE], |
| 191 | ! |
data.y[, pairs.xiyj.index[2, j], drop = FALSE] |
| 192 |
), |
|
| 193 | ! |
useNA = "ifany" |
| 194 |
) |
|
| 195 |
} |
|
| 196 |
} |
|
| 197 | ||
| 198 |
# if percentages are asked |
|
| 199 | ! |
if (perc) {
|
| 200 | ! |
Nobs <- dim(data)[1] |
| 201 | ! |
res <- lapply(res, function(x) {
|
| 202 | ! |
x / Nobs |
| 203 |
}) |
|
| 204 |
} |
|
| 205 | ||
| 206 |
# Ncases_del = the number of cases deleted because they had missing values |
|
| 207 | ! |
if (na.exclude) {
|
| 208 | ! |
Ncases_deleted <- dim(old.data)[1] - dim(data)[1] |
| 209 |
} else {
|
|
| 210 | ! |
Ncases_deleted <- 0 |
| 211 |
} |
|
| 212 | ||
| 213 | ! |
list(pairTables = res, VarLevels = var.levels, Ncases_del = Ncases_deleted) |
| 214 |
} |
| 1 |
# casewise likelihoods |
|
| 2 | ||
| 3 |
# closed-form marginal likelihood |
|
| 4 |
# - classic SEM models, continous observed variables only |
|
| 5 |
lav_model_lik_ml <- function(lavmodel = NULL, |
|
| 6 |
GLIST = NULL, |
|
| 7 |
lavdata = NULL, |
|
| 8 |
lavsamplestats = NULL) {
|
|
| 9 | ||
| 10 | ||
| 11 |
} |
|
| 12 | ||
| 13 | ||
| 14 |
# marginal ML |
|
| 15 |
lav_model_lik_mml <- function(lavmodel = NULL, |
|
| 16 |
THETA = NULL, |
|
| 17 |
TH = NULL, |
|
| 18 |
GLIST = NULL, |
|
| 19 |
group = 1L, |
|
| 20 |
lavdata = NULL, |
|
| 21 |
sample.mean = NULL, |
|
| 22 |
sample.mean.x = NULL, |
|
| 23 |
lavcache = NULL) {
|
|
| 24 | ! |
conditional.x <- lavmodel@conditional.x |
| 25 | ||
| 26 |
# data for this group |
|
| 27 | ! |
X <- lavdata@X[[group]] |
| 28 | ! |
nobs <- nrow(X) |
| 29 | ! |
nvar <- ncol(X) |
| 30 | ! |
eXo <- lavdata@eXo[[group]] |
| 31 | ||
| 32 |
# MLIST (for veta and yhat) |
|
| 33 | ! |
mm.in.group <- 1:lavmodel@nmat[group] + cumsum(c(0, lavmodel@nmat))[group] |
| 34 | ! |
MLIST <- GLIST[mm.in.group] |
| 35 | ||
| 36 |
# quadrature points |
|
| 37 | ! |
GH <- lavcache[[group]]$GH |
| 38 | ! |
nGH <- nrow(GH$x) |
| 39 | ! |
nfac <- ncol(GH$x) |
| 40 | ||
| 41 |
# compute VETAx (latent lv only) |
|
| 42 | ! |
lv.dummy.idx <- c( |
| 43 | ! |
lavmodel@ov.y.dummy.lv.idx[[group]], |
| 44 | ! |
lavmodel@ov.x.dummy.lv.idx[[group]] |
| 45 |
) |
|
| 46 | ! |
VETAx <- lav_lisrel_vetax( |
| 47 | ! |
MLIST = MLIST, |
| 48 | ! |
lv.dummy.idx = lv.dummy.idx |
| 49 |
) |
|
| 50 |
# VETAx <- lav_lisrel_vetax(MLIST = MLIST) |
|
| 51 |
# check for negative values? |
|
| 52 | ! |
if (any(diag(VETAx) < 0)) {
|
| 53 | ! |
lav_msg_warn(gettext("--- VETAx contains negative values"))
|
| 54 | ! |
print(VETAx) |
| 55 | ! |
return(0) |
| 56 |
} |
|
| 57 | ||
| 58 |
# cholesky? |
|
| 59 |
# if(is.null(lavmodel@control$cholesky)) {
|
|
| 60 | ! |
CHOLESKY <- TRUE |
| 61 |
# } else {
|
|
| 62 |
# CHOLESKY <- as.logical(lavmodel@control$cholesky) |
|
| 63 |
# if(nfac > 1L && !CHOLESKY) {
|
|
| 64 |
# warning("lavaan WARNING: CHOLESKY is OFF but nfac > 1L")
|
|
| 65 |
# } |
|
| 66 |
# } |
|
| 67 | ||
| 68 | ! |
if (!CHOLESKY) {
|
| 69 |
# we should still 'scale' the factors, if std.lv=FALSE |
|
| 70 | ! |
ETA.sd <- sqrt(diag(VETAx)) |
| 71 |
} else {
|
|
| 72 |
# cholesky takes care of scaling |
|
| 73 | ! |
tchol.VETA <- try(chol(VETAx), silent = TRUE) |
| 74 | ! |
if (inherits(tchol.VETA, "try-error")) {
|
| 75 | ! |
lav_msg_warn(gettext("--- VETAx not positive definite"))
|
| 76 | ! |
print(VETAx) |
| 77 | ! |
return(0) |
| 78 |
} |
|
| 79 | ! |
if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
|
| 80 | ! |
if (conditional.x) {
|
| 81 | ! |
EETAx <- lav_lisrel_eetax( |
| 82 | ! |
MLIST = MLIST, eXo = eXo, N = nobs, |
| 83 | ! |
sample.mean = sample.mean, |
| 84 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]], |
| 85 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]], |
| 86 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]], |
| 87 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]] |
| 88 |
) |
|
| 89 |
} else {
|
|
| 90 | ! |
EETA <- lav_lisrel_eeta( |
| 91 | ! |
MLIST = MLIST, |
| 92 | ! |
mean.x = sample.mean.x, |
| 93 | ! |
sample.mean = sample.mean, |
| 94 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]], |
| 95 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]], |
| 96 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]], |
| 97 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]] |
| 98 |
) |
|
| 99 |
} |
|
| 100 |
# if(length(lv.dummy.idx) > 0L) {
|
|
| 101 |
# EETAx <- EETAx[,-lv.dummy.idx,drop=FALSE] |
|
| 102 |
# } |
|
| 103 |
} |
|
| 104 |
} |
|
| 105 | ||
| 106 |
# compute (log)lik for each node, for each observation |
|
| 107 | ! |
SUM.LOG.FY <- matrix(0, nrow = nGH, ncol = nobs) |
| 108 | ! |
for (q in 1:nGH) {
|
| 109 |
# current value(s) for ETA |
|
| 110 |
# eta <- matrix(0, nrow = 1, ncol = ncol(MLIST$lambda)) |
|
| 111 | ||
| 112 |
# non-dummy elements -> quadrature points |
|
| 113 |
# eta[1L, -lv.dummy.idx] <- GH$x[q,,drop=FALSE] |
|
| 114 | ! |
XQ <- GH$x[q, , drop = FALSE] |
| 115 | ||
| 116 |
# rescale/unwhiten |
|
| 117 | ! |
if (CHOLESKY) {
|
| 118 |
# un-orthogonalize |
|
| 119 | ! |
XQ <- XQ %*% tchol.VETA |
| 120 |
} else {
|
|
| 121 |
# no unit scale? (un-standardize) |
|
| 122 | ! |
XQ <- sweep(XQ, MARGIN = 2, STATS = ETA.sd, FUN = "*") |
| 123 |
} |
|
| 124 | ||
| 125 | ! |
eta <- matrix(0, nrow = 1, ncol = ncol(MLIST$lambda)) |
| 126 | ! |
if (length(lv.dummy.idx) > 0L) {
|
| 127 | ! |
eta[, -lv.dummy.idx] <- XQ |
| 128 |
} else {
|
|
| 129 | ! |
eta <- XQ |
| 130 |
} |
|
| 131 | ||
| 132 |
# eta_i = alpha + BETA eta_i + GAMMA eta_i + error |
|
| 133 |
# |
|
| 134 |
# - direct effect of BETA is already in VETAx, and hence tchol.VETA |
|
| 135 |
# - need to add alpha, and GAMMA eta_i |
|
| 136 | ! |
if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
|
| 137 | ! |
if (conditional.x) {
|
| 138 | ! |
eta <- sweep(EETAx, MARGIN = 2, STATS = eta, FUN = "+") |
| 139 |
} else {
|
|
| 140 | ! |
eta <- eta + EETA |
| 141 |
} |
|
| 142 |
} |
|
| 143 | ||
| 144 |
# compute yhat for this node (eta) |
|
| 145 | ! |
if (lavmodel@conditional.x) {
|
| 146 | ! |
yhat <- lav_lisrel_eyetax( |
| 147 | ! |
MLIST = MLIST, eXo = eXo, |
| 148 | ! |
ETA = eta, sample.mean = sample.mean, |
| 149 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]], |
| 150 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]], |
| 151 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]], |
| 152 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]] |
| 153 |
) |
|
| 154 |
} else {
|
|
| 155 | ! |
yhat <- lav_lisrel_eyetax3( |
| 156 | ! |
MLIST = MLIST, |
| 157 | ! |
ETA = eta, sample.mean = sample.mean, |
| 158 | ! |
mean.x = sample.mean.x, |
| 159 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]], |
| 160 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]], |
| 161 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]], |
| 162 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]] |
| 163 |
) |
|
| 164 |
} |
|
| 165 | ||
| 166 |
# compute fy.var, for this node (eta): P(Y_i = y_i | eta_i, x_i) |
|
| 167 | ! |
log.fy.var <- lav_predict_fy_internal( |
| 168 | ! |
X = X, yhat = yhat, |
| 169 | ! |
TH = TH, THETA = THETA, |
| 170 | ! |
num.idx = lavmodel@num.idx[[group]], |
| 171 | ! |
th.idx = lavmodel@th.idx[[group]], |
| 172 | ! |
link = lavmodel@link, log. = TRUE |
| 173 |
) |
|
| 174 | ||
| 175 |
# if log, fy is just the sum of log.fy.var |
|
| 176 | ! |
log.fy <- apply(log.fy.var, 1L, sum) |
| 177 | ||
| 178 |
# store log likelihoods for this node |
|
| 179 | ! |
SUM.LOG.FY[q, ] <- log.fy |
| 180 |
} |
|
| 181 | ||
| 182 |
# integration |
|
| 183 | ! |
lik <- as.numeric(t(GH$w) %*% exp(SUM.LOG.FY)) |
| 184 | ||
| 185 |
# avoid underflow |
|
| 186 | ! |
idx <- which(lik < exp(-600)) |
| 187 | ! |
if (length(idx) > 0L) {
|
| 188 | ! |
lik[idx] <- exp(-600) |
| 189 |
} |
|
| 190 | ||
| 191 | ! |
lik |
| 192 |
} |
| 1 |
# generate syntax for an independence model |
|
| 2 |
lav_syntax_independence <- function(ov.names = character(0), |
|
| 3 |
ov.names.x = character(0), |
|
| 4 |
sample.cov = NULL) {
|
|
| 5 | ! |
ov.names.nox <- ov.names[!ov.names %in% ov.names.x] |
| 6 | ! |
nvar <- length(ov.names.nox) |
| 7 | ! |
lv.names <- paste("f", 1:nvar, sep = "")
|
| 8 | ||
| 9 |
# check sample.cov |
|
| 10 | ! |
if (!is.null(sample.cov)) {
|
| 11 | ! |
if (is.list(sample.cov)) {
|
| 12 | ! |
ngroups <- length(sample.cov) |
| 13 |
} else {
|
|
| 14 | ! |
ngroups <- 1L |
| 15 | ! |
sample.cov <- list(sample.cov) |
| 16 |
} |
|
| 17 | ! |
stopifnot(is.matrix(sample.cov[[1]])) |
| 18 |
# stopifnot(length(ov.names) == nrow(sample.cov[[1]])) |
|
| 19 |
# FIXME: check rownames and reorder... |
|
| 20 |
} |
|
| 21 | ||
| 22 |
# construct lavaan syntax for an independence model |
|
| 23 | ! |
txt <- "# independence model\n" |
| 24 | ||
| 25 |
# =~ lines (each observed variables has its own latent variable) |
|
| 26 |
# excepct for ov's that are in ov.names.x |
|
| 27 | ! |
txt <- paste(txt, paste(lv.names, " =~ 1*", ov.names.nox, |
| 28 | ! |
"\n", |
| 29 | ! |
sep = "", collapse = "" |
| 30 | ! |
), sep = "") |
| 31 | ||
| 32 |
# residual ov variances fixed to zero |
|
| 33 | ! |
txt <- paste(txt, paste(ov.names.nox, " ~~ 0*", ov.names.nox, |
| 34 | ! |
"\n", |
| 35 | ! |
sep = "", collapse = "" |
| 36 | ! |
), sep = "") |
| 37 | ||
| 38 |
# latent variances |
|
| 39 | ! |
if (is.null(sample.cov)) {
|
| 40 | ! |
txt <- paste(txt, paste(lv.names, " ~~ ", lv.names, |
| 41 | ! |
"\n", |
| 42 | ! |
sep = "", collapse = "" |
| 43 | ! |
), sep = "") |
| 44 |
} else {
|
|
| 45 |
# fill in sample values |
|
| 46 | ! |
ov.idx <- match(ov.names.nox, ov.names) |
| 47 | ||
| 48 | ! |
start.txt <- paste("start(c(",
|
| 49 | ! |
apply(matrix( |
| 50 | ! |
unlist(lapply(sample.cov, function(x) {
|
| 51 | ! |
diag(x)[ov.idx] |
| 52 |
})), |
|
| 53 | ! |
ncol = ngroups |
| 54 | ! |
), 1, paste, collapse = ","), "))", |
| 55 | ! |
sep = "" |
| 56 |
) |
|
| 57 | ! |
txt <- paste(txt, paste(lv.names, " ~~ ", start.txt, " * ", |
| 58 | ! |
lv.names, |
| 59 | ! |
"\n", |
| 60 | ! |
sep = "", collapse = "" |
| 61 | ! |
), sep = "") |
| 62 |
} |
|
| 63 | ||
| 64 |
# latent *covariances* fixed to zero (= independence!) |
|
| 65 | ! |
if (length(lv.names) > 1L) {
|
| 66 | ! |
tmp <- utils::combn(lv.names, 2) |
| 67 | ! |
txt <- paste(txt, paste(tmp[1, ], " ~~ 0*", tmp[2, ], "\n", |
| 68 | ! |
sep = "", |
| 69 | ! |
collapse = "" |
| 70 | ! |
), sep = "") |
| 71 |
} |
|
| 72 | ||
| 73 |
# if 'independent x' variables, add an 'empty' regression |
|
| 74 | ! |
if ((nx <- length(ov.names.x)) > 0) {
|
| 75 |
# dummy regression line |
|
| 76 | ! |
txt <- paste(txt, paste("f1 ~ 0*", ov.names.x,
|
| 77 | ! |
"\n", |
| 78 | ! |
sep = "", collapse = "" |
| 79 | ! |
), sep = "") |
| 80 |
} |
|
| 81 | ||
| 82 |
# Note: no need to pass starting values here, lavaanStart will |
|
| 83 |
# use the sample statistics anyway.... |
|
| 84 | ||
| 85 | ! |
txt |
| 86 |
} |
| 1 |
lav_standardize_lv_x <- function(x, lavobject, partable = NULL, cov.std = TRUE, |
|
| 2 |
lv.var = NULL, |
|
| 3 |
rotation = FALSE) {
|
|
| 4 |
# set new values for x |
|
| 5 | ! |
lavmodel <- lav_model_set_parameters(lavmodel = lavobject@Model, x = x) |
| 6 | ||
| 7 | ! |
if (rotation) {
|
| 8 | ! |
x.unrotated <- x |
| 9 | ! |
lavmodel@GLIST <- lavTech(lavobject, "est.unrotated") # unrotated! |
| 10 | ! |
est.rot <- lav_model_efa_rotate_x( |
| 11 | ! |
x = x.unrotated, |
| 12 | ! |
lavmodel = lavmodel, # unrotated! |
| 13 | ! |
lavoptions = lavobject@Options, |
| 14 | ! |
init.rot = lavmodel@H, |
| 15 | ! |
type = "user", |
| 16 | ! |
extra = TRUE |
| 17 |
) |
|
| 18 | ! |
GLIST <- attr(est.rot, "extra")$GLIST |
| 19 | ! |
attributes(est.rot) <- NULL |
| 20 | ! |
est <- est.rot |
| 21 |
} else {
|
|
| 22 | ! |
GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message |
| 23 | ! |
est <- lav_model_get_parameters(lavmodel, type = "user") |
| 24 |
} |
|
| 25 | ||
| 26 | ! |
x.stand.user <- lav_standardize_lv( |
| 27 | ! |
lavobject = lavobject, |
| 28 | ! |
partable = partable, est = est, |
| 29 | ! |
GLIST = GLIST, cov.std = cov.std, |
| 30 | ! |
lv.var = lv.var |
| 31 |
) |
|
| 32 | ||
| 33 | ! |
x.stand.user |
| 34 |
} |
|
| 35 | ||
| 36 |
lav_standardize_all_x <- function(x, lavobject, partable = NULL, cov.std = TRUE, |
|
| 37 |
rotation = FALSE) {
|
|
| 38 | 1802x |
lavmodel <- lav_model_set_parameters(lavmodel = lavobject@Model, x = x) |
| 39 | ||
| 40 | 1802x |
if (rotation) {
|
| 41 | ! |
x.unrotated <- x |
| 42 | ! |
lavmodel@GLIST <- lavTech(lavobject, "est.unrotated") # unrotated! |
| 43 | ! |
est.rot <- lav_model_efa_rotate_x( |
| 44 | ! |
x = x.unrotated, |
| 45 | ! |
lavmodel = lavmodel, # unrotated! |
| 46 | ! |
lavoptions = lavobject@Options, |
| 47 | ! |
init.rot = lavmodel@H, |
| 48 | ! |
type = "user", |
| 49 | ! |
extra = TRUE |
| 50 |
) |
|
| 51 | ! |
GLIST <- attr(est.rot, "extra")$GLIST |
| 52 | ! |
attributes(est.rot) <- NULL |
| 53 | ! |
est <- est.rot |
| 54 |
} else {
|
|
| 55 | 1802x |
GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message |
| 56 | 1802x |
est <- lav_model_get_parameters(lavmodel, type = "user") |
| 57 |
} |
|
| 58 | ||
| 59 | 1802x |
x.stand.user <- lav_standardize_all( |
| 60 | 1802x |
lavobject = lavobject, |
| 61 | 1802x |
partable = partable, est = est, |
| 62 | 1802x |
est.std = NULL, GLIST = GLIST, |
| 63 | 1802x |
cov.std = cov.std |
| 64 |
) |
|
| 65 | 1773x |
x.stand.user |
| 66 |
} |
|
| 67 | ||
| 68 |
lav_standardize_all_nox_x <- function(x, lavobject, partable = NULL, |
|
| 69 |
cov.std = TRUE, rotation = FALSE) {
|
|
| 70 | ! |
lavmodel <- lav_model_set_parameters(lavmodel = lavobject@Model, x = x) |
| 71 | ||
| 72 | ! |
if (rotation) {
|
| 73 | ! |
x.unrotated <- x |
| 74 | ! |
lavmodel@GLIST <- lavTech(lavobject, "est.unrotated") # unrotated! |
| 75 | ! |
est.rot <- lav_model_efa_rotate_x( |
| 76 | ! |
x = x.unrotated, |
| 77 | ! |
lavmodel = lavmodel, # unrotated! |
| 78 | ! |
lavoptions = lavobject@Options, |
| 79 | ! |
init.rot = lavmodel@H, |
| 80 | ! |
type = "user", |
| 81 | ! |
extra = TRUE |
| 82 |
) |
|
| 83 | ! |
GLIST <- attr(est.rot, "extra")$GLIST |
| 84 | ! |
attributes(est.rot) <- NULL |
| 85 | ! |
est <- est.rot |
| 86 |
} else {
|
|
| 87 | ! |
GLIST <- lavmodel@GLIST # if this changes, tag @TDJorgensen in commit message |
| 88 | ! |
est <- lav_model_get_parameters(lavmodel, type = "user") |
| 89 |
} |
|
| 90 | ||
| 91 | ! |
x.stand.user <- lav_standardize_all_nox( |
| 92 | ! |
lavobject = lavobject, |
| 93 | ! |
partable = partable, est = est, |
| 94 | ! |
est.std = NULL, GLIST = GLIST, |
| 95 | ! |
cov.std = cov.std |
| 96 |
) |
|
| 97 | ! |
x.stand.user |
| 98 |
} |
|
| 99 | ||
| 100 |
lav_unstandardize_ov_x <- function(x, lavobject) {
|
|
| 101 | ! |
partable <- lavobject@ParTable |
| 102 | ! |
partable$ustart <- x |
| 103 | ! |
lav_unstandardize_ov( |
| 104 | ! |
partable = partable, |
| 105 | ! |
ov.var = lavobject@SampleStats@var, |
| 106 | ! |
cov.std = TRUE |
| 107 |
) |
|
| 108 |
} |
|
| 109 | ||
| 110 | ||
| 111 |
lav_standardize_lv <- function(lavobject = NULL, |
|
| 112 |
partable = NULL, est = NULL, GLIST = NULL, |
|
| 113 |
cov.std = TRUE, lv.var = NULL, |
|
| 114 |
lavmodel = NULL, lavpartable = NULL) {
|
|
| 115 | 1921x |
if (is.null(lavobject)) {
|
| 116 | 2x |
stopifnot(!is.null(lavmodel)) |
| 117 | 2x |
stopifnot(!is.null(lavpartable)) |
| 118 | 2x |
if (is.null(est)) {
|
| 119 | ! |
if (!is.null(lavpartable$est)) {
|
| 120 | ! |
est <- lavpartable$est # if this changes, tag @TDJorgensen in commit message |
| 121 |
} else {
|
|
| 122 | ! |
lav_msg_stop(gettext("could not find `est' in lavpartable"))
|
| 123 |
} |
|
| 124 |
} |
|
| 125 |
} else {
|
|
| 126 | 1919x |
lavmodel <- lavobject@Model |
| 127 | 1919x |
lavpartable <- lavobject@ParTable |
| 128 | 1919x |
if (is.null(est)) {
|
| 129 | 20x |
est <- lav_object_inspect_est(lavobject) |
| 130 |
} |
|
| 131 |
} |
|
| 132 | ||
| 133 | 1921x |
if (is.null(partable)) {
|
| 134 | 20x |
partable <- lavpartable |
| 135 |
} |
|
| 136 | 1921x |
if (is.null(GLIST)) {
|
| 137 | 20x |
GLIST <- lavmodel@GLIST |
| 138 |
} |
|
| 139 | ||
| 140 | 1921x |
out <- est |
| 141 | 1921x |
N <- length(est) |
| 142 | 1921x |
stopifnot(N == length(partable$lhs)) |
| 143 | ||
| 144 | 1921x |
nmat <- lavmodel@nmat |
| 145 | ||
| 146 |
# compute ETA |
|
| 147 | 1921x |
if (is.null(lv.var)) {
|
| 148 | 1919x |
LV.ETA <- lav_model_veta( |
| 149 | 1919x |
lavmodel = lavmodel, |
| 150 | 1919x |
GLIST = GLIST |
| 151 |
) |
|
| 152 |
} |
|
| 153 | ||
| 154 | 1921x |
for (g in 1:lavmodel@nblocks) {
|
| 155 | 2245x |
ov.names <- lav_partable_vnames(lavpartable, "ov", block = g) # not user, |
| 156 |
# which may be incomplete |
|
| 157 | 2245x |
lv.names <- lav_partable_vnames(lavpartable, "lv", block = g) |
| 158 | ||
| 159 |
# shortcut: no latents in this block, nothing to do |
|
| 160 | 2245x |
if (length(lv.names) == 0L) {
|
| 161 | 275x |
next |
| 162 |
} |
|
| 163 | ||
| 164 |
# which mm belong to block g? |
|
| 165 | 1970x |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 166 | 1970x |
MLIST <- GLIST[mm.in.group] |
| 167 | ||
| 168 | 1970x |
if (is.null(lv.var)) {
|
| 169 | 1968x |
ETA2 <- diag(LV.ETA[[g]]) |
| 170 |
} else {
|
|
| 171 | 2x |
ETA2 <- lv.var[[g]] |
| 172 |
} |
|
| 173 |
# change negative values to NA |
|
| 174 | 1970x |
ETA2[ETA2 < 0] <- as.numeric(NA) |
| 175 | 1950x |
ETA <- sqrt(ETA2) |
| 176 | ||
| 177 |
# 1a. "=~" regular indicators |
|
| 178 | 1950x |
idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) & |
| 179 | 1950x |
partable$block == g) |
| 180 | 1950x |
out[idx] <- out[idx] * ETA[match(partable$lhs[idx], lv.names)] |
| 181 | ||
| 182 |
# 1b. "=~" regular higher-order lv indicators |
|
| 183 | 1950x |
idx <- which(partable$op == "=~" & !(partable$rhs %in% ov.names) & |
| 184 | 1950x |
partable$block == g) |
| 185 | 1950x |
out[idx] <- (out[idx] * ETA[match(partable$lhs[idx], lv.names)] |
| 186 | 1950x |
/ ETA[match(partable$rhs[idx], lv.names)]) |
| 187 | ||
| 188 |
# 1c. "=~" indicators that are both in ov and lv |
|
| 189 |
# idx <- which(partable$op == "=~" & partable$rhs %in% ov.names |
|
| 190 |
# & partable$rhs %in% lv.names & |
|
| 191 |
# partable$block == g) |
|
| 192 | ||
| 193 |
# 2. "~" regressions (and "<~") |
|
| 194 | 1950x |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 195 | 1950x |
partable$lhs %in% lv.names & |
| 196 | 1950x |
partable$block == g) |
| 197 | 1950x |
out[idx] <- out[idx] / ETA[match(partable$lhs[idx], lv.names)] |
| 198 | ||
| 199 | 1950x |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 200 | 1950x |
partable$rhs %in% lv.names & |
| 201 | 1950x |
partable$block == g) |
| 202 | 1950x |
out[idx] <- out[idx] * ETA[match(partable$rhs[idx], lv.names)] |
| 203 | ||
| 204 |
# 3a. "~~" ov |
|
| 205 |
# idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) & |
|
| 206 |
# partable$block == g) |
|
| 207 | ||
| 208 |
# 3b. "~~" lv |
|
| 209 |
# ATTENTION: in Mplus 4.1, the off-diagonal residual covariances |
|
| 210 |
# were computed by the formula cov(i,j) / sqrt(i.var*j.var) |
|
| 211 |
# were i.var and j.var where diagonal elements of ETA |
|
| 212 |
# |
|
| 213 |
# in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var |
|
| 214 |
# elements are the 'PSI' diagonal elements!! |
|
| 215 | ||
| 216 |
# variances |
|
| 217 | 1950x |
rv.idx <- which(partable$op == "~~" & partable$rhs %in% lv.names & |
| 218 | 1950x |
partable$lhs == partable$rhs & |
| 219 | 1950x |
partable$block == g) |
| 220 | 1950x |
out[rv.idx] <- (out[rv.idx] / ETA[match(partable$lhs[rv.idx], lv.names)] |
| 221 | 1950x |
/ ETA[match(partable$rhs[rv.idx], lv.names)]) |
| 222 | ||
| 223 |
# covariances lv |
|
| 224 |
# three types: |
|
| 225 |
# - only lhs is LV (and fixed.x = FALSE) |
|
| 226 |
# - only rhs is LV (and fixed.x = FALSE) |
|
| 227 |
# - both lhs and rhs are LV (regular case) |
|
| 228 | 1950x |
if (cov.std) {
|
| 229 | 1948x |
if (!is.complex(est[rv.idx])) {
|
| 230 | 1948x |
RV <- sqrt(abs(est[rv.idx])) # abs in case of heywood cases |
| 231 |
} else {
|
|
| 232 | ! |
RV <- sqrt(est[rv.idx]) |
| 233 |
} |
|
| 234 | 1948x |
rv.names <- partable$lhs[rv.idx] |
| 235 |
} |
|
| 236 | ||
| 237 |
# left |
|
| 238 | 1950x |
idx.lhs <- which(partable$op == "~~" & |
| 239 | 1950x |
partable$lhs %in% lv.names & |
| 240 | 1950x |
partable$lhs != partable$rhs & |
| 241 | 1950x |
partable$block == g) |
| 242 | 1950x |
if (length(idx.lhs) > 0L) {
|
| 243 | 1324x |
if (cov.std == FALSE) {
|
| 244 | 2x |
out[idx.lhs] <- |
| 245 | 2x |
(out[idx.lhs] / ETA[match(partable$lhs[idx.lhs], lv.names)]) |
| 246 |
} else {
|
|
| 247 | 1322x |
out[idx.lhs] <- |
| 248 | 1322x |
(out[idx.lhs] / RV[match(partable$lhs[idx.lhs], rv.names)]) |
| 249 |
} |
|
| 250 |
} |
|
| 251 | ||
| 252 |
# right |
|
| 253 | 1950x |
idx.rhs <- which(partable$op == "~~" & |
| 254 | 1950x |
partable$rhs %in% lv.names & |
| 255 | 1950x |
partable$lhs != partable$rhs & |
| 256 | 1950x |
partable$block == g) |
| 257 | 1950x |
if (length(idx.rhs) > 0L) {
|
| 258 | 1324x |
if (cov.std == FALSE) {
|
| 259 | 2x |
out[idx.rhs] <- |
| 260 | 2x |
(out[idx.rhs] / ETA[match(partable$rhs[idx.rhs], lv.names)]) |
| 261 |
} else {
|
|
| 262 | 1322x |
out[idx.rhs] <- |
| 263 | 1322x |
(out[idx.rhs] / RV[match(partable$rhs[idx.rhs], rv.names)]) |
| 264 |
} |
|
| 265 |
} |
|
| 266 | ||
| 267 | ||
| 268 |
# 4a. "~1" ov |
|
| 269 |
# idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) & |
|
| 270 |
# partable$block == g) |
|
| 271 | ||
| 272 |
# 4b. "~1" lv |
|
| 273 | 1950x |
idx <- which(partable$op == "~1" & partable$lhs %in% lv.names & |
| 274 | 1950x |
partable$block == g) |
| 275 | 1950x |
out[idx] <- out[idx] / ETA[match(partable$lhs[idx], lv.names)] |
| 276 |
} |
|
| 277 | ||
| 278 |
# 5a ":=" |
|
| 279 | 1901x |
idx <- which(partable$op == ":=") |
| 280 | 1901x |
if (length(idx) > 0L) {
|
| 281 | 86x |
x <- out[partable$free & !duplicated(partable$free)] |
| 282 | 86x |
out[idx] <- lavmodel@def.function(x) |
| 283 |
} |
|
| 284 | ||
| 285 |
# 5b "==" |
|
| 286 | 1901x |
idx <- which(partable$op == "==") |
| 287 | 1901x |
if (length(idx) > 0L) {
|
| 288 | 398x |
x <- out[partable$free & !duplicated(partable$free)] |
| 289 | 398x |
out[idx] <- lavmodel@ceq.function(x) |
| 290 |
} |
|
| 291 | ||
| 292 |
# 5c. "<" or ">" |
|
| 293 | 1901x |
idx <- which((partable$op == "<" | partable$op == ">")) |
| 294 | 1901x |
if (length(idx) > 0L) {
|
| 295 | 15x |
x <- out[partable$free & !duplicated(partable$free)] |
| 296 | 15x |
out[idx] <- lavmodel@cin.function(x) |
| 297 |
} |
|
| 298 | ||
| 299 | 1901x |
out |
| 300 |
} |
|
| 301 | ||
| 302 |
lav_standardize_all <- function(lavobject = NULL, |
|
| 303 |
partable = NULL, est = NULL, est.std = NULL, |
|
| 304 |
GLIST = NULL, cov.std = TRUE, ov.var = NULL, |
|
| 305 |
lv.var = NULL, |
|
| 306 |
lavmodel = NULL, lavpartable = NULL, |
|
| 307 |
cov.x = NULL) {
|
|
| 308 | 1881x |
if (is.null(lavobject)) {
|
| 309 | 2x |
stopifnot(!is.null(lavmodel)) |
| 310 | 2x |
stopifnot(!is.null(lavpartable)) |
| 311 | 2x |
if (is.null(est)) {
|
| 312 | ! |
if (!is.null(lavpartable$est)) {
|
| 313 | ! |
est <- lavpartable$est # if this changes, tag @TDJorgensen in commit message |
| 314 |
} else {
|
|
| 315 | ! |
lav_msg_stop(gettext("could not find `est' in lavpartable"))
|
| 316 |
} |
|
| 317 |
} |
|
| 318 |
} else {
|
|
| 319 | 1879x |
lavmodel <- lavobject@Model |
| 320 | 1879x |
lavpartable <- lavobject@ParTable |
| 321 | 1879x |
if (is.null(est)) {
|
| 322 | 77x |
est <- lav_object_inspect_est(lavobject) |
| 323 |
} |
|
| 324 | 1879x |
if (lavmodel@conditional.x) {
|
| 325 | 107x |
if (is.null(cov.x)) {
|
| 326 |
# try SampleStats slot |
|
| 327 |
# if("SampleStats" %in% slotNames(lavobject)) {
|
|
| 328 |
# cov.x <- lavobject@SampleStats@cov.x |
|
| 329 | 107x |
if (!is.null(lavobject@implied$cov.x[[1]])) {
|
| 330 | 107x |
cov.x <- lavobject@implied$cov.x # if this changes, tag @TDJorgensen in commit message |
| 331 |
} else {
|
|
| 332 |
# perhaps lavaanList object |
|
| 333 |
# extract it from GLIST per block |
|
| 334 | ! |
cov.x <- vector("list", length = lavmodel@nblocks)
|
| 335 | ! |
for (b in seq_len(lavmodel@nblocks)) {
|
| 336 |
# which mm belong to block b? |
|
| 337 | ! |
mm.in.block <- (seq_len(lavmodel@nmat[b]) + |
| 338 | ! |
cumsum(c(0, lavmodel@nmat))[b]) |
| 339 | ! |
MLIST <- lavmodel@GLIST[mm.in.block] |
| 340 | ! |
cov.x[[b]] <- MLIST[["cov.x"]] |
| 341 |
} |
|
| 342 |
} |
|
| 343 |
} |
|
| 344 |
} |
|
| 345 |
} |
|
| 346 | ||
| 347 | 1881x |
if (is.null(partable)) {
|
| 348 | 1881x |
partable <- lavpartable |
| 349 |
} |
|
| 350 | 1881x |
if (is.null(GLIST)) {
|
| 351 | 79x |
GLIST <- lavmodel@GLIST |
| 352 |
} |
|
| 353 | 1881x |
if (is.null(est.std)) {
|
| 354 | 1881x |
est.std <- lav_standardize_lv( |
| 355 | 1881x |
lavobject = lavobject, |
| 356 | 1881x |
partable = partable, est = est, GLIST = GLIST, |
| 357 | 1881x |
cov.std = cov.std, lv.var = lv.var, lavmodel = lavmodel, |
| 358 | 1881x |
lavpartable = lavpartable |
| 359 |
) |
|
| 360 |
} |
|
| 361 | ||
| 362 | 1861x |
out <- est.std |
| 363 | 1861x |
N <- length(est.std) |
| 364 | 1861x |
stopifnot(N == length(partable$lhs)) |
| 365 | ||
| 366 | 1861x |
VY <- lav_model_vy( |
| 367 | 1861x |
lavmodel = lavmodel, GLIST = GLIST, |
| 368 | 1861x |
diagonal.only = TRUE |
| 369 |
) |
|
| 370 | ||
| 371 | ||
| 372 | 1861x |
for (g in 1:lavmodel@nblocks) {
|
| 373 | 2177x |
ov.names <- lav_partable_vnames(lavpartable, "ov", block = g) # not user |
| 374 | 2177x |
lv.names <- lav_partable_vnames(lavpartable, "lv", block = g) |
| 375 | ||
| 376 | 2177x |
if (is.null(ov.var)) {
|
| 377 | 2175x |
OV2 <- VY[[g]] |
| 378 |
# replace zero values by NA (but keep negative values) |
|
| 379 | 2175x |
zero.idx <- which(abs(OV2) < .Machine$double.eps) |
| 380 | 2175x |
if (length(zero.idx) > 0L) {
|
| 381 | ! |
OV2[zero.idx] <- as.numeric(NA) |
| 382 |
} |
|
| 383 | ||
| 384 |
# replace negative values by NA (for sqrt) |
|
| 385 | 2175x |
tmp.OV2 <- OV2 |
| 386 | 2175x |
neg.idx <- which(tmp.OV2 < 0) |
| 387 | 2166x |
if (length(neg.idx) > 0L) {
|
| 388 | ! |
tmp.OV2[neg.idx] <- as.numeric(NA) |
| 389 |
} |
|
| 390 | 2166x |
OV <- sqrt(tmp.OV2) |
| 391 |
} else {
|
|
| 392 | 2x |
OV2 <- ov.var[[g]] |
| 393 | 2x |
OV <- sqrt(OV2) |
| 394 |
} |
|
| 395 | ||
| 396 | 2168x |
if (lavmodel@conditional.x) {
|
| 397 |
# extend OV with ov.names.x |
|
| 398 | 108x |
ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g) |
| 399 | 108x |
ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g) |
| 400 | 108x |
ov.names <- c(ov.names.nox, ov.names.x) |
| 401 | 108x |
OV2 <- c(OV2, diag(cov.x[[g]])) |
| 402 | 108x |
OV <- c(OV, sqrt(diag(cov.x[[g]]))) |
| 403 |
} |
|
| 404 | ||
| 405 |
# 1a. "=~" regular indicators |
|
| 406 | 2168x |
idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) & |
| 407 | 2168x |
partable$block == g) |
| 408 | 2168x |
out[idx] <- out[idx] / OV[match(partable$rhs[idx], ov.names)] |
| 409 | ||
| 410 |
# 1b. "=~" regular higher-order lv indicators |
|
| 411 | ||
| 412 |
# 1c. "=~" indicators that are both in ov and lv |
|
| 413 |
# idx <- which(partable$op == "=~" & partable$rhs %in% ov.names |
|
| 414 |
# & partable$rhs %in% lv.names & |
|
| 415 |
# partable$block == g) |
|
| 416 | ||
| 417 |
# 2. "~" regressions (and "<~") |
|
| 418 | 2168x |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 419 | 2168x |
partable$lhs %in% ov.names & |
| 420 | 2168x |
partable$block == g) |
| 421 | 2168x |
out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)] |
| 422 | ||
| 423 | 2168x |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 424 | 2168x |
partable$rhs %in% ov.names & |
| 425 | 2168x |
partable$block == g) |
| 426 | 2168x |
out[idx] <- out[idx] * OV[match(partable$rhs[idx], ov.names)] |
| 427 | ||
| 428 |
# 3a. "~~" ov |
|
| 429 |
# ATTENTION: in Mplus 4.1, the off-diagonal residual covariances |
|
| 430 |
# were computed by the formula cov(i,j) / sqrt(i.var*j.var) |
|
| 431 |
# were i.var and j.var where diagonal elements of OV |
|
| 432 |
# |
|
| 433 |
# in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var |
|
| 434 |
# elements are the 'THETA' diagonal elements!! |
|
| 435 | ||
| 436 |
# variances |
|
| 437 | 2168x |
rv.idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) & |
| 438 | 2168x |
partable$lhs == partable$rhs & |
| 439 | 2168x |
partable$block == g) |
| 440 |
# out[rv.idx] <- ( out[rv.idx] / OV[ match(partable$lhs[rv.idx], ov.names) ] |
|
| 441 |
# / OV[ match(partable$rhs[rv.idx], ov.names) ] ) |
|
| 442 | 2168x |
out[rv.idx] <- (out[rv.idx] / |
| 443 | 2168x |
OV2[match(partable$lhs[rv.idx], ov.names)]) |
| 444 | ||
| 445 |
# covariances ov |
|
| 446 |
# three types: |
|
| 447 |
# - only lhs is OV (and fixed.x = FALSE) |
|
| 448 |
# - only rhs is OV (and fixed.x = FALSE) |
|
| 449 |
# - both lhs and rhs are OV (regular case) |
|
| 450 | 2168x |
if (cov.std) {
|
| 451 | 2166x |
if (!is.complex(est[rv.idx])) {
|
| 452 | 2166x |
RV <- sqrt(abs(est[rv.idx])) |
| 453 |
} else {
|
|
| 454 | ! |
RV <- sqrt(est[rv.idx]) |
| 455 |
} |
|
| 456 | 2166x |
rv.names <- partable$lhs[rv.idx] |
| 457 |
} |
|
| 458 | ||
| 459 |
# left |
|
| 460 | 2168x |
idx.lhs <- which(partable$op == "~~" & |
| 461 | 2168x |
!(partable$lhs %in% lv.names) & |
| 462 | 2168x |
partable$lhs != partable$rhs & |
| 463 | 2168x |
partable$block == g) |
| 464 | 2168x |
if (length(idx.lhs) > 0L) {
|
| 465 | 448x |
if (cov.std == FALSE) {
|
| 466 | ! |
out[idx.lhs] <- |
| 467 | ! |
(out[idx.lhs] / OV[match(partable$lhs[idx.lhs], ov.names)]) |
| 468 |
} else {
|
|
| 469 | 448x |
out[idx.lhs] <- |
| 470 | 448x |
(out[idx.lhs] / RV[match(partable$lhs[idx.lhs], rv.names)]) |
| 471 |
} |
|
| 472 |
} |
|
| 473 | ||
| 474 |
# right |
|
| 475 | 2168x |
idx.rhs <- which(partable$op == "~~" & |
| 476 | 2168x |
!(partable$rhs %in% lv.names) & |
| 477 | 2168x |
partable$lhs != partable$rhs & |
| 478 | 2168x |
partable$block == g) |
| 479 | 2168x |
if (length(idx.rhs) > 0L) {
|
| 480 | 448x |
if (cov.std == FALSE) {
|
| 481 | ! |
out[idx.rhs] <- |
| 482 | ! |
(out[idx.rhs] / OV[match(partable$rhs[idx.rhs], ov.names)]) |
| 483 |
} else {
|
|
| 484 | 448x |
out[idx.rhs] <- |
| 485 | 448x |
(out[idx.rhs] / RV[match(partable$rhs[idx.rhs], rv.names)]) |
| 486 |
} |
|
| 487 |
} |
|
| 488 | ||
| 489 |
# 3b. "~~" lv |
|
| 490 |
# idx <- which(partable$op == "~~" & partable$rhs %in% lv.names & |
|
| 491 |
# partable$block == g) |
|
| 492 | ||
| 493 |
# 4a. "~1" ov |
|
| 494 | 2168x |
idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) & |
| 495 | 2168x |
partable$block == g) |
| 496 | 2168x |
out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)] |
| 497 | ||
| 498 |
# 4b. "~1" lv |
|
| 499 |
# idx <- which(partable$op == "~1" & partable$lhs %in% lv.names & |
|
| 500 |
# partable$block == g) |
|
| 501 | ||
| 502 |
# 4c. "|" thresholds |
|
| 503 | 2168x |
idx <- which(partable$op == "|" & !(partable$lhs %in% lv.names) & |
| 504 | 2168x |
partable$block == g) |
| 505 | 2168x |
out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)] |
| 506 | ||
| 507 |
# 4d. "~*~" scales |
|
| 508 | 2168x |
idx <- which(partable$op == "~*~" & !(partable$lhs %in% lv.names) & |
| 509 | 2168x |
partable$block == g) |
| 510 | 2168x |
out[idx] <- 1.0 |
| 511 |
} |
|
| 512 | ||
| 513 |
# 5a ":=" |
|
| 514 | 1852x |
idx <- which(partable$op == ":=") |
| 515 | 1852x |
if (length(idx) > 0L) {
|
| 516 | 84x |
x <- out[partable$free & !duplicated(partable$free)] |
| 517 | 84x |
out[idx] <- lavmodel@def.function(x) |
| 518 |
} |
|
| 519 | ||
| 520 |
# 5b "==" |
|
| 521 | 1852x |
idx <- which(partable$op == "==") |
| 522 | 1852x |
if (length(idx) > 0L) {
|
| 523 | 388x |
x <- out[partable$free & !duplicated(partable$free)] |
| 524 | 388x |
out[idx] <- lavmodel@ceq.function(x) |
| 525 |
} |
|
| 526 | ||
| 527 |
# 5c. "<" or ">" |
|
| 528 | 1852x |
idx <- which((partable$op == "<" | partable$op == ">")) |
| 529 | 1852x |
if (length(idx) > 0L) {
|
| 530 | 12x |
x <- out[partable$free & !duplicated(partable$free)] |
| 531 | 12x |
out[idx] <- lavmodel@cin.function(x) |
| 532 |
} |
|
| 533 | ||
| 534 | 1852x |
out |
| 535 |
} |
|
| 536 | ||
| 537 | ||
| 538 |
lav_standardize_all_nox <- function(lavobject = NULL, |
|
| 539 |
partable = NULL, est = NULL, est.std = NULL, |
|
| 540 |
GLIST = NULL, cov.std = TRUE, ov.var = NULL, |
|
| 541 |
lv.var = NULL, |
|
| 542 |
lavmodel = NULL, lavpartable = NULL, |
|
| 543 |
cov.x = NULL) {
|
|
| 544 | 20x |
if (is.null(lavobject)) {
|
| 545 | ! |
stopifnot(!is.null(lavmodel)) |
| 546 | ! |
stopifnot(!is.null(lavpartable)) |
| 547 | ! |
if (is.null(est)) {
|
| 548 | ! |
if (!is.null(lavpartable$est)) {
|
| 549 | ! |
est <- lavpartable$est # if this changes, tag @TDJorgensen in commit message |
| 550 |
} else {
|
|
| 551 | ! |
lav_msg_stop(gettext("could not find `est' in lavpartable"))
|
| 552 |
} |
|
| 553 |
} |
|
| 554 |
} else {
|
|
| 555 | 20x |
lavmodel <- lavobject@Model |
| 556 | 20x |
lavpartable <- lavobject@ParTable |
| 557 | 20x |
if (is.null(est)) {
|
| 558 | 20x |
est <- lav_object_inspect_est(lavobject) |
| 559 |
} |
|
| 560 | 20x |
if (lavmodel@conditional.x) {
|
| 561 | 1x |
if (is.null(cov.x)) {
|
| 562 |
# try SampleStats slot |
|
| 563 |
# if("SampleStats" %in% slotNames(lavobject)) {
|
|
| 564 |
# cov.x <- lavobject@SampleStats@cov.x |
|
| 565 | 1x |
if (!is.null(lavobject@implied$cov.x[[1]])) {
|
| 566 | 1x |
cov.x <- lavobject@implied$cov.x # if this changes, tag @TDJorgensen in commit message |
| 567 |
} else {
|
|
| 568 |
# perhaps lavaanList object |
|
| 569 |
# extract it from GLIST per block |
|
| 570 | ! |
cov.x <- vector("list", length = lavmodel@nblocks)
|
| 571 | ! |
for (b in seq_len(lavmodel@nblocks)) {
|
| 572 |
# which mm belong to block b? |
|
| 573 | ! |
mm.in.block <- (seq_len(lavmodel@nmat[b]) + |
| 574 | ! |
cumsum(c(0, lavmodel@nmat))[b]) |
| 575 | ! |
MLIST <- lavmodel@GLIST[mm.in.block] |
| 576 | ! |
cov.x[[b]] <- MLIST[["cov.x"]] |
| 577 |
} |
|
| 578 |
} |
|
| 579 |
} |
|
| 580 |
} |
|
| 581 |
} |
|
| 582 | ||
| 583 | 20x |
if (is.null(partable)) {
|
| 584 | 20x |
partable <- lavpartable |
| 585 |
} |
|
| 586 | 20x |
if (is.null(GLIST)) {
|
| 587 | 20x |
GLIST <- lavmodel@GLIST |
| 588 |
} |
|
| 589 | 20x |
if (is.null(est.std)) {
|
| 590 | 20x |
est.std <- lav_standardize_lv( |
| 591 | 20x |
lavobject = lavobject, |
| 592 | 20x |
partable = partable, est = est, GLIST = GLIST, |
| 593 | 20x |
cov.std = cov.std, lv.var = lv.var, lavmodel = lavmodel, |
| 594 | 20x |
lavpartable = lavpartable |
| 595 |
) |
|
| 596 |
} |
|
| 597 | ||
| 598 | ||
| 599 | 20x |
out <- est.std |
| 600 | 20x |
N <- length(est.std) |
| 601 | 20x |
stopifnot(N == length(partable$lhs)) |
| 602 | ||
| 603 | 20x |
VY <- lav_model_vy( |
| 604 | 20x |
lavmodel = lavmodel, GLIST = GLIST, |
| 605 | 20x |
diagonal.only = TRUE |
| 606 |
) |
|
| 607 | ||
| 608 | ||
| 609 | 20x |
for (g in 1:lavmodel@nblocks) {
|
| 610 | 24x |
ov.names <- lav_partable_vnames(lavpartable, "ov", block = g) |
| 611 | 24x |
ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g) |
| 612 | 24x |
ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g) |
| 613 | 24x |
lv.names <- lav_partable_vnames(lavpartable, "lv", block = g) |
| 614 | ||
| 615 | 24x |
if (is.null(ov.var)) {
|
| 616 | 24x |
OV2 <- VY[[g]] |
| 617 |
# replace zero values by NA (but keep negative values) |
|
| 618 | 24x |
zero.idx <- which(abs(OV2) < .Machine$double.eps) |
| 619 | 24x |
if (length(zero.idx) > 0L) {
|
| 620 | ! |
OV2[zero.idx] <- as.numeric(NA) |
| 621 |
} |
|
| 622 | ||
| 623 |
# replace negative values by NA (for sqrt) |
|
| 624 | 24x |
tmp.OV2 <- OV2 |
| 625 | 24x |
neg.idx <- which(tmp.OV2 < 0) |
| 626 | 24x |
if (length(neg.idx) > 0L) {
|
| 627 | ! |
tmp.OV2[neg.idx] <- as.numeric(NA) |
| 628 |
} |
|
| 629 | 24x |
OV <- sqrt(tmp.OV2) |
| 630 |
} else {
|
|
| 631 | ! |
OV2 <- ov.var[[g]] |
| 632 | ! |
OV <- sqrt(OV2) |
| 633 |
} |
|
| 634 | ||
| 635 | ||
| 636 | 24x |
if (lavmodel@conditional.x) {
|
| 637 |
# extend OV with ov.names.x |
|
| 638 | 1x |
ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g) |
| 639 | 1x |
ov.names <- c(ov.names.nox, ov.names.x) |
| 640 | 1x |
OV2 <- c(OV2, diag(cov.x[[g]])) |
| 641 | 1x |
OV <- c(OV, sqrt(diag(cov.x[[g]]))) |
| 642 |
} |
|
| 643 | ||
| 644 |
# 1a. "=~" regular indicators |
|
| 645 | 24x |
idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) & |
| 646 | 24x |
partable$block == g) |
| 647 | 24x |
out[idx] <- out[idx] / OV[match(partable$rhs[idx], ov.names)] |
| 648 | ||
| 649 |
# 1b. "=~" regular higher-order lv indicators |
|
| 650 | ||
| 651 |
# 1c. "=~" indicators that are both in ov and lv |
|
| 652 |
# idx <- which(partable$op == "=~" & partable$rhs %in% ov.names |
|
| 653 |
# & partable$rhs %in% lv.names & |
|
| 654 |
# partable$block == g) |
|
| 655 | ||
| 656 |
# 2. "~" regressions (and "<~") |
|
| 657 | 24x |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 658 | 24x |
partable$lhs %in% ov.names & |
| 659 | 24x |
partable$block == g) |
| 660 | 24x |
out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)] |
| 661 | ||
| 662 | 24x |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 663 | 24x |
partable$rhs %in% ov.names.nox & |
| 664 | 24x |
partable$block == g) |
| 665 | 24x |
out[idx] <- out[idx] * OV[match(partable$rhs[idx], ov.names.nox)] |
| 666 | ||
| 667 |
# 3a. "~~" ov |
|
| 668 |
# ATTENTION: in Mplus 4.1, the off-diagonal residual covariances |
|
| 669 |
# were computed by the formula cov(i,j) / sqrt(i.var*j.var) |
|
| 670 |
# were i.var and j.var where diagonal elements of OV |
|
| 671 |
# |
|
| 672 |
# in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var |
|
| 673 |
# elements are the 'THETA' diagonal elements!! |
|
| 674 | ||
| 675 |
# variances |
|
| 676 | 24x |
rv.idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) & |
| 677 | 24x |
!(partable$lhs %in% ov.names.x) & |
| 678 | 24x |
partable$lhs == partable$rhs & |
| 679 | 24x |
partable$block == g) |
| 680 |
# out[rv.idx] <- ( out[rv.idx] / OV[ match(partable$lhs[rv.idx], ov.names) ] |
|
| 681 |
# / OV[ match(partable$rhs[rv.idx], ov.names) ] ) |
|
| 682 | 24x |
out[rv.idx] <- (out[rv.idx] / |
| 683 | 24x |
OV2[match(partable$lhs[rv.idx], ov.names)]) |
| 684 | ||
| 685 |
# covariances ov |
|
| 686 |
# three types: |
|
| 687 |
# - only lhs is OV (and fixed.x = FALSE) |
|
| 688 |
# - only rhs is OV (and fixed.x = FALSE) |
|
| 689 |
# - both lhs and rhs are OV (regular case) |
|
| 690 | 24x |
if (cov.std) {
|
| 691 | 24x |
if (!is.complex(est[rv.idx])) {
|
| 692 | 24x |
RV <- sqrt(abs(est[rv.idx])) |
| 693 |
} else {
|
|
| 694 | ! |
RV <- sqrt(est[rv.idx]) |
| 695 |
} |
|
| 696 | 24x |
rv.names <- partable$lhs[rv.idx] |
| 697 |
} |
|
| 698 | ||
| 699 |
# left |
|
| 700 | 24x |
idx.lhs <- which(partable$op == "~~" & |
| 701 | 24x |
!(partable$lhs %in% lv.names) & |
| 702 | 24x |
!(partable$lhs %in% ov.names.x) & |
| 703 | 24x |
partable$lhs != partable$rhs & |
| 704 | 24x |
partable$block == g) |
| 705 | 24x |
if (length(idx.lhs) > 0L) {
|
| 706 | 4x |
if (cov.std == FALSE) {
|
| 707 | ! |
out[idx.lhs] <- |
| 708 | ! |
(out[idx.lhs] / OV[match(partable$lhs[idx.lhs], ov.names)]) |
| 709 |
} else {
|
|
| 710 | 4x |
out[idx.lhs] <- |
| 711 | 4x |
(out[idx.lhs] / RV[match(partable$lhs[idx.lhs], rv.names)]) |
| 712 |
} |
|
| 713 |
} |
|
| 714 | ||
| 715 |
# right |
|
| 716 | 24x |
idx.rhs <- which(partable$op == "~~" & |
| 717 | 24x |
!(partable$rhs %in% lv.names) & |
| 718 | 24x |
!(partable$rhs %in% ov.names.x) & |
| 719 | 24x |
partable$lhs != partable$rhs & |
| 720 | 24x |
partable$block == g) |
| 721 | 24x |
if (length(idx.rhs) > 0L) {
|
| 722 | 4x |
if (cov.std == FALSE) {
|
| 723 | ! |
out[idx.rhs] <- |
| 724 | ! |
(out[idx.rhs] / OV[match(partable$rhs[idx.rhs], ov.names)]) |
| 725 |
} else {
|
|
| 726 | 4x |
out[idx.rhs] <- |
| 727 | 4x |
(out[idx.rhs] / RV[match(partable$rhs[idx.rhs], rv.names)]) |
| 728 |
} |
|
| 729 |
} |
|
| 730 | ||
| 731 |
# 3b. "~~" lv |
|
| 732 |
# idx <- which(partable$op == "~~" & partable$rhs %in% lv.names & |
|
| 733 |
# partable$block == g) |
|
| 734 | ||
| 735 |
# 4a. "~1" ov |
|
| 736 | 24x |
idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) & |
| 737 | 24x |
!(partable$lhs %in% ov.names.x) & |
| 738 | 24x |
partable$block == g) |
| 739 | 24x |
out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)] |
| 740 | ||
| 741 |
# 4b. "~1" lv |
|
| 742 |
# idx <- which(partable$op == "~1" & partable$lhs %in% lv.names & |
|
| 743 |
# partable$block == g) |
|
| 744 | ||
| 745 |
# 4c. "|" thresholds |
|
| 746 | 24x |
idx <- which(partable$op == "|" & !(partable$lhs %in% lv.names) & |
| 747 | 24x |
partable$block == g) |
| 748 | 24x |
out[idx] <- out[idx] / OV[match(partable$lhs[idx], ov.names)] |
| 749 | ||
| 750 |
# 4d. "~*~" scales |
|
| 751 | 24x |
idx <- which(partable$op == "~*~" & !(partable$lhs %in% lv.names) & |
| 752 | 24x |
partable$block == g) |
| 753 | 24x |
out[idx] <- 1.0 |
| 754 |
} |
|
| 755 | ||
| 756 |
# 5a ":=" |
|
| 757 | 20x |
idx <- which(partable$op == ":=") |
| 758 | 20x |
if (length(idx) > 0L) {
|
| 759 | 1x |
x <- out[partable$free & !duplicated(partable$free)] |
| 760 | 1x |
out[idx] <- lavmodel@def.function(x) |
| 761 |
} |
|
| 762 | ||
| 763 |
# 5b "==" |
|
| 764 | 20x |
idx <- which(partable$op == "==") |
| 765 | 20x |
if (length(idx) > 0L) {
|
| 766 | 5x |
x <- out[partable$free & !duplicated(partable$free)] |
| 767 | 5x |
out[idx] <- lavmodel@ceq.function(x) |
| 768 |
} |
|
| 769 | ||
| 770 |
# 5c. "<" or ">" |
|
| 771 | 20x |
idx <- which((partable$op == "<" | partable$op == ">")) |
| 772 | 20x |
if (length(idx) > 0L) {
|
| 773 | 1x |
x <- out[partable$free & !duplicated(partable$free)] |
| 774 | 1x |
out[idx] <- lavmodel@cin.function(x) |
| 775 |
} |
|
| 776 | ||
| 777 | 20x |
out |
| 778 |
} |
|
| 779 | ||
| 780 |
lav_unstandardize_ov <- function(partable, ov.var = NULL, cov.std = TRUE) {
|
|
| 781 |
# check if ustart is missing; if so, look for est |
|
| 782 | ! |
if (is.null(partable$ustart)) {
|
| 783 | ! |
partable$ustart <- partable$est |
| 784 |
} |
|
| 785 | ||
| 786 |
# check if block is missing |
|
| 787 | ! |
if (is.null(partable$block)) {
|
| 788 | ! |
partable$block <- rep(1L, length(partable$ustart)) |
| 789 |
} |
|
| 790 | ||
| 791 | ! |
stopifnot(!any(is.na(partable$ustart))) |
| 792 | ! |
est <- out <- partable$ustart |
| 793 | ! |
N <- length(est) |
| 794 | ||
| 795 |
# nblocks |
|
| 796 | ! |
nblocks <- lav_partable_nblocks(partable) |
| 797 | ||
| 798 |
# if ov.var is NOT a list, make a list |
|
| 799 | ! |
if (!is.list(ov.var)) {
|
| 800 | ! |
tmp <- ov.var |
| 801 | ! |
ov.var <- vector("list", length = nblocks)
|
| 802 | ! |
ov.var[1:nblocks] <- list(tmp) |
| 803 |
} |
|
| 804 | ||
| 805 | ! |
for (g in 1:nblocks) {
|
| 806 | ! |
ov.names <- lav_partable_vnames(partable, "ov", block = g) # not user |
| 807 | ! |
lv.names <- lav_partable_vnames(partable, "lv", block = g) |
| 808 | ||
| 809 | ! |
OV <- sqrt(ov.var[[g]]) |
| 810 | ||
| 811 |
# 1a. "=~" regular indicators |
|
| 812 | ! |
idx <- which(partable$op == "=~" & !(partable$rhs %in% lv.names) & |
| 813 | ! |
partable$block == g) |
| 814 | ! |
out[idx] <- out[idx] * OV[match(partable$rhs[idx], ov.names)] |
| 815 | ||
| 816 |
# 1b. "=~" regular higher-order lv indicators |
|
| 817 | ||
| 818 |
# 1c. "=~" indicators that are both in ov and lv |
|
| 819 |
# idx <- which(partable$op == "=~" & partable$rhs %in% ov.names |
|
| 820 |
# & partable$rhs %in% lv.names & |
|
| 821 |
# partable$block == g) |
|
| 822 | ||
| 823 |
# 2. "~" regressions (and "<~") |
|
| 824 | ! |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 825 | ! |
partable$lhs %in% ov.names & |
| 826 | ! |
partable$block == g) |
| 827 | ! |
out[idx] <- out[idx] * OV[match(partable$lhs[idx], ov.names)] |
| 828 | ||
| 829 | ! |
idx <- which((partable$op == "~" | partable$op == "<~") & |
| 830 | ! |
partable$rhs %in% ov.names & |
| 831 | ! |
partable$block == g) |
| 832 | ! |
out[idx] <- out[idx] / OV[match(partable$rhs[idx], ov.names)] |
| 833 | ||
| 834 |
# 3a. "~~" ov |
|
| 835 |
# ATTENTION: in Mplus 4.1, the off-diagonal residual covariances |
|
| 836 |
# were computed by the formula cov(i,j) / sqrt(i.var*j.var) |
|
| 837 |
# were i.var and j.var where diagonal elements of OV |
|
| 838 |
# |
|
| 839 |
# in Mplus 6.1 (but also AMOS and EQS), the i.var and j.var |
|
| 840 |
# elements are the 'THETA' diagonal elements!! |
|
| 841 | ||
| 842 |
# variances |
|
| 843 | ! |
rv.idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) & |
| 844 | ! |
partable$lhs == partable$rhs & |
| 845 | ! |
partable$block == g) |
| 846 | ! |
out[rv.idx] <- (out[rv.idx] * OV[match(partable$lhs[rv.idx], ov.names)] |
| 847 | ! |
* OV[match(partable$rhs[rv.idx], ov.names)]) |
| 848 | ||
| 849 |
# covariances |
|
| 850 | ! |
idx <- which(partable$op == "~~" & !(partable$lhs %in% lv.names) & |
| 851 | ! |
partable$lhs != partable$rhs & |
| 852 | ! |
partable$block == g) |
| 853 | ! |
if (length(idx) > 0L) {
|
| 854 | ! |
if (cov.std == FALSE) {
|
| 855 | ! |
out[idx] <- (out[idx] * OV[match(partable$lhs[idx], ov.names)] |
| 856 | ! |
* OV[match(partable$rhs[idx], ov.names)]) |
| 857 |
} else {
|
|
| 858 | ! |
if (!is.complex(out[rv.idx])) {
|
| 859 | ! |
RV <- sqrt(abs(out[rv.idx])) |
| 860 |
} else {
|
|
| 861 | ! |
RV <- sqrt(out[rv.idx]) |
| 862 |
} |
|
| 863 | ! |
rv.names <- partable$lhs[rv.idx] |
| 864 | ! |
out[idx] <- (out[idx] * RV[match(partable$lhs[idx], rv.names)] |
| 865 | ! |
* RV[match(partable$rhs[idx], rv.names)]) |
| 866 |
} |
|
| 867 |
} |
|
| 868 | ||
| 869 |
# 3b. "~~" lv |
|
| 870 |
# idx <- which(partable$op == "~~" & partable$rhs %in% lv.names & |
|
| 871 |
# partable$block == g) |
|
| 872 | ||
| 873 |
# 4a. "~1" ov |
|
| 874 | ! |
idx <- which(partable$op == "~1" & !(partable$lhs %in% lv.names) & |
| 875 | ! |
partable$block == g) |
| 876 | ! |
out[idx] <- out[idx] * OV[match(partable$lhs[idx], ov.names)] |
| 877 | ||
| 878 |
# 4b. "~1" lv |
|
| 879 |
# idx <- which(partable$op == "~1" & partable$lhs %in% lv.names & |
|
| 880 |
# partable$block == g) |
|
| 881 |
} |
|
| 882 | ||
| 883 |
# 5a ":=" |
|
| 884 |
# 5b "==" |
|
| 885 |
# 5c. "<" or ">" |
|
| 886 | ||
| 887 | ! |
out |
| 888 |
} |
| 1 |
# extract info from model |
|
| 2 |
lav_model_plotinfo <- function(model = NULL, infile = NULL, varlv = FALSE) {
|
|
| 3 | ! |
if (is.null(model) == is.null(infile)) {
|
| 4 | ! |
lav_msg_stop(gettext("either model or infile must be specified"))
|
| 5 |
} |
|
| 6 | ! |
edge_label <- function(label, fix) {
|
| 7 | ! |
if (label == "" && fix == "") {
|
| 8 | ! |
return("")
|
| 9 |
} |
|
| 10 | ! |
if (label == "") {
|
| 11 | ! |
return(fix) |
| 12 |
} |
|
| 13 | ! |
if (fix == "") {
|
| 14 | ! |
return(label) |
| 15 |
} |
|
| 16 | ! |
paste(label, fix, sep = "=") |
| 17 |
} |
|
| 18 | ! |
if (!is.null(infile)) {
|
| 19 | ! |
if (!file.exists(infile)) {
|
| 20 | ! |
lav_msg_stop(gettextf("Infile %s not found!", infile))
|
| 21 |
} |
|
| 22 | ! |
model <- readLines(infile) |
| 23 |
} |
|
| 24 | ! |
if (inherits(model, "lavaan")) {
|
| 25 | ! |
model <- as.data.frame(model@ParTable) |
| 26 | ! |
model <- model[model$user == 1, ] |
| 27 | ! |
model$fixed <- round(model$est, 3L) |
| 28 | ! |
if (max(model$block) == 1L) model$block <- rep(0L, length(model$block)) |
| 29 | ! |
model$est <- NULL |
| 30 |
} |
|
| 31 | ! |
if (is.list(model) && !is.null(model$op) && !is.null(model$lhs) && |
| 32 | ! |
!is.null(model$rhs) && !is.null(model$label) && |
| 33 | ! |
!is.null(model$fixed)) {
|
| 34 | ! |
tbl <- as.data.frame(model) |
| 35 | ! |
} else if (is.character(model)) {
|
| 36 | ! |
tbl <- lavParseModelString( |
| 37 | ! |
model.syntax = model, |
| 38 | ! |
as.data.frame. = TRUE |
| 39 |
) |
|
| 40 |
} else {
|
|
| 41 | ! |
lav_msg_stop(gettext( |
| 42 | ! |
"model, or content of infile, not in interpretable form!" |
| 43 |
)) |
|
| 44 |
} |
|
| 45 | ! |
if (is.null(tbl$block)) {
|
| 46 | ! |
tbl$block <- 0L |
| 47 | ! |
} else if (all(tbl$block == tbl$block[1L])) {
|
| 48 | ! |
tbl$block <- 0L |
| 49 |
} else {
|
|
| 50 | ! |
blockmin <- min(tbl$block) |
| 51 | ! |
tbl$block[tbl$block == blockmin] <- 999L |
| 52 | ! |
tbl$block[tbl$block != 999L] <- 2L |
| 53 | ! |
tbl$block[tbl$block == 999L] <- 1L |
| 54 |
} |
|
| 55 | ! |
create_node_id <- function(blok, naam) {
|
| 56 | ! |
if (blok == 0L) {
|
| 57 | ! |
naam |
| 58 |
} else {
|
|
| 59 | ! |
paste(blok, naam, sep = ".") |
| 60 |
} |
|
| 61 |
} |
|
| 62 | ! |
maxedges <- nrow(tbl) |
| 63 | ! |
maxnodes <- 2 * maxedges |
| 64 | ! |
nodes <- data.frame( |
| 65 | ! |
id = character(maxnodes), |
| 66 | ! |
naam = character(maxnodes), |
| 67 | ! |
tiepe = character(maxnodes), # ov, lv, varlv, cv, wov, bov, const |
| 68 |
# cv: composite; wov = within; bov = between; const = intercept |
|
| 69 | ! |
blok = integer(maxnodes) |
| 70 |
) |
|
| 71 | ! |
edges <- data.frame( |
| 72 | ! |
id = integer(maxedges), |
| 73 | ! |
label = character(maxedges), |
| 74 | ! |
van = character(maxedges), |
| 75 | ! |
naar = character(maxedges), |
| 76 | ! |
tiepe = character(maxedges) # lavaan operator, behalve ~~ self -> "~~~" |
| 77 |
) |
|
| 78 | ! |
curnode <- 0L |
| 79 | ! |
curedge <- 0L |
| 80 | ! |
for (i in seq.int(nrow(tbl))) {
|
| 81 | ! |
if (tbl$op[i] == "=~") {
|
| 82 |
#### =~ : is manifested by #### |
|
| 83 |
# lhs node |
|
| 84 | ! |
jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]), |
| 85 | ! |
nodes$id, nomatch = 0L) |
| 86 | ! |
if (jl == 0L) {
|
| 87 | ! |
curnode <- curnode + 1L |
| 88 | ! |
jl <- curnode |
| 89 | ! |
nodes$naam[curnode] <- tbl$lhs[i] |
| 90 | ! |
nodes$tiepe[curnode] <- "lv" |
| 91 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 92 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 93 | ! |
nodes$naam[curnode]) |
| 94 |
} else {
|
|
| 95 | ! |
nodes$tiepe[jl] <- "lv" |
| 96 |
} |
|
| 97 |
# rhs node |
|
| 98 | ! |
jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]), |
| 99 | ! |
nodes$id, nomatch = 0L) |
| 100 | ! |
nodetype <- "ov" |
| 101 | ! |
if (length(unique(tbl$block[tbl$rhs == tbl$rhs[i]])) > 1L) {
|
| 102 | ! |
nodetype <- switch(tbl$block[i], |
| 103 | ! |
"wov", |
| 104 | ! |
"bov" |
| 105 |
) |
|
| 106 |
} |
|
| 107 | ! |
if (jr == 0L) {
|
| 108 | ! |
curnode <- curnode + 1L |
| 109 | ! |
jr <- curnode |
| 110 | ! |
nodes$naam[curnode] <- tbl$rhs[i] |
| 111 | ! |
nodes$tiepe[curnode] <- nodetype |
| 112 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 113 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 114 | ! |
nodes$naam[curnode]) |
| 115 |
} else {
|
|
| 116 | ! |
if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype |
| 117 |
} |
|
| 118 |
# edge |
|
| 119 | ! |
curedge <- curedge + 1L |
| 120 | ! |
edges$id[curedge] <- curedge |
| 121 | ! |
edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i]) |
| 122 | ! |
edges$van[curedge] <- nodes$id[jl] |
| 123 | ! |
edges$naar[curedge] <- nodes$id[jr] |
| 124 | ! |
edges$tiepe[curedge] <- tbl$op[i] |
| 125 | ! |
} else if (tbl$op[i] == "<~") {
|
| 126 |
#### <~ : is a result of #### |
|
| 127 |
# lhs node |
|
| 128 | ! |
jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]), |
| 129 | ! |
nodes$id, nomatch = 0L) |
| 130 | ! |
if (jl == 0L) {
|
| 131 | ! |
curnode <- curnode + 1L |
| 132 | ! |
jl <- curnode |
| 133 | ! |
nodes$naam[curnode] <- tbl$lhs[i] |
| 134 | ! |
nodes$tiepe[curnode] <- "cv" |
| 135 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 136 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 137 | ! |
nodes$naam[curnode]) |
| 138 |
} else {
|
|
| 139 | ! |
nodes$tiepe[jl] <- "cv" |
| 140 |
} |
|
| 141 |
# rhs node |
|
| 142 | ! |
jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]), |
| 143 | ! |
nodes$id, nomatch = 0L) |
| 144 | ! |
nodetype <- "ov" |
| 145 | ! |
if (length(unique(tbl$block[tbl$rhs == tbl$rhs[i]])) > 1L) {
|
| 146 | ! |
nodetype <- switch(tbl$block[i], |
| 147 | ! |
"wov", |
| 148 | ! |
"bov" |
| 149 |
) |
|
| 150 |
} |
|
| 151 | ! |
if (jr == 0L) {
|
| 152 | ! |
curnode <- curnode + 1L |
| 153 | ! |
jr <- curnode |
| 154 | ! |
nodes$naam[curnode] <- tbl$rhs[i] |
| 155 | ! |
nodes$tiepe[curnode] <- nodetype |
| 156 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 157 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 158 | ! |
nodes$naam[curnode]) |
| 159 |
} else {
|
|
| 160 | ! |
if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype |
| 161 |
} |
|
| 162 |
# edge |
|
| 163 | ! |
curedge <- curedge + 1L |
| 164 | ! |
edges$id[curedge] <- curedge |
| 165 | ! |
edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i]) |
| 166 | ! |
edges$van[curedge] <- nodes$id[jr] |
| 167 | ! |
edges$naar[curedge] <- nodes$id[jl] |
| 168 | ! |
edges$tiepe[curedge] <- tbl$op[i] |
| 169 | ! |
} else if (tbl$op[i] == "~") {
|
| 170 |
#### ~ : is regressed on #### |
|
| 171 |
# lhs node |
|
| 172 | ! |
jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]), |
| 173 | ! |
nodes$id, nomatch = 0L) |
| 174 | ! |
nodetype <- "ov" |
| 175 | ! |
if (length(unique(tbl$block[tbl$rhs == tbl$rhs[i]])) > 1L) {
|
| 176 | ! |
nodetype <- switch(tbl$block[i], |
| 177 | ! |
"wov", |
| 178 | ! |
"bov" |
| 179 |
) |
|
| 180 |
} |
|
| 181 | ! |
if (jl == 0L) {
|
| 182 | ! |
curnode <- curnode + 1L |
| 183 | ! |
jl <- curnode |
| 184 | ! |
nodes$naam[curnode] <- tbl$lhs[i] |
| 185 | ! |
nodes$tiepe[curnode] <- nodetype |
| 186 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 187 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 188 | ! |
nodes$naam[curnode]) |
| 189 |
} else {
|
|
| 190 | ! |
if (nodes$tiepe[jl] == "") nodes$tiepe[jl] <- nodetype |
| 191 |
} |
|
| 192 |
# rhs node |
|
| 193 | ! |
jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]), |
| 194 | ! |
nodes$id, nomatch = 0L) |
| 195 | ! |
if (jr == 0L) {
|
| 196 | ! |
curnode <- curnode + 1L |
| 197 | ! |
jr <- curnode |
| 198 | ! |
nodes$naam[curnode] <- tbl$rhs[i] |
| 199 | ! |
nodes$tiepe[curnode] <- nodetype |
| 200 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 201 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 202 | ! |
nodes$naam[curnode]) |
| 203 |
} else {
|
|
| 204 | ! |
if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype |
| 205 |
} |
|
| 206 |
# edge |
|
| 207 | ! |
curedge <- curedge + 1L |
| 208 | ! |
edges$id[curedge] <- curedge |
| 209 | ! |
edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i]) |
| 210 | ! |
edges$van[curedge] <- nodes$id[jr] |
| 211 | ! |
edges$naar[curedge] <- nodes$id[jl] |
| 212 | ! |
edges$tiepe[curedge] <- tbl$op[i] |
| 213 | ! |
} else if (tbl$op[i] == "~1") {
|
| 214 |
#### ~1 : intercept #### |
|
| 215 |
# lhs node |
|
| 216 | ! |
jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]), |
| 217 | ! |
nodes$id, nomatch = 0L) |
| 218 | ! |
nodetype <- "ov" |
| 219 | ! |
if (length(unique(tbl$block[tbl$rhs == tbl$lhs[i] | |
| 220 | ! |
tbl$lhs == tbl$lhs[i]])) > 1L) {
|
| 221 | ! |
nodetype <- switch(tbl$block[i], |
| 222 | ! |
"wov", |
| 223 | ! |
"bov" |
| 224 |
) |
|
| 225 |
} |
|
| 226 | ! |
if (jl == 0L) {
|
| 227 | ! |
curnode <- curnode + 1L |
| 228 | ! |
jl <- curnode |
| 229 | ! |
nodes$naam[curnode] <- tbl$lhs[i] |
| 230 | ! |
nodes$tiepe[curnode] <- nodetype |
| 231 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 232 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 233 | ! |
nodes$naam[curnode]) |
| 234 |
} else {
|
|
| 235 | ! |
if (nodes$tiepe[jl] == "") nodes$tiepe[jl] <- nodetype |
| 236 |
} |
|
| 237 |
# rhs node |
|
| 238 | ! |
jr <- 0L |
| 239 | ! |
curnode <- curnode + 1L |
| 240 | ! |
jr <- curnode |
| 241 | ! |
nodes$naam[curnode] <- paste0("1van", tbl$lhs[i])
|
| 242 | ! |
nodes$tiepe[curnode] <- "const" |
| 243 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 244 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 245 | ! |
nodes$naam[curnode]) |
| 246 |
# edge |
|
| 247 | ! |
curedge <- curedge + 1L |
| 248 | ! |
edges$id[curedge] <- curedge |
| 249 | ! |
edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i]) |
| 250 | ! |
edges$van[curedge] <- nodes$id[jr] |
| 251 | ! |
edges$naar[curedge] <- nodes$id[jl] |
| 252 | ! |
edges$tiepe[curedge] <- "~" |
| 253 | ! |
} else if (tbl$op[i] == "~~") {
|
| 254 |
#### ~~ : is correlated with #### |
|
| 255 |
# lhs node |
|
| 256 | ! |
jl <- match(create_node_id(tbl$block[i], tbl$lhs[i]), |
| 257 | ! |
nodes$id, nomatch = 0L) |
| 258 | ! |
nodetype <- "ov" |
| 259 | ! |
if (length(unique(tbl$block[tbl$rhs == tbl$lhs[i] | |
| 260 | ! |
tbl$lhs == tbl$lhs[i]])) > 1L) {
|
| 261 | ! |
nodetype <- switch(tbl$block[i], |
| 262 | ! |
"wov", |
| 263 | ! |
"bov" |
| 264 |
) |
|
| 265 |
} |
|
| 266 | ! |
if (jl == 0L) {
|
| 267 | ! |
curnode <- curnode + 1L |
| 268 | ! |
jl <- curnode |
| 269 | ! |
nodes$naam[curnode] <- tbl$lhs[i] |
| 270 | ! |
nodes$tiepe[curnode] <- nodetype |
| 271 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 272 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 273 | ! |
nodes$naam[curnode]) |
| 274 |
} else {
|
|
| 275 | ! |
if (nodes$tiepe[jl] == "") nodes$tiepe[jl] <- nodetype |
| 276 |
} |
|
| 277 |
# rhs node |
|
| 278 | ! |
jr <- match(create_node_id(tbl$block[i], tbl$rhs[i]), |
| 279 | ! |
nodes$id, nomatch = 0L) |
| 280 | ! |
nodetype <- "ov" |
| 281 | ! |
if (length(unique(tbl$block[tbl$rhs == tbl$lhs[i] | |
| 282 | ! |
tbl$lhs == tbl$lhs[i]])) > 1L) {
|
| 283 | ! |
nodetype <- switch(tbl$block[i], |
| 284 | ! |
"wov", |
| 285 | ! |
"bov" |
| 286 |
) |
|
| 287 |
} |
|
| 288 | ! |
if (jr == 0L) {
|
| 289 | ! |
curnode <- curnode + 1L |
| 290 | ! |
jr <- curnode |
| 291 | ! |
nodes$naam[curnode] <- tbl$rhs[i] |
| 292 | ! |
nodes$tiepe[curnode] <- nodetype |
| 293 | ! |
nodes$blok[curnode] <- tbl$block[i] |
| 294 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 295 | ! |
nodes$naam[curnode]) |
| 296 |
} else {
|
|
| 297 | ! |
if (nodes$tiepe[jr] == "") nodes$tiepe[jr] <- nodetype |
| 298 |
} |
|
| 299 |
# edge |
|
| 300 | ! |
curedge <- curedge + 1L |
| 301 | ! |
edges$id[curedge] <- curedge |
| 302 | ! |
edges$label[curedge] <- edge_label(tbl$label[i], tbl$fixed[i]) |
| 303 | ! |
if (varlv && jl == jr) { # prepare for handling varlv
|
| 304 | ! |
edges$label[curedge] <- paste(tbl$label[i], tbl$fixed[i], sep = "=") |
| 305 |
} |
|
| 306 | ! |
edges$van[curedge] <- nodes$id[jr] |
| 307 | ! |
edges$naar[curedge] <- nodes$id[jl] |
| 308 | ! |
edges$tiepe[curedge] <- ifelse(jl == jr, "~~~", tbl$op[i]) |
| 309 |
} |
|
| 310 |
} |
|
| 311 |
# aanpassingen voor varlv |
|
| 312 | ! |
if (varlv && any(edges$tiepe == "~~~")) {
|
| 313 |
# wijzigen varianties |
|
| 314 | ! |
welke <- which(edges$tiepe == "~~~") |
| 315 | ! |
varlvnodes <- rep(0L, length(welke)) |
| 316 | ! |
lvnodes <- rep(0L, length(welke)) |
| 317 | ! |
for (ji in seq_along(welke)) {
|
| 318 | ! |
j <- welke[ji] |
| 319 | ! |
curnode <- curnode + 1L |
| 320 | ! |
nodes$naam[curnode] <- gsub("=.*$", "", edges$label[j])
|
| 321 | ! |
if (nodes$naam[curnode] == "") |
| 322 | ! |
nodes$naam[curnode] <- paste0("var", edges$van[j])
|
| 323 | ! |
nodes$tiepe[curnode] <- "varlv" |
| 324 | ! |
nodes$blok[curnode] <- nodes$blok[which(nodes$id == edges$van[j])[[1L]]] |
| 325 | ! |
nodes$id[curnode] <- create_node_id(nodes$blok[curnode], |
| 326 | ! |
nodes$naam[curnode]) |
| 327 | ! |
varlvnodes[ji] <- curnode |
| 328 | ! |
lvnodes[ji] <- edges$van[j] |
| 329 | ! |
edges$van[j] <- nodes$id[curnode] |
| 330 | ! |
edges$tiepe[j] <- "~." |
| 331 | ! |
edges$label[j] <- ifelse(grepl("=", edges$label[j]),
|
| 332 | ! |
gsub("^.*=", "", edges$label[j]), ""
|
| 333 |
) |
|
| 334 |
} |
|
| 335 |
# wijzigen covarianties |
|
| 336 | ! |
for (j1 in seq_along(welke)) {
|
| 337 | ! |
for (j2 in seq_along(welke)) {
|
| 338 | ! |
if (j1 != j2 && any(edges$tiepe == "~~" & |
| 339 | ! |
edges$van == lvnodes[j1] & edges$naar == lvnodes[j2])) {
|
| 340 | ! |
edg <- which(edges$tiepe == "~~" & |
| 341 | ! |
edges$van == lvnodes[j1] & edges$naar == lvnodes[j2])[[1L]] |
| 342 | ! |
edges$van[edg] <- varlvnodes[j1] |
| 343 | ! |
edges$naar[edg] <- varlvnodes[j2] |
| 344 |
} |
|
| 345 |
} |
|
| 346 |
} |
|
| 347 |
} |
|
| 348 | ! |
nodes <- nodes[seq.int(curnode), ] |
| 349 | ! |
edges <- edges[seq.int(curedge), ] |
| 350 | ! |
edges$label <- trimws(edges$label) |
| 351 | ! |
if (any(grepl("[<>&]", c(edges$label, nodes$naam)))) {
|
| 352 | ! |
lav_msg_warn(gettext( |
| 353 | ! |
"some labels contain '<', '>' or '&', which can result in errors!" |
| 354 |
)) |
|
| 355 |
} |
|
| 356 | ! |
list(nodes = nodes, edges = edges) |
| 357 |
} |
| 1 |
lav_pml_plrt2 <- function(lavobject = NULL, lavmodel = NULL, lavdata = NULL, |
|
| 2 |
lavsamplestats = NULL, lavpartable = NULL, |
|
| 3 |
lavoptions = NULL, x = NULL, VCOV = NULL, |
|
| 4 |
lavcache = NULL) {
|
|
| 5 | ! |
lavpta <- NULL |
| 6 | ! |
if (!is.null(lavobject)) {
|
| 7 | ! |
lavmodel <- lavobject@Model |
| 8 | ! |
lavdata <- lavobject@Data |
| 9 | ! |
lavoptions <- lavobject@Options |
| 10 | ! |
lavsamplestats <- lavobject@SampleStats |
| 11 | ! |
lavcache <- lavobject@Cache |
| 12 | ! |
lavpartable <- lav_partable_set_cache(lavobject@ParTable, lavobject@pta) |
| 13 | ! |
lavpta <- lavobject@pta |
| 14 |
} |
|
| 15 | ! |
if (is.null(lavpta)) {
|
| 16 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 17 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 18 |
} |
|
| 19 | ||
| 20 | ! |
if (is.null(x)) {
|
| 21 |
# compute 'fx' = objective function value |
|
| 22 |
# (NOTE: since 0.5-18, NOT divided by N!!) |
|
| 23 | ! |
fx <- lav_model_objective( |
| 24 | ! |
lavmodel = lavmodel, |
| 25 | ! |
lavsamplestats = lavsamplestats, |
| 26 | ! |
lavdata = lavdata, |
| 27 | ! |
lavcache = lavcache |
| 28 |
) |
|
| 29 | ! |
H0.fx <- as.numeric(fx) |
| 30 | ! |
H0.fx.group <- attr(fx, "fx.group") |
| 31 |
} else {
|
|
| 32 | ! |
H0.fx <- attr(attr(x, "fx"), "fx.pml") |
| 33 | ! |
H0.fx.group <- attr(attr(x, "fx"), "fx.group") |
| 34 |
} |
|
| 35 | ||
| 36 |
# fit a saturated model 'fittedSat' |
|
| 37 | ! |
ModelSat <- lav_partable_unrestricted( |
| 38 | ! |
lavobject = NULL, |
| 39 | ! |
lavdata = lavdata, |
| 40 | ! |
lavoptions = lavoptions, |
| 41 | ! |
lavpta = lavpta, |
| 42 | ! |
lavsamplestats = lavsamplestats |
| 43 |
) |
|
| 44 | ||
| 45 |
# FIXME: se="none", test="none"?? |
|
| 46 | ! |
Options <- lavoptions |
| 47 | ! |
Options$se <- "none" |
| 48 | ! |
Options$test <- "none" |
| 49 | ! |
Options$baseline <- FALSE |
| 50 | ! |
Options$h1 <- FALSE |
| 51 | ! |
fittedSat <- lavaan(ModelSat, |
| 52 | ! |
slotOptions = Options, verbose = FALSE, |
| 53 | ! |
slotSampleStats = lavsamplestats, |
| 54 | ! |
slotData = lavdata, slotCache = lavcache |
| 55 |
) |
|
| 56 | ! |
fx <- lav_model_objective( |
| 57 | ! |
lavmodel = fittedSat@Model, |
| 58 | ! |
lavsamplestats = fittedSat@SampleStats, |
| 59 | ! |
lavdata = fittedSat@Data, |
| 60 | ! |
lavcache = fittedSat@Cache |
| 61 |
) |
|
| 62 | ! |
SAT.fx <- as.numeric(fx) |
| 63 | ! |
SAT.fx.group <- attr(fx, "fx.group") |
| 64 | ||
| 65 |
# we also need a `saturated model', but where the moments are based |
|
| 66 |
# on the model-implied sample statistics under H0 |
|
| 67 | ! |
ModelSat2 <- |
| 68 | ! |
lav_partable_unrestricted( |
| 69 | ! |
lavobject = NULL, |
| 70 | ! |
lavdata = lavdata, |
| 71 | ! |
lavoptions = lavoptions, |
| 72 | ! |
lavpta = lavpta, |
| 73 | ! |
lavsamplestats = NULL, |
| 74 | ! |
sample.cov = lav_model_sigma(lavmodel), |
| 75 | ! |
sample.mean = lav_model_mu(lavmodel), |
| 76 | ! |
sample.th = lav_model_th(lavmodel), |
| 77 | ! |
sample.th.idx = lavsamplestats@th.idx |
| 78 |
) |
|
| 79 | ||
| 80 | ! |
Options2 <- Options |
| 81 | ! |
Options2$optim.method <- "none" |
| 82 | ! |
Options2$optim.force.converged <- TRUE |
| 83 | ! |
fittedSat2 <- lavaan(ModelSat2, |
| 84 | ! |
slotOptions = Options2, verbose = FALSE, |
| 85 | ! |
slotSampleStats = lavsamplestats, |
| 86 | ! |
slotData = lavdata, slotCache = lavcache |
| 87 |
) |
|
| 88 | ||
| 89 |
# the code below was contributed by Myrsini Katsikatsou (Jan 2015) |
|
| 90 | ||
| 91 |
# for now, only a single group is supported: |
|
| 92 |
# g = 1L |
|
| 93 | ||
| 94 | ||
| 95 |
########################### The code for PLRT for overall goodness of fit |
|
| 96 | ||
| 97 |
##### Section 1. Compute the asymptotic mean and variance |
|
| 98 |
##### of the first quadratic quantity |
|
| 99 |
# if(is.null(VCOV)) {
|
|
| 100 |
# VCOV <- lav_model_vcov(lavmodel = lavmodel, |
|
| 101 |
# lavsamplestats = lavsamplestats, |
|
| 102 |
# lavoptions = lavoptions, |
|
| 103 |
# lavdata = lavdata, |
|
| 104 |
# lavpartable = lavpartable, |
|
| 105 |
# lavcache = lavcache) |
|
| 106 |
# } |
|
| 107 |
# G.inv |
|
| 108 |
# InvG_attheta0 <- lavsamplestats@ntotal * VCOV[,] |
|
| 109 |
# Hessian |
|
| 110 |
# H_attheta0 <- solve(attr(VCOV, "E.inv")) |
|
| 111 | ||
| 112 |
# inverted observed information ('H.inv')
|
|
| 113 | ! |
if (is.null(VCOV)) {
|
| 114 | ! |
H0.inv <- lav_model_information_observed( |
| 115 | ! |
lavmodel = lavmodel, |
| 116 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 117 | ! |
lavoptions = lavoptions, |
| 118 | ! |
lavcache = lavcache, augmented = TRUE, inverted = TRUE |
| 119 |
) |
|
| 120 |
} else {
|
|
| 121 | ! |
H0.inv <- attr(VCOV, "E.inv") |
| 122 |
} |
|
| 123 | ||
| 124 |
# first order information ('J')
|
|
| 125 | ! |
if (is.null(VCOV)) {
|
| 126 | ! |
J0 <- lav_model_information_firstorder( |
| 127 | ! |
lavmodel = lavmodel, lavoptions = lavoptions, |
| 128 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 129 | ! |
lavcache = lavcache |
| 130 |
)[, ] |
|
| 131 |
} else {
|
|
| 132 |
# we do not get J, but J.group, FIXME? |
|
| 133 | ! |
J0 <- lav_model_information_firstorder( |
| 134 | ! |
lavmodel = lavmodel, lavoptions = lavoptions, |
| 135 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 136 | ! |
lavcache = lavcache |
| 137 |
)[, ] |
|
| 138 |
} |
|
| 139 | ||
| 140 |
# inverted Godambe information |
|
| 141 | ! |
G0.inv <- H0.inv %*% J0 %*% H0.inv |
| 142 | ||
| 143 | ! |
H0tmp_prod1 <- H0.inv %*% J0 |
| 144 |
# H0tmp_prod1 <- InvG_attheta0 %*% H_attheta0 |
|
| 145 | ! |
H0tmp_prod2 <- H0tmp_prod1 %*% H0tmp_prod1 |
| 146 | ! |
E_tww <- sum(diag(H0tmp_prod1)) |
| 147 | ! |
var_tww <- 2 * sum(diag(H0tmp_prod2)) |
| 148 | ||
| 149 |
##### Section 2: Compute the asymptotic mean and variance |
|
| 150 |
##### of the second quadratic quantity. |
|
| 151 | ! |
tmp.options <- fittedSat2@Options |
| 152 | ! |
tmp.options$se <- "robust.huber.white" |
| 153 | ! |
VCOV.Sat2 <- lav_model_vcov( |
| 154 | ! |
lavmodel = fittedSat2@Model, |
| 155 | ! |
lavsamplestats = fittedSat2@SampleStats, |
| 156 | ! |
lavoptions = tmp.options, |
| 157 | ! |
lavdata = fittedSat2@Data, |
| 158 | ! |
lavpartable = fittedSat2@ParTable, |
| 159 | ! |
lavcache = fittedSat2@Cache |
| 160 |
) |
|
| 161 |
# G.inv at vartheta_0 |
|
| 162 | ! |
InvG_at_vartheta0 <- lavsamplestats@ntotal * VCOV.Sat2[, ] |
| 163 |
# Hessian at vartheta_0 |
|
| 164 | ! |
H_at_vartheta0 <- solve(attr(VCOV.Sat2, "E.inv")) # should always work |
| 165 |
# H1.inv <- lavTech(fittedSat2, "inverted.information.observed") |
|
| 166 |
# J1 <- lavTech(fittedSat2, "information.first.order") |
|
| 167 |
# H1tmp_prod1 <- H1.inv %*% J1 |
|
| 168 | ! |
H1tmp_prod1 <- InvG_at_vartheta0 %*% H_at_vartheta0 |
| 169 | ! |
H1tmp_prod2 <- H1tmp_prod1 %*% H1tmp_prod1 |
| 170 | ! |
E_tzz <- sum(diag(H1tmp_prod1)) |
| 171 | ! |
var_tzz <- 2 * sum(diag(H1tmp_prod2)) |
| 172 | ||
| 173 | ||
| 174 |
##### Section 3: Compute the asymptotic covariance |
|
| 175 |
##### of the two quadratic quantities |
|
| 176 | ||
| 177 | ! |
drhodpsi_MAT <- vector("list", length = lavsamplestats@ngroups)
|
| 178 | ! |
group.values <- lav_partable_group_values(fittedSat2@ParTable) |
| 179 | ! |
for (g in 1:lavsamplestats@ngroups) {
|
| 180 | ! |
delta.g <- lav_model_delta(lavmodel)[[g]] |
| 181 |
# order of the rows: first the thresholds, then the correlations |
|
| 182 |
# we need to map the rows of delta.g to the rows/cols of H_at_vartheta0 |
|
| 183 |
# of H1 |
|
| 184 | ||
| 185 | ! |
PT <- fittedSat2@ParTable |
| 186 | ! |
PT$label <- lav_partable_labels(PT) |
| 187 | ! |
free.idx <- which(PT$free > 0 & PT$group == group.values[g]) |
| 188 | ! |
PARLABEL <- PT$label[free.idx] |
| 189 | ||
| 190 |
# for now, we can assume that lav_model_delta will always return |
|
| 191 |
# the thresholds first, then the correlations |
|
| 192 |
# |
|
| 193 |
# later, we should add a (working) add.labels = TRUE option to |
|
| 194 |
# lav_model_delta |
|
| 195 | ! |
th.names <- lavpta$vnames$th[[g]] |
| 196 | ! |
ov.names <- lavpta$vnames$ov[[g]] |
| 197 | ! |
tmp <- utils::combn(ov.names, 2) |
| 198 | ! |
cor.names <- paste(tmp[1, ], "~~", tmp[2, ], sep = "") |
| 199 | ! |
NAMES <- c(th.names, cor.names) |
| 200 | ! |
if (g > 1L) {
|
| 201 | ! |
NAMES <- paste(NAMES, ".g", g, sep = "") |
| 202 |
} |
|
| 203 | ||
| 204 | ! |
par.idx <- match(PARLABEL, NAMES) |
| 205 | ! |
drhodpsi_MAT[[g]] <- delta.g[par.idx, , drop = FALSE] |
| 206 |
} |
|
| 207 | ! |
drhodpsi_mat <- do.call(rbind, drhodpsi_MAT) |
| 208 | ||
| 209 |
# tmp_prod <- ( t(drhodpsi_mat) %*% H_at_vartheta0 %*% |
|
| 210 |
# drhodpsi_mat %*% InvG_attheta0 %*% |
|
| 211 |
# H_attheta0 %*% InvG_attheta0 ) |
|
| 212 | ! |
tmp_prod <- (t(drhodpsi_mat) %*% H_at_vartheta0 %*% |
| 213 | ! |
drhodpsi_mat %*% H0.inv %*% J0 %*% G0.inv) |
| 214 | ! |
cov_tzztww <- 2 * sum(diag(tmp_prod)) |
| 215 | ||
| 216 |
##### Section 4: compute the adjusted PLRT and its p-value |
|
| 217 | ! |
PLRTH0Sat <- 2 * (H0.fx - SAT.fx) |
| 218 | ! |
PLRTH0Sat.group <- 2 * (H0.fx.group - SAT.fx.group) |
| 219 | ! |
asym_mean_PLRTH0Sat <- E_tzz - E_tww |
| 220 | ! |
asym_var_PLRTH0Sat <- var_tzz + var_tww - 2 * cov_tzztww |
| 221 | ! |
scaling.factor <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2)) |
| 222 | ! |
FSA_PLRT_SEM <- (asym_mean_PLRTH0Sat / (asym_var_PLRTH0Sat / 2)) * PLRTH0Sat |
| 223 | ! |
adjusted_df <- (asym_mean_PLRTH0Sat * asym_mean_PLRTH0Sat) / |
| 224 | ! |
(asym_var_PLRTH0Sat / 2) |
| 225 |
# In some very few cases (simulations show very few cases |
|
| 226 |
# in small sample sizes) |
|
| 227 |
# the adjusted_df is a negative number, we should then |
|
| 228 |
# print a warning like: "The adjusted df is computed to be a negative number |
|
| 229 |
# and for this the first and second moment adjusted PLRT is not computed." . |
|
| 230 | ! |
pvalue <- 1 - pchisq(FSA_PLRT_SEM, df = adjusted_df) |
| 231 | ||
| 232 | ! |
list( |
| 233 | ! |
PLRTH0Sat = PLRTH0Sat, PLRTH0Sat.group = PLRTH0Sat.group, |
| 234 | ! |
stat = FSA_PLRT_SEM, df = adjusted_df, p.value = pvalue, |
| 235 | ! |
scaling.factor = scaling.factor |
| 236 |
) |
|
| 237 |
} |
|
| 238 |
############################################################################ |
| 1 |
# new version of lav_data_simulate (replaced lav_data_simulate_old) |
|
| 2 |
# from lavaan 0.6-1 |
|
| 3 |
# YR 23 March 2018 |
|
| 4 |
# |
|
| 5 |
# - calls lavaan directly to get model-implied statistics |
|
| 6 |
# - allows for groups with different sets of variables |
|
| 7 |
# - |
|
| 8 | ||
| 9 | ||
| 10 |
lav_data_simulate <- function(model = NULL, |
|
| 11 |
cmd.pop = "sem", |
|
| 12 |
..., |
|
| 13 |
# data properties |
|
| 14 |
sample.nobs = 1000L, |
|
| 15 |
cluster.idx = NULL, |
|
| 16 |
# control |
|
| 17 |
empirical = FALSE, |
|
| 18 |
# output |
|
| 19 |
add.labels = TRUE, |
|
| 20 |
return.fit = FALSE, |
|
| 21 |
output = "data.frame") {
|
|
| 22 |
# dotdotdot |
|
| 23 | ! |
dotdotdot <- list(...) |
| 24 | ! |
dotdotdot.orig <- dotdotdot |
| 25 | ||
| 26 |
# remove/override some options |
|
| 27 | ! |
dotdotdot$verbose <- FALSE |
| 28 | ! |
dotdotdot$debug <- FALSE |
| 29 | ! |
dotdotdot$data <- NULL |
| 30 | ! |
dotdotdot$sample.cov <- NULL |
| 31 | ||
| 32 | ||
| 33 |
# add sample.nobs/group.label to lavaan call |
|
| 34 | ! |
dotdotdot$sample.nobs <- sample.nobs |
| 35 | ||
| 36 |
# always use meanstructure = TRUE |
|
| 37 | ! |
dotdotdot$meanstructure <- TRUE |
| 38 | ||
| 39 | ||
| 40 |
# remove 'ordered' argument: we will first pretend we generate |
|
| 41 |
# continuous data only |
|
| 42 | ! |
dotdotdot$ordered <- NULL |
| 43 | ||
| 44 |
# 'fit' population model |
|
| 45 | ! |
fit.pop <- do.call(cmd.pop, args = c(list(model = model), dotdotdot)) |
| 46 | ||
| 47 |
# categorical? |
|
| 48 | ! |
if (fit.pop@Model@categorical) {
|
| 49 |
# refit, as if continuous only |
|
| 50 | ! |
dotdotdot$ordered <- NULL |
| 51 | ! |
fit.con <- do.call(cmd.pop, args = c(list(model = model), dotdotdot)) |
| 52 |
# restore |
|
| 53 | ! |
dotdotdot$ordered <- dotdotdot.orig$ordered |
| 54 |
} else {
|
|
| 55 | ! |
fit.con <- fit.pop |
| 56 |
} |
|
| 57 | ||
| 58 |
# extract model implied statistics and data slot |
|
| 59 | ! |
lavimplied <- fit.con@implied # take continuous mean/cov |
| 60 | ! |
lavdata <- fit.pop@Data |
| 61 | ! |
lavmodel <- fit.pop@Model |
| 62 | ! |
lavpartable <- fit.pop@ParTable |
| 63 | ! |
lavoptions <- fit.pop@Options |
| 64 | ||
| 65 |
# number of groups/levels |
|
| 66 | ! |
ngroups <- lav_partable_ngroups(lavpartable) |
| 67 | ! |
nblocks <- lav_partable_nblocks(lavpartable) |
| 68 | ||
| 69 |
# check sample.nobs argument |
|
| 70 | ! |
if (lavdata@nlevels > 1L) {
|
| 71 |
# multilevel |
|
| 72 | ! |
if (is.null(cluster.idx)) {
|
| 73 |
# default? -> 1000 per block |
|
| 74 | ! |
if (is.null(sample.nobs)) {
|
| 75 | ! |
sample.nobs <- rep.int( |
| 76 | ! |
c( |
| 77 | ! |
1000L, |
| 78 | ! |
rep.int(100L, lavdata@nlevels - 1L) |
| 79 |
), |
|
| 80 | ! |
times = ngroups |
| 81 |
) |
|
| 82 |
} else {
|
|
| 83 |
# we assume sample.nobs only contains a single number |
|
| 84 | ! |
sample.nobs <- rep.int( |
| 85 | ! |
c( |
| 86 | ! |
sample.nobs, |
| 87 | ! |
rep.int(100L, lavdata@nlevels - 1L) |
| 88 |
), |
|
| 89 | ! |
times = ngroups |
| 90 |
) |
|
| 91 |
} |
|
| 92 |
} else {
|
|
| 93 |
# we got a cluster.idx argument |
|
| 94 | ! |
if (!is.list(cluster.idx)) {
|
| 95 | ! |
cluster.idx <- rep(list(cluster.idx), ngroups) |
| 96 |
} |
|
| 97 | ||
| 98 | ! |
if (!is.null(sample.nobs) && (length(sample.nobs) > 1L || |
| 99 | ! |
sample.nobs != 1000L)) {
|
| 100 | ! |
lav_msg_warn(gettext( |
| 101 | ! |
"sample.nobs will be ignored if cluster.idx is provided")) |
| 102 |
} |
|
| 103 | ! |
sample.nobs <- numeric(nblocks) |
| 104 | ! |
for (g in seq_len(ngroups)) {
|
| 105 | ! |
gg <- (g - 1) * lavdata@nlevels + 1L |
| 106 | ! |
sample.nobs[gg] <- length(cluster.idx[[g]]) |
| 107 | ! |
sample.nobs[gg + 1] <- length(unique(cluster.idx[[g]])) |
| 108 |
} |
|
| 109 |
} |
|
| 110 |
} else {
|
|
| 111 |
# single level |
|
| 112 | ! |
if (length(sample.nobs) == ngroups) {
|
| 113 |
# nothing to do |
|
| 114 | ! |
} else if (ngroups > 1L && length(sample.nobs) == 1L) {
|
| 115 | ! |
sample.nobs <- rep.int(sample.nobs, ngroups) |
| 116 |
} else {
|
|
| 117 | ! |
lav_msg_stop(gettextf( |
| 118 | ! |
"ngroups = %1$s but sample.nobs has length = %2$s", |
| 119 | ! |
ngroups, length(sample.nobs))) |
| 120 |
} |
|
| 121 |
} |
|
| 122 | ||
| 123 |
# check if ov.names are the same for each group |
|
| 124 | ! |
if (ngroups > 1L) {
|
| 125 | ! |
N1 <- lavdata@ov.names[[1]] |
| 126 | ! |
if (!all(sapply( |
| 127 | ! |
lavdata@ov.names, |
| 128 | ! |
function(x) all(x %in% N1) |
| 129 |
))) {
|
|
| 130 | ! |
if (output == "data.frame") {
|
| 131 | ! |
output <- "matrix" |
| 132 | ! |
lav_msg_warn(gettext( |
| 133 | ! |
"groups do not contain the same set of variables; |
| 134 | ! |
changing output= argument to \"matrix\"")) |
| 135 |
} |
|
| 136 |
} |
|
| 137 |
} |
|
| 138 | ||
| 139 |
# prepare data containers |
|
| 140 | ! |
X <- vector("list", length = nblocks)
|
| 141 | ||
| 142 |
# generate data per BLOCK |
|
| 143 | ! |
for (b in seq_len(nblocks)) {
|
| 144 | ! |
if (lavoptions$conditional.x) {
|
| 145 | ! |
lav_msg_stop(gettext("conditional.x is not ready yet"))
|
| 146 |
} else {
|
|
| 147 | ! |
COV <- lavimplied$cov[[b]] |
| 148 | ! |
MU <- lavimplied$mean[[b]] |
| 149 |
} |
|
| 150 | ||
| 151 |
# if empirical = TRUE, rescale by N/(N-1), so that estimator=ML |
|
| 152 |
# returns exact results |
|
| 153 | ! |
if (empirical) {
|
| 154 |
# check if sample.nobs is large enough |
|
| 155 | ! |
if (sample.nobs[b] < NCOL(COV)) {
|
| 156 | ! |
lav_msg_stop(gettextf( |
| 157 | ! |
"empirical = TRUE requires sample.nobs = %1$s to be larger than the |
| 158 | ! |
number of variables = %2$s in block = %3$s", |
| 159 | ! |
sample.nobs[b], NCOL(COV), b |
| 160 |
)) |
|
| 161 |
} |
|
| 162 | ! |
if (lavdata@nlevels > 1L && (b %% lavdata@nlevels == 1L)) {
|
| 163 | ! |
COV <- COV * sample.nobs[b] / (sample.nobs[b] - sample.nobs[b + 1]) |
| 164 |
} else {
|
|
| 165 | ! |
COV <- COV * sample.nobs[b] / (sample.nobs[b] - 1) |
| 166 |
} |
|
| 167 |
} |
|
| 168 | ||
| 169 |
# generate normal data (using sign-invariant method for reproducibility) |
|
| 170 | ! |
tmp <- try( |
| 171 | ! |
lav_mvrnorm( |
| 172 | ! |
n = sample.nobs[b], |
| 173 | ! |
mu = MU, Sigma = COV, empirical = empirical, byrow = TRUE |
| 174 |
), |
|
| 175 | ! |
silent = TRUE |
| 176 |
) |
|
| 177 | ||
| 178 | ! |
if (inherits(tmp, "try-error")) {
|
| 179 |
# something went wrong; most likely: non-positive COV? |
|
| 180 | ! |
ev <- eigen(COV, symmetric = TRUE, only.values = TRUE)$values |
| 181 | ! |
if (any(ev < 0)) {
|
| 182 | ! |
lav_msg_stop(gettextf( |
| 183 | ! |
"model-implied covariance matrix is not positive-definite in block |
| 184 | ! |
= %1$s; smallest eigen value = %2$s; change the model parameters.", |
| 185 | ! |
b, round(min(ev), 5))) |
| 186 |
} else {
|
|
| 187 | ! |
lav_msg_stop(gettextf("data generation failed for block = %s", b))
|
| 188 |
} |
|
| 189 |
} else {
|
|
| 190 | ! |
X[[b]] <- unname(tmp) |
| 191 |
} |
|
| 192 |
} # block |
|
| 193 | ||
| 194 | ! |
if (output == "block") {
|
| 195 | ! |
return(X) |
| 196 |
} |
|
| 197 | ||
| 198 |
# if multilevel, make a copy, and create X[[g]] per group |
|
| 199 | ! |
if (lavdata@nlevels > 1L) {
|
| 200 | ! |
X.block <- X |
| 201 | ! |
X <- vector("list", length = ngroups)
|
| 202 |
} |
|
| 203 | ||
| 204 |
# assemble data per group |
|
| 205 | ! |
group.values <- lav_partable_group_values(lavpartable) |
| 206 | ! |
for (g in 1:ngroups) {
|
| 207 |
# multilevel? |
|
| 208 | ! |
if (lavdata@nlevels > 1L) {
|
| 209 |
# which block? |
|
| 210 | ! |
bb <- (g - 1) * lavdata@nlevels + 1L |
| 211 | ||
| 212 | ! |
Lp <- lavdata@Lp[[g]] |
| 213 | ! |
p.tilde <- length(lavdata@ov.names[[g]]) |
| 214 | ! |
tmp1 <- matrix(0, nrow(X.block[[bb]]), p.tilde + 1L) # one extra for |
| 215 | ! |
tmp2 <- matrix(0, nrow(X.block[[bb]]), p.tilde + 1L) # the clus id |
| 216 | ||
| 217 |
# level 1 |
|
| 218 |
# if(empirical) {
|
|
| 219 | ! |
if (FALSE) {
|
| 220 |
# force the within-cluster means to be zero (for both.idx vars) |
|
| 221 | ! |
Y2 <- unname(as.matrix(aggregate(X.block[[bb]], |
| 222 |
# NOTE: cluster.idx becomes a factor |
|
| 223 |
# should be 111122223333... |
|
| 224 | ! |
by = list(cluster.idx[[g]]), FUN = mean, na.rm = TRUE |
| 225 | ! |
)[, -1])) |
| 226 |
# don't touch within-only variables |
|
| 227 | ! |
w.idx <- match(Lp$within.idx[[2]], Lp$ov.idx[[1]]) |
| 228 | ! |
Y2[, w.idx] <- 0 |
| 229 | ||
| 230 |
# center cluster-wise |
|
| 231 | ! |
Y1c <- X.block[[bb]] - Y2[cluster.idx[[g]], , drop = FALSE] |
| 232 | ||
| 233 |
# this destroys the within covariance matrix |
|
| 234 | ! |
sigma.sqrt <- lav_matrix_symmetric_sqrt(lavimplied$cov[[bb]]) |
| 235 | ! |
NY <- NROW(Y1c) |
| 236 | ! |
S <- cov(Y1c) * (NY - 1) / NY |
| 237 | ! |
S.inv <- solve(S) |
| 238 | ! |
S.inv.sqrt <- lav_matrix_symmetric_sqrt(S.inv) |
| 239 | ||
| 240 |
# transform |
|
| 241 | ! |
X.block[[bb]] <- Y1c %*% S.inv.sqrt %*% sigma.sqrt |
| 242 |
} |
|
| 243 | ! |
tmp1[, Lp$ov.idx[[1]]] <- X.block[[bb]] |
| 244 | ||
| 245 |
# level 2 |
|
| 246 | ! |
tmp2[, Lp$ov.idx[[2]]] <- X.block[[bb + 1L]][cluster.idx[[g]], , |
| 247 | ! |
drop = FALSE |
| 248 |
] |
|
| 249 |
# final |
|
| 250 | ! |
X[[g]] <- tmp1 + tmp2 |
| 251 | ||
| 252 |
# cluster id |
|
| 253 | ! |
X[[g]][, p.tilde + 1L] <- cluster.idx[[g]] |
| 254 |
} |
|
| 255 | ||
| 256 |
# add variable names? |
|
| 257 | ! |
if (add.labels) {
|
| 258 | ! |
if (lavdata@nlevels > 1L) {
|
| 259 | ! |
colnames(X[[g]]) <- c(lavdata@ov.names[[g]], "cluster") |
| 260 |
} else {
|
|
| 261 | ! |
colnames(X[[g]]) <- lavdata@ov.names[[g]] |
| 262 |
} |
|
| 263 |
} |
|
| 264 | ||
| 265 |
# any categorical variables? |
|
| 266 | ! |
ov.ord <- lav_object_vnames(fit.pop, "ov.ord", group = group.values[g]) |
| 267 | ! |
if (is.list(ov.ord)) {
|
| 268 |
# multilvel -> use within level only |
|
| 269 | ! |
ov.ord <- ov.ord[[1L]] |
| 270 |
} |
|
| 271 | ! |
if (length(ov.ord) > 0L) {
|
| 272 | ! |
ov.names <- lavdata@ov.names[[g]] |
| 273 | ||
| 274 |
# which block? |
|
| 275 | ! |
bb <- (g - 1) * lavdata@nlevels + 1L |
| 276 | ||
| 277 |
# th/names |
|
| 278 | ! |
TH.VAL <- as.numeric(fit.pop@implied$th[[bb]]) |
| 279 | ! |
if (length(lavmodel@num.idx[[bb]]) > 0L) {
|
| 280 | ! |
NUM.idx <- which(lavmodel@th.idx[[bb]] == 0) |
| 281 | ! |
TH.VAL <- TH.VAL[-NUM.idx] |
| 282 |
} |
|
| 283 | ! |
th.names <- fit.pop@pta$vnames$th[[bb]] |
| 284 | ! |
TH.NAMES <- sapply(strsplit(th.names, |
| 285 | ! |
split = "|", |
| 286 | ! |
fixed = TRUE |
| 287 | ! |
), "[[", 1L) |
| 288 | ||
| 289 |
# use thresholds to cut |
|
| 290 | ! |
for (o in ov.ord) {
|
| 291 | ! |
o.idx <- which(o == ov.names) |
| 292 | ! |
th.idx <- which(o == TH.NAMES) |
| 293 | ! |
th.val <- c(-Inf, sort(TH.VAL[th.idx]), +Inf) |
| 294 |
# center (because model-implied 'mean' may be nonzero) |
|
| 295 | ! |
tmp <- X[[g]][, o.idx] |
| 296 | ! |
tmp <- tmp - mean(tmp, na.rm = TRUE) |
| 297 | ! |
X[[g]][, o.idx] <- cut(tmp, th.val, labels = FALSE) |
| 298 |
} |
|
| 299 |
} |
|
| 300 |
} |
|
| 301 | ||
| 302 | ||
| 303 |
# output |
|
| 304 | ! |
if (output == "matrix") {
|
| 305 | ! |
if (ngroups == 1L) {
|
| 306 | ! |
out <- X[[1L]] |
| 307 |
} else {
|
|
| 308 | ! |
out <- X |
| 309 |
} |
|
| 310 | ! |
} else if (output == "data.frame") {
|
| 311 | ! |
if (ngroups == 1L) {
|
| 312 |
# convert to data.frame |
|
| 313 | ! |
out <- as.data.frame(X[[1L]], stringsAsFactors = FALSE) |
| 314 | ! |
} else if (ngroups > 1L) {
|
| 315 |
# rbind |
|
| 316 | ! |
out <- do.call("rbind", X)
|
| 317 | ||
| 318 |
# add group column |
|
| 319 | ! |
group <- rep.int(1:ngroups, times = sapply(X, NROW)) |
| 320 | ! |
out <- cbind(out, group) |
| 321 | ||
| 322 |
# convert to data.frame |
|
| 323 | ! |
out <- as.data.frame(out, stringsAsFactors = FALSE) |
| 324 |
} |
|
| 325 | ! |
} else if (output == "cov") {
|
| 326 | ! |
if (ngroups == 1L) {
|
| 327 | ! |
out <- cov(X[[1L]]) |
| 328 |
} else {
|
|
| 329 | ! |
out <- lapply(X, cov) |
| 330 |
} |
|
| 331 |
} else {
|
|
| 332 | ! |
lav_msg_stop(gettextf("unknown option for argument output: %s", output))
|
| 333 |
} |
|
| 334 | ||
| 335 | ! |
if (return.fit) {
|
| 336 | ! |
attr(out, "fit") <- fit.pop |
| 337 |
} |
|
| 338 | ||
| 339 | ! |
out |
| 340 |
} |
| 1 |
# # # # # # # # # # # # # # # |
|
| 2 |
# # lavaan main function # # |
|
| 3 |
# # # # # # # # # # # # # # # |
|
| 4 |
# |
|
| 5 |
# main user-visible cfa/sem/growth functions |
|
| 6 |
# |
|
| 7 |
# initial version: YR 25/03/2009 |
|
| 8 |
# added lavoptions YR 02/08/2010 |
|
| 9 |
# major revision: YR 9/12/2010: - new workflow (since 0.4-5) |
|
| 10 |
# - merge cfa/sem/growth functions |
|
| 11 |
# YR 25/02/2012: changed data slot (from list() to S4); data@X contains data |
|
| 12 | ||
| 13 |
# YR 26 Jan 2017: use '...' to capture the never-ending list of options |
|
| 14 |
# YR 07 Feb 2023: add ov.order= argument |
|
| 15 |
# HJ 18 Oct 2023: extend PML to allow sampling weights |
|
| 16 |
# LDW 26 Feb 2024: split lavaan in smaller steps |
|
| 17 |
# |
|
| 18 |
lavaan <- function( |
|
| 19 |
# user specified model: can be syntax, parameter Table, ... |
|
| 20 |
model = NULL, |
|
| 21 |
# data (second argument, most used) |
|
| 22 |
data = NULL, |
|
| 23 |
# variable information |
|
| 24 |
ordered = NULL, |
|
| 25 |
# sampling weights |
|
| 26 |
sampling.weights = NULL, |
|
| 27 |
# summary data |
|
| 28 |
sample.cov = NULL, |
|
| 29 |
sample.mean = NULL, |
|
| 30 |
sample.th = NULL, |
|
| 31 |
sample.nobs = NULL, |
|
| 32 |
# multiple groups? |
|
| 33 |
group = NULL, |
|
| 34 |
# multiple levels? |
|
| 35 |
cluster = NULL, |
|
| 36 |
# constraints |
|
| 37 |
constraints = "", |
|
| 38 |
# user-specified variance matrices |
|
| 39 |
WLS.V = NULL, # nolint |
|
| 40 |
NACOV = NULL, # nolint |
|
| 41 |
# internal order of ov.names |
|
| 42 |
ov.order = "model", |
|
| 43 |
# full slots from previous fits |
|
| 44 |
slotOptions = NULL, # nolint |
|
| 45 |
slotParTable = NULL, # nolint |
|
| 46 |
slotSampleStats = NULL, # nolint |
|
| 47 |
slotData = NULL, # nolint |
|
| 48 |
slotModel = NULL, # nolint |
|
| 49 |
slotCache = NULL, # nolint |
|
| 50 |
sloth1 = NULL, |
|
| 51 |
# options (dotdotdot) |
|
| 52 |
...) {
|
|
| 53 |
# start timer |
|
| 54 | 140x |
start.time0 <- proc.time()[3] |
| 55 | 140x |
timing <- list() |
| 56 | 140x |
timing$start.time <- start.time0 |
| 57 | ||
| 58 |
# ------------- adapt parameters ----------------- |
|
| 59 | 140x |
mc <- match.call(expand.dots = TRUE) |
| 60 | 140x |
temp <- lav_lavaan_step00_parameters( |
| 61 | 140x |
matchcall = mc, |
| 62 | 140x |
syscall = sys.call(), # to get main arguments without partial matching |
| 63 | 140x |
dotdotdot = list(...) |
| 64 |
) |
|
| 65 | 140x |
lavmc <- temp$mc |
| 66 | 140x |
dotdotdot <- temp$dotdotdot |
| 67 | 140x |
cluster <- lavmc$cluster |
| 68 | 140x |
rm(mc) |
| 69 | ||
| 70 |
# store current random seed (if any) |
|
| 71 | 140x |
if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 72 | 16x |
temp.seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
|
| 73 |
} else {
|
|
| 74 | 124x |
temp.seed <- NULL |
| 75 |
} |
|
| 76 | ||
| 77 |
# ------------- handling of warn/debug/verbose switches ---------- |
|
| 78 | 140x |
if (!is.null(dotdotdot$debug)) {
|
| 79 | ! |
current.debug <- lav_debug() |
| 80 | ! |
if (lav_debug(dotdotdot$debug)) |
| 81 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 82 | ! |
dotdotdot$debug <- NULL |
| 83 | ! |
if (lav_debug()) {
|
| 84 | ! |
dotdotdot$warn <- TRUE # force warnings if debug |
| 85 | ! |
dotdotdot$verbose <- TRUE # force verbose if debug |
| 86 |
} |
|
| 87 |
} |
|
| 88 | 140x |
if (!is.null(dotdotdot$warn)) {
|
| 89 | 4x |
current.warn <- lav_warn() |
| 90 | 4x |
if (lav_warn(dotdotdot$warn)) |
| 91 | 4x |
on.exit(lav_warn(current.warn), TRUE) |
| 92 | 4x |
dotdotdot$warn <- NULL |
| 93 |
} |
|
| 94 | 140x |
if (!is.null(dotdotdot$verbose)) {
|
| 95 | ! |
current.verbose <- lav_verbose() |
| 96 | ! |
if (lav_verbose(dotdotdot$verbose)) |
| 97 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 98 | ! |
dotdotdot$verbose <- NULL |
| 99 |
} |
|
| 100 | ||
| 101 |
# ------------ check data ------------------------ |
|
| 102 | 140x |
temp <- lav_lavaan_step00_checkdata( |
| 103 | 140x |
data = data, |
| 104 | 140x |
dotdotdot = dotdotdot, |
| 105 | 140x |
sample.cov = sample.cov, |
| 106 | 140x |
sample.nobs = sample.nobs, |
| 107 | 140x |
sample.mean = sample.mean, |
| 108 | 140x |
sample.th = sample.th, |
| 109 | 140x |
NACOV = NACOV, |
| 110 | 140x |
WLS.V = WLS.V, |
| 111 | 140x |
ov.order = ov.order |
| 112 |
) |
|
| 113 | 140x |
data <- temp$data |
| 114 | 140x |
dotdotdot <- temp$dotdotdot |
| 115 | 140x |
sample.cov <- temp$sample.cov |
| 116 | 140x |
sample.nobs <- temp$sample.nobs |
| 117 | 140x |
sample.mean <- temp$sample.mean |
| 118 | 140x |
sample.th <- temp$sample.th |
| 119 | 140x |
NACOV <- temp$NACOV # nolint |
| 120 | 140x |
WLS.V <- temp$WLS.V # nolint |
| 121 | 140x |
ov.order <- temp$ov.order |
| 122 | ||
| 123 | 140x |
timing <- ldw_add_timing(timing, "init") |
| 124 | ||
| 125 |
# ------------ ov.names 1 ----- initial flat model -------------------- |
|
| 126 |
# if parser not specified, take default one |
|
| 127 | 140x |
if (is.null(dotdotdot$parser)) {
|
| 128 | 93x |
opt.default <- lav_options_default() |
| 129 | 93x |
useparser <- opt.default$parser |
| 130 |
} else {
|
|
| 131 | 47x |
useparser <- dotdotdot$parser |
| 132 |
} |
|
| 133 | ||
| 134 | 140x |
flat.model <- lav_lavaan_step01_ovnames_initflat( |
| 135 | 140x |
slotParTable = slotParTable, |
| 136 | 140x |
model = model, |
| 137 | 140x |
dotdotdot.parser = useparser |
| 138 |
) |
|
| 139 | ||
| 140 |
# ------------ ov.names 1b ----- handle 'old way' for composites ------- |
|
| 141 | 140x |
if (!is.null(dotdotdot$composites) && !dotdotdot$composites && |
| 142 | 140x |
any(flat.model$op == "<~")) {
|
| 143 | ! |
flat.model <- lav_lavaan_step01_ovnames_composites(flat.model) |
| 144 |
} |
|
| 145 | ||
| 146 |
# ------------ ov.names 2 ------ handle ov.order ----------------------- |
|
| 147 | 140x |
flat.model <- lav_lavaan_step01_ovnames_ovorder( |
| 148 | 140x |
flat.model = flat.model, |
| 149 | 140x |
ov.order = ov.order, |
| 150 | 140x |
data = data, |
| 151 | 140x |
sample.cov = sample.cov, |
| 152 | 140x |
slotData = slotData |
| 153 |
) |
|
| 154 | ||
| 155 |
# ------------ ov.names 3 ------- group blocks ------------------ |
|
| 156 | 140x |
ngroups <- 1L # default value |
| 157 | 140x |
temp <- lav_lavaan_step01_ovnames_group( |
| 158 | 140x |
flat.model = flat.model, |
| 159 | 140x |
ngroups = ngroups |
| 160 |
) |
|
| 161 | 140x |
flat.model <- temp$flat.model |
| 162 | 140x |
ov.names <- temp$ov.names |
| 163 | 140x |
ov.names.x <- temp$ov.names.x |
| 164 | 140x |
ov.names.y <- temp$ov.names.y |
| 165 | 140x |
lv.names <- temp$lv.names |
| 166 | 140x |
group.values <- temp$group.values |
| 167 | 140x |
ngroups <- temp$ngroups |
| 168 | ||
| 169 |
# ------------ ov.names 4 ------ sanity checks ------------------ |
|
| 170 | 140x |
lav_lavaan_step01_ovnames_checklv( |
| 171 | 140x |
lv.names = lv.names, |
| 172 | 140x |
ov.names = ov.names, |
| 173 | 140x |
data = data, |
| 174 | 140x |
sample.cov = sample.cov, |
| 175 | 140x |
dotdotdot = dotdotdot, |
| 176 | 140x |
slotOptions = slotOptions |
| 177 |
) |
|
| 178 | ||
| 179 |
# ------------ ov.names 5 ------ handle ov.names.l -------------- |
|
| 180 | 140x |
temp <- lav_lavaan_step01_ovnames_namesl( |
| 181 | 140x |
data = data, |
| 182 | 140x |
cluster = cluster, |
| 183 | 140x |
flat.model = flat.model, |
| 184 | 140x |
group.values = group.values, |
| 185 | 140x |
ngroups = ngroups |
| 186 |
) |
|
| 187 | 140x |
flat.model <- temp$flat.model |
| 188 | 140x |
ov.names.l <- temp$ov.names.l |
| 189 | ||
| 190 |
# ------------ ov.names 6 ------ sanity check ordered -------------- |
|
| 191 | 140x |
ordered <- lav_lavaan_step01_ovnames_ordered( |
| 192 | 140x |
ordered = ordered, |
| 193 | 140x |
flat.model = flat.model, |
| 194 | 140x |
data = data |
| 195 |
) |
|
| 196 | 140x |
timing <- ldw_add_timing(timing, "ov.names") |
| 197 | ||
| 198 |
# ------------ lavoptions -------------------- |
|
| 199 | 140x |
lavoptions <- lav_lavaan_step02_options( |
| 200 | 140x |
slotOptions = slotOptions, |
| 201 | 140x |
slotData = slotData, |
| 202 | 140x |
flat.model = flat.model, |
| 203 | 140x |
ordered = ordered, |
| 204 | 140x |
sample.cov = sample.cov, |
| 205 | 140x |
sample.mean = sample.mean, |
| 206 | 140x |
sample.th = sample.th, |
| 207 | 140x |
sample.nobs = sample.nobs, |
| 208 | 140x |
ov.names.l = ov.names.l, |
| 209 | 140x |
sampling.weights = sampling.weights, |
| 210 | 140x |
constraints = constraints, |
| 211 | 140x |
group = group, |
| 212 | 140x |
ov.names.x = ov.names.x, |
| 213 | 140x |
ov.names.y = ov.names.y, |
| 214 | 140x |
dotdotdot = dotdotdot, |
| 215 | 140x |
cluster = cluster, |
| 216 | 140x |
data = data |
| 217 |
) |
|
| 218 |
# fixed.x = FALSE? set ov.names.x = character(0L) |
|
| 219 |
# new in 0.6-1 |
|
| 220 | 140x |
if (!lavoptions$fixed.x) {
|
| 221 | 76x |
ov.names.x <- character(0L) |
| 222 |
} |
|
| 223 | ||
| 224 | 140x |
timing <- ldw_add_timing(timing, "Options") |
| 225 | ||
| 226 |
# ------------ lavdata ------------------------ |
|
| 227 | 140x |
temp <- lav_lavaan_step03_data( |
| 228 | 140x |
slotData = slotData, |
| 229 | 140x |
lavoptions = lavoptions, |
| 230 | 140x |
ov.names = ov.names, |
| 231 | 140x |
ov.names.y = ov.names.y, |
| 232 | 140x |
group = group, |
| 233 | 140x |
data = data, |
| 234 | 140x |
cluster = cluster, |
| 235 | 140x |
ov.names.x = ov.names.x, |
| 236 | 140x |
ov.names.l = ov.names.l, |
| 237 | 140x |
ordered = ordered, |
| 238 | 140x |
sampling.weights = sampling.weights, |
| 239 | 140x |
sample.cov = sample.cov, |
| 240 | 140x |
sample.mean = sample.mean, |
| 241 | 140x |
sample.th = sample.th, |
| 242 | 140x |
sample.nobs = sample.nobs, |
| 243 | 140x |
slotParTable = slotParTable, |
| 244 | 140x |
ngroups = ngroups, |
| 245 | 140x |
dotdotdot = dotdotdot, |
| 246 | 140x |
flat.model = flat.model, |
| 247 | 140x |
model = model, # in case model is a lavaan object |
| 248 | 140x |
NACOV = NACOV, |
| 249 | 140x |
WLS.V = WLS.V |
| 250 |
) |
|
| 251 | 140x |
lavdata <- temp$lavdata |
| 252 | 140x |
lavoptions <- temp$lavoptions |
| 253 | ||
| 254 | 140x |
timing <- ldw_add_timing(timing, "Data") |
| 255 | ||
| 256 |
# ------------ lavpartable ------------------- |
|
| 257 | 140x |
temp <- lav_lavaan_step04_partable( |
| 258 | 140x |
slotParTable = slotParTable, |
| 259 | 140x |
model = model, |
| 260 | 140x |
flat.model = flat.model, |
| 261 | 140x |
lavoptions = lavoptions, |
| 262 | 140x |
lavdata = lavdata, |
| 263 | 140x |
constraints = constraints |
| 264 |
) |
|
| 265 | 140x |
lavoptions <- temp$lavoptions |
| 266 | 140x |
lavpartable <- temp$lavpartable |
| 267 | 140x |
timing <- ldw_add_timing(timing, "ParTable") |
| 268 | ||
| 269 |
# ------------ lavpta ------------------------ |
|
| 270 |
# lavpta <- lav_lavaan_step04_pta( |
|
| 271 |
# lavpartable = lavpartable, |
|
| 272 |
# lavoptions = lavoptions |
|
| 273 |
# ) |
|
| 274 |
# timing <- ldw_add_timing(timing, "lavpta") |
|
| 275 | ||
| 276 |
# ------------ lavsamplestats --------------- |
|
| 277 | 140x |
lavsamplestats <- lav_lavaan_step05_samplestats( |
| 278 | 140x |
slotSampleStats = slotSampleStats, |
| 279 | 140x |
lavdata = lavdata, |
| 280 | 140x |
lavoptions = lavoptions, |
| 281 | 140x |
WLS.V = WLS.V, |
| 282 | 140x |
NACOV = NACOV, |
| 283 | 140x |
sample.cov = sample.cov, |
| 284 | 140x |
sample.mean = sample.mean, |
| 285 | 140x |
sample.th = sample.th, |
| 286 | 140x |
sample.nobs = sample.nobs, |
| 287 | 140x |
ov.names = ov.names, |
| 288 | 140x |
ov.names.x = ov.names.x, |
| 289 | 140x |
lavpartable = lavpartable |
| 290 |
) |
|
| 291 | 140x |
timing <- ldw_add_timing(timing, "SampleStats") |
| 292 | ||
| 293 |
# ------------ lavh1 ------------------------ |
|
| 294 | 140x |
lavh1 <- lav_lavaan_step06_h1( |
| 295 | 140x |
sloth1 = sloth1, |
| 296 | 140x |
lavoptions = lavoptions, |
| 297 | 140x |
lavsamplestats = lavsamplestats, |
| 298 | 140x |
lavdata = lavdata, |
| 299 | 140x |
lavpartable = lavpartable |
| 300 |
) |
|
| 301 | 140x |
timing <- ldw_add_timing(timing, "h1") |
| 302 | ||
| 303 |
# ------------ bounds ------------------------ |
|
| 304 | 140x |
lavpartable <- lav_lavaan_step07_bounds( |
| 305 | 140x |
lavoptions = lavoptions, |
| 306 | 140x |
lavh1 = lavh1, |
| 307 | 140x |
lavdata = lavdata, |
| 308 | 140x |
lavsamplestats = lavsamplestats, |
| 309 | 140x |
lavpartable = lavpartable |
| 310 |
) |
|
| 311 | 140x |
timing <- ldw_add_timing(timing, "bounds") |
| 312 | ||
| 313 |
# ------------ lavstart ---------------------- |
|
| 314 | 140x |
lavpartable <- lav_lavaan_step08_start( |
| 315 | 140x |
slotModel = slotModel, |
| 316 | 140x |
lavoptions = lavoptions, |
| 317 | 140x |
lavpartable = lavpartable, |
| 318 | 140x |
lavsamplestats = lavsamplestats, |
| 319 | 140x |
lavh1 = lavh1 |
| 320 |
) |
|
| 321 | ||
| 322 | 140x |
timing <- ldw_add_timing(timing, "start") |
| 323 | ||
| 324 |
# ------------ model ------------------------- |
|
| 325 | 140x |
temp <- lav_lavaan_step09_model( |
| 326 | 140x |
slotModel = slotModel, |
| 327 | 140x |
lavoptions = lavoptions, |
| 328 | 140x |
lavpartable = lavpartable, |
| 329 | 140x |
lavsamplestats = lavsamplestats, |
| 330 | 140x |
lavdata = lavdata |
| 331 |
) |
|
| 332 | 140x |
lavpartable <- temp$lavpartable |
| 333 | 140x |
lavmodel <- temp$lavmodel |
| 334 | ||
| 335 | 140x |
timing <- ldw_add_timing(timing, "Model") |
| 336 | ||
| 337 |
# -------- lavcache ---------------------------------- |
|
| 338 | 140x |
lavcache <- lav_lavaan_step10_cache( |
| 339 | 140x |
slotCache = slotCache, |
| 340 | 140x |
lavdata = lavdata, |
| 341 | 140x |
lavmodel = lavmodel, |
| 342 | 140x |
lavpartable = lavpartable, |
| 343 | 140x |
lavoptions = lavoptions, |
| 344 | 140x |
sampling.weights = sampling.weights |
| 345 |
) |
|
| 346 | 140x |
timing <- ldw_add_timing(timing, "cache") |
| 347 | ||
| 348 |
# -------- est + lavoptim ---------------------------- |
|
| 349 | 140x |
temp <- lav_lavaan_step11_estoptim( |
| 350 | 140x |
lavdata = lavdata, |
| 351 | 140x |
lavmodel = lavmodel, |
| 352 | 140x |
lavcache = lavcache, |
| 353 | 140x |
lavsamplestats = lavsamplestats, |
| 354 | 140x |
lavh1 = lavh1, |
| 355 | 140x |
lavoptions = lavoptions, |
| 356 | 140x |
lavpartable = lavpartable |
| 357 |
) |
|
| 358 | 140x |
lavoptim <- temp$lavoptim |
| 359 | 140x |
lavmodel <- temp$lavmodel |
| 360 | 140x |
lavpartable <- temp$lavpartable |
| 361 | 140x |
x <- temp$x |
| 362 |
# store eqs if present in x |
|
| 363 | 140x |
laveqs <- list() |
| 364 | 140x |
if (!is.null(attr(x, "eqs"))) {
|
| 365 | ! |
laveqs <- attr(x, "eqs") |
| 366 |
} |
|
| 367 | ||
| 368 | 140x |
timing <- ldw_add_timing(timing, "optim") |
| 369 | ||
| 370 |
# -------- lavimplied + lavloglik -------------------- |
|
| 371 | 140x |
lavimplied <- lav_lavaan_step12_implied( |
| 372 | 140x |
lavoptions = lavoptions, |
| 373 | 140x |
lavmodel = lavmodel |
| 374 |
) |
|
| 375 | 140x |
timing <- ldw_add_timing(timing, "implied") |
| 376 | ||
| 377 | 140x |
lavloglik <- lav_lavaan_step12_loglik( |
| 378 | 140x |
lavoptions = lavoptions, |
| 379 | 140x |
lavdata = lavdata, |
| 380 | 140x |
lavsamplestats = lavsamplestats, |
| 381 | 140x |
lavh1 = lavh1, |
| 382 | 140x |
lavimplied = lavimplied, |
| 383 | 140x |
lavmodel = lavmodel |
| 384 |
) |
|
| 385 | 140x |
timing <- ldw_add_timing(timing, "loglik") |
| 386 | ||
| 387 |
# ----------- lavvcov + lavboot ------------------- |
|
| 388 | 140x |
temp <- lav_lavaan_step13_vcov_boot( |
| 389 | 140x |
lavoptions = lavoptions, |
| 390 | 140x |
lavmodel = lavmodel, |
| 391 | 140x |
lavsamplestats = lavsamplestats, |
| 392 | 140x |
lavdata = lavdata, |
| 393 | 140x |
lavpartable = lavpartable, |
| 394 | 140x |
lavcache = lavcache, |
| 395 | 140x |
lavimplied = lavimplied, |
| 396 | 140x |
lavh1 = lavh1, |
| 397 | 140x |
x = x |
| 398 |
) |
|
| 399 | 140x |
lavpartable <- temp$lavpartable |
| 400 | 140x |
lavvcov <- temp$lavvcov |
| 401 | 140x |
VCOV <- temp$VCOV # nolint |
| 402 | 140x |
lavmodel <- temp$lavmodel |
| 403 | 140x |
lavboot <- temp$lavboot |
| 404 | ||
| 405 | 140x |
timing <- ldw_add_timing(timing, "vcov") |
| 406 | ||
| 407 |
# ----------- lavtest ---------- |
|
| 408 | 140x |
lavtest <- lav_lavaan_step14_test( |
| 409 | 140x |
lavoptions = lavoptions, |
| 410 | 140x |
lavmodel = lavmodel, |
| 411 | 140x |
lavsamplestats = lavsamplestats, |
| 412 | 140x |
lavdata = lavdata, |
| 413 | 140x |
lavpartable = lavpartable, |
| 414 | 140x |
lavcache = lavcache, |
| 415 | 140x |
lavimplied = lavimplied, |
| 416 | 140x |
lavh1 = lavh1, |
| 417 | 140x |
x = x, |
| 418 | 140x |
VCOV = VCOV, |
| 419 | 140x |
lavloglik = lavloglik |
| 420 |
) |
|
| 421 | 140x |
timing <- ldw_add_timing(timing, "test") |
| 422 | ||
| 423 |
# ----------- lavfit ---------- |
|
| 424 | 140x |
lavfit <- lav_lavaan_step14_fit( |
| 425 | 140x |
lavpartable = lavpartable, |
| 426 | 140x |
lavmodel = lavmodel, |
| 427 | 140x |
lavimplied = lavimplied, |
| 428 | 140x |
x = x, |
| 429 | 140x |
VCOV = VCOV, |
| 430 | 140x |
lavtest = lavtest |
| 431 |
) |
|
| 432 | 140x |
timing <- ldw_add_timing(timing, "Fit") |
| 433 | ||
| 434 |
# ----------- baseline ---------------------------- |
|
| 435 | 140x |
lavbaseline <- lav_lavaan_step15_baseline( |
| 436 | 140x |
lavoptions = lavoptions, |
| 437 | 140x |
lavsamplestats = lavsamplestats, |
| 438 | 140x |
lavdata = lavdata, |
| 439 | 140x |
lavcache = lavcache, |
| 440 | 140x |
lavh1 = lavh1, |
| 441 | 140x |
lavpartable = lavpartable |
| 442 |
) |
|
| 443 | 140x |
timing <- ldw_add_timing(timing, "baseline") |
| 444 | ||
| 445 |
# ----------- rotation --------------------------- |
|
| 446 | 140x |
temp <- lav_lavaan_step16_rotation( |
| 447 | 140x |
lavoptions = lavoptions, |
| 448 | 140x |
lavmodel = lavmodel, |
| 449 | 140x |
lavpartable = lavpartable, |
| 450 | 140x |
lavh1 = lavh1, |
| 451 | 140x |
lavdata = lavdata, |
| 452 | 140x |
x = x, |
| 453 | 140x |
lavvcov = lavvcov, |
| 454 | 140x |
VCOV = VCOV, |
| 455 | 140x |
lavcache = lavcache, |
| 456 | 140x |
lavimplied = lavimplied, |
| 457 | 140x |
lavsamplestats = lavsamplestats |
| 458 |
) |
|
| 459 | 140x |
lavpartable <- temp$lavpartable |
| 460 | 140x |
lavmodel <- temp$lavmodel |
| 461 | 140x |
lavvcov <- temp$lavvcov |
| 462 | ||
| 463 | 140x |
timing <- ldw_add_timing(timing, "rotation") |
| 464 | ||
| 465 |
# ------ lavaan result ---------------- |
|
| 466 | 140x |
out <- lav_lavaan_step17_lavaan( |
| 467 | 140x |
lavmc = lavmc, |
| 468 | 140x |
timing = timing, |
| 469 | 140x |
lavoptions = lavoptions, |
| 470 | 140x |
lavpartable = lavpartable, |
| 471 | 140x |
lavdata = lavdata, |
| 472 | 140x |
lavsamplestats = lavsamplestats, |
| 473 | 140x |
lavmodel = lavmodel, |
| 474 | 140x |
lavcache = lavcache, |
| 475 | 140x |
lavfit = lavfit, |
| 476 | 140x |
lavboot = lavboot, |
| 477 | 140x |
lavoptim = lavoptim, |
| 478 | 140x |
lavimplied = lavimplied, |
| 479 | 140x |
lavloglik = lavloglik, |
| 480 | 140x |
lavvcov = lavvcov, |
| 481 | 140x |
lavtest = lavtest, |
| 482 | 140x |
lavh1 = lavh1, |
| 483 | 140x |
lavbaseline = lavbaseline, |
| 484 | 140x |
laveqs = laveqs, |
| 485 | 140x |
start.time0 = start.time0 |
| 486 |
) |
|
| 487 | ||
| 488 |
# restore random seed |
|
| 489 | 140x |
if (!is.null(temp.seed)) {
|
| 490 | 16x |
assign(".Random.seed", temp.seed, envir = .GlobalEnv)
|
| 491 | 124x |
} else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 492 |
# initially there was no .Random.seed, but we created one along the way |
|
| 493 |
# clean up |
|
| 494 | 77x |
remove(".Random.seed", envir = .GlobalEnv)
|
| 495 |
} |
|
| 496 | ||
| 497 | 140x |
out |
| 498 |
} |
|
| 499 |
# # # # # # |
|
| 500 |
# # cfa # # |
|
| 501 |
# # # # # # |
|
| 502 |
cfa <- function( |
|
| 503 |
model = NULL, |
|
| 504 |
data = NULL, |
|
| 505 |
ordered = NULL, |
|
| 506 |
sampling.weights = NULL, |
|
| 507 |
sample.cov = NULL, |
|
| 508 |
sample.mean = NULL, |
|
| 509 |
sample.th = NULL, |
|
| 510 |
sample.nobs = NULL, |
|
| 511 |
group = NULL, |
|
| 512 |
cluster = NULL, |
|
| 513 |
constraints = "", |
|
| 514 |
WLS.V = NULL, # nolint |
|
| 515 |
NACOV = NULL, # nolint |
|
| 516 |
ov.order = "model", |
|
| 517 |
...) {
|
|
| 518 | 2x |
sc <- sys.call() |
| 519 | 2x |
sc[["model.type"]] <- quote("cfa")
|
| 520 |
# call mother function |
|
| 521 | 2x |
sc[[1L]] <- quote(lavaan::lavaan) |
| 522 | 2x |
eval(sc, parent.frame()) |
| 523 |
} |
|
| 524 |
# # # # # # |
|
| 525 |
# # sem # # |
|
| 526 |
# # # # # # |
|
| 527 |
sem <- function( |
|
| 528 |
model = NULL, |
|
| 529 |
data = NULL, |
|
| 530 |
ordered = NULL, |
|
| 531 |
sampling.weights = NULL, |
|
| 532 |
sample.cov = NULL, |
|
| 533 |
sample.mean = NULL, |
|
| 534 |
sample.th = NULL, |
|
| 535 |
sample.nobs = NULL, |
|
| 536 |
group = NULL, |
|
| 537 |
cluster = NULL, |
|
| 538 |
constraints = "", |
|
| 539 |
WLS.V = NULL, # nolint |
|
| 540 |
NACOV = NULL, # nolint |
|
| 541 |
ov.order = "model", |
|
| 542 |
...) {
|
|
| 543 | 25x |
sc <- sys.call() |
| 544 | 25x |
sc[["model.type"]] <- quote("sem")
|
| 545 |
# call mother function |
|
| 546 | 25x |
sc[[1L]] <- quote(lavaan::lavaan) |
| 547 | 25x |
eval(sc, parent.frame()) |
| 548 |
} |
|
| 549 |
# # # # # # # # |
|
| 550 |
# # growth # # |
|
| 551 |
# # # # # # # # |
|
| 552 |
growth <- function( |
|
| 553 |
model = NULL, |
|
| 554 |
data = NULL, |
|
| 555 |
ordered = NULL, |
|
| 556 |
sampling.weights = NULL, |
|
| 557 |
sample.cov = NULL, |
|
| 558 |
sample.mean = NULL, |
|
| 559 |
sample.th = NULL, |
|
| 560 |
sample.nobs = NULL, |
|
| 561 |
group = NULL, |
|
| 562 |
cluster = NULL, |
|
| 563 |
constraints = "", |
|
| 564 |
WLS.V = NULL, # nolint |
|
| 565 |
NACOV = NULL, # nolint |
|
| 566 |
ov.order = "model", |
|
| 567 |
...) {
|
|
| 568 | ! |
sc <- sys.call() |
| 569 | ! |
sc[["model.type"]] <- quote("growth")
|
| 570 |
# call mother function |
|
| 571 | ! |
sc[[1L]] <- quote(lavaan::lavaan) |
| 572 | ! |
eval(sc, parent.frame()) |
| 573 |
} |
|
| 574 | ||
| 575 |
# # # # # # # # # # # # # # # # # # # |
|
| 576 |
# # help function ldw_add_timing # # |
|
| 577 |
# # # # # # # # # # # # # # # # # # # |
|
| 578 |
ldw_add_timing <- function(timing, part) {
|
|
| 579 |
# timing is a list with element start.time |
|
| 580 |
# this function adds an element with name as specified in parameter part |
|
| 581 |
# and the duration of the interval from start.time upto now |
|
| 582 |
# thereafter the element start.time is set to now (prepare for next call) |
|
| 583 |
# the adapted list is returned |
|
| 584 | 2660x |
timenow <- proc.time()[3] |
| 585 | 2660x |
timing[[part]] <- (timenow - timing$start.time) |
| 586 | 2660x |
timing$start.time <- timenow |
| 587 | ||
| 588 | 2660x |
timing |
| 589 |
} |
| 1 |
# create `full' parameter table, containing (almost) all parameters |
|
| 2 |
# that could be free |
|
| 3 |
# |
|
| 4 |
# main motivation: univariate scores tests (modification indices) |
|
| 5 |
# |
|
| 6 |
lav_partable_full <- function(partable = NULL, |
|
| 7 |
strict.exo = FALSE, |
|
| 8 |
free = FALSE, start = FALSE) {
|
|
| 9 |
# check minimum requirements: lhs, op, rhs |
|
| 10 | ! |
stopifnot( |
| 11 | ! |
!is.null(partable$lhs), |
| 12 | ! |
!is.null(partable$op), |
| 13 | ! |
!is.null(partable$rhs) |
| 14 |
) |
|
| 15 | ||
| 16 |
# lavpta? |
|
| 17 | ! |
lavpta <- lav_partable_attributes(partable) |
| 18 | ||
| 19 |
# meanstructure |
|
| 20 | ! |
if (!is.null(lavpta$meanstructure)) {
|
| 21 | ! |
meanstructure <- lavpta$meanstructure |
| 22 |
} else {
|
|
| 23 |
# old object |
|
| 24 | ! |
meanstructure <- any(partable$op == "~1") |
| 25 |
} |
|
| 26 | ||
| 27 |
# number of blocks |
|
| 28 | ! |
nblocks <- lavpta$nblocks |
| 29 | ! |
ngroups <- lavpta$ngroups |
| 30 | ! |
nlevels <- lavpta$nlevels |
| 31 | ||
| 32 | ! |
lhs <- rhs <- op <- character(0L) |
| 33 | ! |
block <- group <- level <- integer(0L) |
| 34 | ||
| 35 |
# new in 0.6-3: |
|
| 36 | ! |
GROUP.values <- lav_partable_group_values(partable) |
| 37 | ! |
LEVEL.values <- lav_partable_level_values(partable) |
| 38 | ! |
if (is.character(GROUP.values[1])) {
|
| 39 | ! |
group <- character(0L) |
| 40 |
} |
|
| 41 | ! |
if (is.character(LEVEL.values[1L])) {
|
| 42 | ! |
level <- character(0L) |
| 43 |
} |
|
| 44 | ||
| 45 |
# block number |
|
| 46 | ! |
b <- 0L |
| 47 | ! |
for (g in 1:ngroups) {
|
| 48 | ! |
for (l in 1:nlevels) {
|
| 49 |
# block |
|
| 50 | ! |
b <- b + 1L |
| 51 | ||
| 52 | ! |
ov.names <- lavpta$vnames$ov[[b]] |
| 53 | ! |
ov.names.nox <- lavpta$vnames$ov.nox[[b]] |
| 54 | ! |
ov.names.x <- lavpta$vnames$ov.x[[b]] |
| 55 | ! |
ov.names.ind <- lavpta$vnames$ov.ind[[b]] |
| 56 | ! |
ov.names.ord <- lavpta$vnames$ov.ord[[b]] |
| 57 | ||
| 58 | ! |
lv.names <- lavpta$vnames$lv[[b]] |
| 59 | ||
| 60 |
# eqs.y, eqs.x |
|
| 61 | ! |
eqs.names <- unique(c( |
| 62 | ! |
lavpta$vnames$eqs.y[[b]], |
| 63 | ! |
lavpta$vnames$eqs.x[[b]] |
| 64 |
)) |
|
| 65 | ! |
if (length(eqs.names) > 0L) {
|
| 66 | ! |
eqs.y <- eqs.names |
| 67 | ! |
if (strict.exo) {
|
| 68 | ! |
x.idx <- which(eqs.names %in% ov.names.x) |
| 69 | ! |
if (length(x.idx) > 0L) {
|
| 70 | ! |
eqs.y <- eqs.names[-x.idx] |
| 71 |
} |
|
| 72 |
} |
|
| 73 | ! |
eqs.x <- eqs.names |
| 74 |
} else {
|
|
| 75 | ! |
eqs.y <- character(0L) |
| 76 | ! |
eqs.x <- character(0L) |
| 77 |
} |
|
| 78 | ||
| 79 |
# 1 "=~" |
|
| 80 | ! |
l.lhs <- rep(lv.names, each = length(ov.names.nox)) |
| 81 | ! |
l.rhs <- rep(ov.names.nox, times = length(lv.names)) |
| 82 | ||
| 83 |
# remove factor ~ eqs.y combinations, if any |
|
| 84 |
# because they also appear as a regression |
|
| 85 | ! |
bad.idx <- which(l.lhs %in% lv.names & |
| 86 | ! |
l.rhs %in% eqs.y) |
| 87 | ! |
if (length(bad.idx) > 0L) {
|
| 88 | ! |
l.lhs <- l.lhs[-bad.idx] |
| 89 | ! |
l.rhs <- l.rhs[-bad.idx] |
| 90 |
} |
|
| 91 | ! |
l.op <- rep("=~", length(l.lhs))
|
| 92 | ||
| 93 |
# 2a. "~~" ov ## FIXME: ov.names.nox or ov.names?? |
|
| 94 |
# if(strict.exo) {
|
|
| 95 | ! |
OV <- ov.names.nox |
| 96 |
# } else {
|
|
| 97 |
# OV <- ov.names |
|
| 98 |
# } |
|
| 99 | ! |
nx <- length(OV) |
| 100 | ! |
idx <- lower.tri(matrix(0, nx, nx), diag = TRUE) |
| 101 | ! |
ov.lhs <- rep(OV, each = nx)[idx] # fill upper.tri |
| 102 | ! |
ov.rhs <- rep(OV, times = nx)[idx] |
| 103 | ! |
ov.op <- rep("~~", length(ov.lhs))
|
| 104 | ||
| 105 |
# remove dummy indicators that correlate with 'proper' |
|
| 106 |
# indicators; new in 0.6-14; fixed in 0.6-16 |
|
| 107 | ! |
ov.other <- ov.names[!ov.names %in% c( |
| 108 | ! |
ov.names.ind, ov.names.x, |
| 109 | ! |
eqs.x, eqs.y |
| 110 |
)] |
|
| 111 | ! |
if (length(ov.other) > 0L) {
|
| 112 | ! |
bad.idx <- which((ov.lhs %in% ov.names & |
| 113 | ! |
ov.rhs %in% ov.other) | |
| 114 | ! |
(ov.lhs %in% ov.other & |
| 115 | ! |
ov.rhs %in% ov.names)) |
| 116 | ! |
if (length(bad.idx) > 0L) {
|
| 117 | ! |
ov.lhs <- ov.lhs[-bad.idx] |
| 118 | ! |
ov.rhs <- ov.rhs[-bad.idx] |
| 119 | ! |
ov.op <- ov.op[-bad.idx] |
| 120 |
} |
|
| 121 |
} |
|
| 122 | ||
| 123 |
# exo ~~ |
|
| 124 | ! |
if (!strict.exo && length(ov.names.x) > 0L) {
|
| 125 | ! |
OV <- ov.names.x |
| 126 | ! |
nx <- length(OV) |
| 127 | ! |
idx <- lower.tri(matrix(0, nx, nx), diag = TRUE) |
| 128 | ! |
more.lhs <- rep(OV, each = nx)[idx] # fill upper.tri |
| 129 | ! |
more.rhs <- rep(OV, times = nx)[idx] |
| 130 | ! |
ov.lhs <- c(ov.lhs, more.lhs) |
| 131 | ! |
ov.rhs <- c(ov.rhs, more.rhs) |
| 132 | ! |
ov.op <- c(ov.op, rep("~~", length(more.lhs)))
|
| 133 |
} |
|
| 134 | ||
| 135 |
# 2b. "~~" lv |
|
| 136 | ! |
nx <- length(lv.names) |
| 137 | ! |
idx <- lower.tri(matrix(0, nx, nx), diag = TRUE) |
| 138 | ! |
lv.lhs <- rep(lv.names, each = nx)[idx] # fill upper.tri |
| 139 | ! |
lv.rhs <- rep(lv.names, times = nx)[idx] |
| 140 | ! |
lv.op <- rep("~~", length(lv.lhs))
|
| 141 | ||
| 142 |
# 3 regressions? |
|
| 143 | ! |
r.lhs <- r.rhs <- r.op <- character(0) |
| 144 | ! |
if (length(eqs.names) > 0L) {
|
| 145 | ! |
r.lhs <- rep(eqs.y, each = length(eqs.x)) |
| 146 | ! |
r.rhs <- rep(eqs.x, times = length(eqs.y)) |
| 147 | ||
| 148 |
# remove self-arrows |
|
| 149 | ! |
idx <- which(r.lhs == r.rhs) |
| 150 | ! |
if (length(idx) > 0L) {
|
| 151 | ! |
r.lhs <- r.lhs[-idx] |
| 152 | ! |
r.rhs <- r.rhs[-idx] |
| 153 |
} |
|
| 154 | ||
| 155 |
# remove indicator ~ factor if they exist |
|
| 156 | ! |
bad.idx <- which(r.lhs %in% ov.names.ind & |
| 157 | ! |
r.rhs %in% lv.names) |
| 158 | ! |
if (length(bad.idx) > 0L) {
|
| 159 | ! |
r.lhs <- r.lhs[-bad.idx] |
| 160 | ! |
r.rhs <- r.rhs[-bad.idx] |
| 161 |
} |
|
| 162 | ||
| 163 | ! |
r.op <- rep("~", length(r.rhs))
|
| 164 |
} |
|
| 165 | ||
| 166 |
# 4. intercepts |
|
| 167 | ! |
int.lhs <- int.rhs <- int.op <- character(0) |
| 168 | ! |
if (meanstructure) {
|
| 169 | ! |
if (strict.exo) {
|
| 170 | ! |
int.lhs <- c(ov.names.nox, lv.names) |
| 171 |
} else {
|
|
| 172 | ! |
int.lhs <- c(ov.names, lv.names) |
| 173 |
} |
|
| 174 | ! |
int.rhs <- rep("", length(int.lhs))
|
| 175 | ! |
int.op <- rep("~1", length(int.lhs))
|
| 176 |
} |
|
| 177 | ||
| 178 |
# 5. thresholds |
|
| 179 | ! |
th.lhs <- th.rhs <- th.op <- character(0) |
| 180 | ! |
if (length(ov.names.ord) > 0L) {
|
| 181 | ! |
th.names <- lavpta$vnames$th[[b]] |
| 182 | ! |
tmp <- strsplit(th.names, "\\|") |
| 183 | ! |
th.lhs <- sapply(tmp, function(x) x[1]) |
| 184 | ! |
th.rhs <- sapply(tmp, function(x) x[2]) |
| 185 | ! |
th.op <- rep("|", length(th.lhs))
|
| 186 |
} |
|
| 187 | ||
| 188 |
# 6. scaling parameters |
|
| 189 | ! |
delta.lhs <- delta.rhs <- delta.op <- character(0) |
| 190 | ! |
if (ngroups > 1L && length(ov.names.ord) > 0L) {
|
| 191 | ! |
delta.lhs <- ov.names.ord |
| 192 | ! |
delta.rhs <- ov.names.ord |
| 193 | ! |
delta.op <- rep("~*~", length(delta.lhs))
|
| 194 |
} |
|
| 195 | ||
| 196 |
# combine |
|
| 197 | ! |
this.lhs <- c( |
| 198 | ! |
l.lhs, ov.lhs, lv.lhs, r.lhs, int.lhs, th.lhs, |
| 199 | ! |
delta.lhs |
| 200 |
) |
|
| 201 | ! |
this.rhs <- c( |
| 202 | ! |
l.rhs, ov.rhs, lv.rhs, r.rhs, int.rhs, th.rhs, |
| 203 | ! |
delta.rhs |
| 204 |
) |
|
| 205 | ! |
this.op <- c( |
| 206 | ! |
l.op, ov.op, lv.op, r.op, int.op, th.op, |
| 207 | ! |
delta.op |
| 208 |
) |
|
| 209 | ! |
n.el <- length(this.lhs) |
| 210 | ||
| 211 | ! |
lhs <- c(lhs, this.lhs) |
| 212 | ! |
rhs <- c(rhs, this.rhs) |
| 213 | ! |
op <- c(op, this.op) |
| 214 | ! |
block <- c(block, rep(b, n.el)) |
| 215 | ! |
group <- c(group, rep(GROUP.values[g], n.el)) |
| 216 | ! |
level <- c(level, rep(LEVEL.values[l], n.el)) |
| 217 |
} # level |
|
| 218 |
} # group |
|
| 219 | ||
| 220 | ! |
LIST <- data.frame( |
| 221 | ! |
lhs = lhs, op = op, rhs = rhs, block = block, |
| 222 | ! |
group = group, level = level, stringsAsFactors = FALSE |
| 223 |
) |
|
| 224 | ||
| 225 | ! |
if (free) {
|
| 226 | ! |
LIST$free <- rep(0L, nrow(LIST)) |
| 227 |
} |
|
| 228 | ||
| 229 | ! |
if (start) {
|
| 230 | ! |
LIST$start <- rep(0, nrow(LIST)) |
| 231 |
} |
|
| 232 | ||
| 233 | ! |
LIST |
| 234 |
} |
| 1 |
# export `lavaan' lav model description to third-party software |
|
| 2 |
# |
|
| 3 | ||
| 4 |
lav_export <- function(object, target = "lavaan", prefix = "sem", |
|
| 5 |
dir.name = "lav_export", export = TRUE) {
|
|
| 6 | ! |
stopifnot(inherits(object, "lavaan")) |
| 7 |
# check object |
|
| 8 | ! |
object <- lav_object_check_version(object) |
| 9 | ! |
target <- tolower(target) |
| 10 | ||
| 11 |
# check for conditional.x = TRUE |
|
| 12 |
# if(object@Model@conditional.x) {
|
|
| 13 |
# stop("lavaan ERROR: this function is not (yet) available if conditional.x = TRUE")
|
|
| 14 |
# } |
|
| 15 | ||
| 16 | ! |
ngroups <- object@Data@ngroups |
| 17 | ! |
if (ngroups > 1L) {
|
| 18 | ! |
group.label2 <- paste(".", object@Data@group.label, sep = "")
|
| 19 |
} else {
|
|
| 20 | ! |
group.label2 <- "" |
| 21 |
} |
|
| 22 | ! |
data.file <- paste(prefix, group.label2, ".", target, ".raw", sep = "") |
| 23 | ||
| 24 |
# 2. create syntax file |
|
| 25 | ! |
if (target == "lavaan") {
|
| 26 | ! |
header <- "" |
| 27 | ! |
syntax <- lav_export_lavaan(object) |
| 28 | ! |
footer <- "" |
| 29 | ! |
out <- paste(header, syntax, footer, sep = "") |
| 30 | ! |
} else if (target == "mplus") {
|
| 31 | ! |
header <- lav_mplus_header( |
| 32 | ! |
data.file = data.file, |
| 33 | ! |
group.label = object@Data@group.label, |
| 34 | ! |
ov.names = c( |
| 35 | ! |
lav_partable_vnames(object@ParTable, "ov"), |
| 36 | ! |
object@Data@sampling.weights |
| 37 |
), |
|
| 38 | ! |
ov.ord.names = lav_partable_vnames(object@ParTable, "ov.ord"), |
| 39 | ! |
weight.name = object@Data@sampling.weights, |
| 40 | ! |
listwise = lavInspect(object, "options")$missing == "listwise", |
| 41 | ! |
estimator = lav_mplus_estimator(object), |
| 42 | ! |
information = lavInspect(object, "options")$information, |
| 43 | ! |
meanstructure = lavInspect(object, "meanstructure"), |
| 44 | ! |
data.type = object@Data@data.type, |
| 45 | ! |
nobs = object@Data@nobs[[1L]] |
| 46 |
) |
|
| 47 | ! |
syntax <- lav_export_mplus(object, group.label = object@Data@group.label) |
| 48 | ! |
footer <- paste("OUTPUT:\n sampstat standardized tech1;\n")
|
| 49 | ! |
out <- paste(header, syntax, footer, sep = "") |
| 50 | ! |
} else if (target == "lisrel") {
|
| 51 | ! |
syntax <- lav_export_lisrel(object) |
| 52 | ! |
} else if (target == "eqs") {
|
| 53 | ! |
syntax <- lav_export_eqs(object) |
| 54 | ! |
} else if (target == "sem") {
|
| 55 | ! |
syntax <- lav_export_sem(object) |
| 56 | ! |
} else if (target == "openmx") {
|
| 57 | ! |
syntax <- lav_export_openmx(object) |
| 58 |
} else {
|
|
| 59 | ! |
lav_msg_stop(gettextf("target %s has not been implemented yet", target))
|
| 60 |
} |
|
| 61 | ||
| 62 |
# export to file? |
|
| 63 | ! |
if (export) {
|
| 64 | ! |
dir.create(path = dir.name) |
| 65 | ! |
input.file <- paste(dir.name, "/", prefix, ".", target, ".in", sep = "") |
| 66 | ! |
cat(out, file = input.file, sep = "") |
| 67 | ||
| 68 |
# write data (if available) |
|
| 69 | ! |
if (identical(object@Data@data.type, "full")) {
|
| 70 | ! |
for (g in 1:ngroups) {
|
| 71 | ! |
if (is.null(object@Data@eXo[[g]])) {
|
| 72 | ! |
DATA <- object@Data@X[[g]] |
| 73 |
} else {
|
|
| 74 | ! |
DATA <- cbind(object@Data@X[[g]], object@Data@eXo[[g]]) |
| 75 |
} |
|
| 76 | ! |
if (!is.null(object@Data@weights[[g]])) {
|
| 77 | ! |
DATA <- cbind(DATA, object@Data@weights[[g]]) |
| 78 |
} |
|
| 79 | ! |
write.table(DATA, |
| 80 | ! |
file = paste(dir.name, "/", data.file[g], sep = ""), |
| 81 | ! |
na = "-999999", |
| 82 | ! |
col.names = FALSE, row.names = FALSE, quote = FALSE |
| 83 |
) |
|
| 84 |
} |
|
| 85 | ! |
} else if (identical(object@Data@data.type, "moment")) {
|
| 86 | ! |
for (g in 1:ngroups) {
|
| 87 | ! |
DATA <- object@SampleStats@cov[[g]] |
| 88 | ! |
write.table(DATA, |
| 89 | ! |
file = paste(dir.name, "/", data.file[g], sep = ""), |
| 90 | ! |
na = "-999999", |
| 91 | ! |
col.names = FALSE, row.names = FALSE, quote = FALSE |
| 92 |
) |
|
| 93 |
} |
|
| 94 |
} else {
|
|
| 95 | ! |
lav_msg_warn(gettext("not data available"))
|
| 96 |
} |
|
| 97 | ! |
return(invisible(out)) |
| 98 |
} else {
|
|
| 99 |
# just return the syntax file for inspection |
|
| 100 | ! |
class(out) <- c("lavaan.character", "character")
|
| 101 |
} |
|
| 102 | ||
| 103 | ! |
out |
| 104 |
} |
|
| 105 |
lavExport <- lav_export # synonym #nolint |
|
| 106 | ||
| 107 | ||
| 108 |
lav_export_check <- function(lav) {
|
|
| 109 | ! |
if (inherits(lav, "lavaan")) {
|
| 110 | ! |
lav <- lav@ParTable |
| 111 | ! |
} else if (is.list(lav)) {
|
| 112 |
# nothing to do |
|
| 113 |
} else {
|
|
| 114 | ! |
lav_msg_stop(gettext("lav must be of class `lavaan' or a parTable"))
|
| 115 |
} |
|
| 116 | ||
| 117 |
# check syntax |
|
| 118 | ! |
if (is.null(lav$ustart)) lav$ustart <- lav$est |
| 119 | ||
| 120 |
# check if free is missing |
|
| 121 | ! |
if (is.null(lav$free)) lav$free <- rep(0L, length(lav$ustart)) |
| 122 | ||
| 123 |
# check if label is missing |
|
| 124 | ! |
if (is.null(lav$label)) lav$label <- rep("", length(lav$ustart))
|
| 125 | ||
| 126 |
# check if group is missing |
|
| 127 | ! |
if (is.null(lav$group)) lav$group <- rep(1L, length(lav$ustart)) |
| 128 | ||
| 129 |
# if eq.id not all zero, create labels instead |
|
| 130 |
# if(!is.null(lav$eq.id) && !all(lav$eq.id == 0L)) {
|
|
| 131 |
# lav$label <- paste("p",as.character(lav$eq.id), sep="")
|
|
| 132 |
# lav$label[lav$label == "p0"] <- "" |
|
| 133 |
# } |
|
| 134 | ||
| 135 | ! |
lav |
| 136 |
} |
|
| 137 | ||
| 138 |
## FIXME: this is completely UNFINISHED (just used to quickly get something) |
|
| 139 |
lav_export_lavaan <- function(lav) {
|
|
| 140 | ! |
lav <- lav_export_check(lav) |
| 141 | ! |
header <- "# this model syntax is autogenerated by lav_export\n" |
| 142 | ! |
footer <- "\n" |
| 143 | ||
| 144 |
# intercepts |
|
| 145 | ! |
int.idx <- which(lav$op == "~1") |
| 146 | ! |
lav$op[int.idx] <- "~" |
| 147 | ! |
lav$rhs[int.idx] <- "1" |
| 148 | ||
| 149 |
# spacing around operator |
|
| 150 | ! |
lav$op <- paste(" ", lav$op, " ", sep = "")
|
| 151 | ||
| 152 | ! |
lav2 <- ifelse(lav$free != 0L, |
| 153 | ! |
ifelse(lav$label == "", |
| 154 | ! |
paste(lav$lhs, lav$op, lav$rhs, sep = ""), |
| 155 | ! |
paste(lav$lhs, lav$op, lav$label, "*", lav$rhs, |
| 156 | ! |
sep = "" |
| 157 |
) |
|
| 158 |
), |
|
| 159 | ! |
ifelse(lav$label == "", |
| 160 | ! |
paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, |
| 161 | ! |
sep = "" |
| 162 |
), |
|
| 163 | ! |
paste(lav$lhs, lav$op, lav$ustart, "*", lav$rhs, |
| 164 | ! |
"+", lav$label, "*", lav$rhs, |
| 165 | ! |
sep = "" |
| 166 |
) |
|
| 167 |
) |
|
| 168 |
) |
|
| 169 | ||
| 170 | ! |
body <- paste(lav2, collapse = "\n") |
| 171 | ! |
out <- paste(header, body, footer, sep = "") |
| 172 | ! |
class(out) <- c("lavaan.character", "character")
|
| 173 | ! |
out |
| 174 |
} |
|
| 175 | ||
| 176 |
lav_export_lisrel <- function(lav) {
|
|
| 177 | ! |
lav <- lav_export_check(lav) |
| 178 | ! |
lav_msg_stop(gettext("this function needs revision"))
|
| 179 |
} |
|
| 180 | ||
| 181 |
lav_export_eqs <- function(lav) {
|
|
| 182 | ! |
lav <- lav_export_check(lav) |
| 183 | ! |
lav_msg_stop(gettext("this function needs revision"))
|
| 184 |
} |
|
| 185 | ||
| 186 |
lav_export_sem <- function(lav) {
|
|
| 187 | ! |
lav <- lav_export_check(lav) |
| 188 | ! |
lav_msg_stop(gettext("this function needs revision"))
|
| 189 |
} |
|
| 190 | ||
| 191 |
lav_export_openmx <- function(lav) {
|
|
| 192 | ! |
lav <- lav_export_check(lav) |
| 193 | ! |
lav_msg_stop(gettext("this function needs revision"))
|
| 194 |
} |
| 1 |
# lav_options specific per estimator in separate functions LDW 06/04/2024 |
|
| 2 | ||
| 3 |
lav_options_est_ml <- function(opt) {
|
|
| 4 |
# ML and friends: MLF, MLM, MLMV, MLMVS, MLR #### |
|
| 5 |
# se |
|
| 6 | 69x |
if (opt$se == "bootstrap" && |
| 7 | 69x |
opt$estimator %in% c("mlf", "mlm", "mlmv", "mlmvs", "mlr")) {
|
| 8 | ! |
lav_msg_stop(gettext("use ML estimator for bootstrap"))
|
| 9 | 69x |
} else if (opt$se == "default") {
|
| 10 | 36x |
if (opt$estimator %in% c("ml", "mlf")) {
|
| 11 | 34x |
opt$se <- "standard" |
| 12 | 2x |
} else if (opt$estimator %in% c("mlm", "mlmv", "mlmvs")) {
|
| 13 | ! |
opt$se <- "robust.sem" |
| 14 | 2x |
} else if (opt$estimator == "mlr") {
|
| 15 | 2x |
opt$se <- "robust.huber.white" |
| 16 |
} |
|
| 17 | 33x |
} else if (opt$se == "robust") {
|
| 18 | ! |
if (opt$missing %in% c("ml", "ml.x")) {
|
| 19 | ! |
opt$se <- "robust.huber.white" |
| 20 | ! |
} else if (opt$missing == "two.stage") { # needed?
|
| 21 | ! |
opt$se <- "two.stage" |
| 22 | ! |
} else if (opt$missing == "robust.two.stage") { # needed?
|
| 23 | ! |
opt$se <- "robust.two.stage" |
| 24 |
} else {
|
|
| 25 | ! |
opt$se <- "robust.sem" |
| 26 |
} |
|
| 27 |
} |
|
| 28 |
# information |
|
| 29 | 69x |
if (opt$estimator == "mlf") {
|
| 30 | ! |
if (opt$information[1] == "default") {
|
| 31 | ! |
opt$information[1] <- "first.order" |
| 32 |
} |
|
| 33 | ! |
if (length(opt$information) > 1L && |
| 34 | ! |
opt$information[2] == "default") {
|
| 35 | ! |
opt$information[2] <- "first.order" |
| 36 |
} |
|
| 37 |
} |
|
| 38 |
# test |
|
| 39 | 69x |
if (!opt$test[1] == "none") {
|
| 40 | 69x |
if (opt$estimator %in% c("ml", "mlf")) {
|
| 41 | 67x |
if (opt$test[1] == "default") {
|
| 42 | 35x |
opt$test <- "standard" |
| 43 |
} # else {
|
|
| 44 |
# opt$test <- union("standard", opt$test)
|
|
| 45 |
# } |
|
| 46 | 2x |
} else if (opt$estimator == "mlm") {
|
| 47 | ! |
if (opt$test[1] == "default") {
|
| 48 | ! |
opt$test <- "satorra.bentler" |
| 49 |
} else {
|
|
| 50 | ! |
opt$test <- union("satorra.bentler", opt$test)
|
| 51 |
} |
|
| 52 | 2x |
} else if (opt$estimator == "mlmv") {
|
| 53 | ! |
if (opt$test[1] == "default") {
|
| 54 | ! |
opt$test <- "scaled.shifted" |
| 55 |
} else {
|
|
| 56 | ! |
opt$test <- union("scaled.shifted", opt$test)
|
| 57 |
} |
|
| 58 | 2x |
} else if (opt$estimator == "mlmvs") {
|
| 59 | ! |
if (opt$test[1] == "default") {
|
| 60 | ! |
opt$test <- "mean.var.adjusted" |
| 61 |
} else {
|
|
| 62 | ! |
opt$test <- union("mean.var.adjusted", opt$test)
|
| 63 |
} |
|
| 64 |
} |
|
| 65 |
} |
|
| 66 | 69x |
opt |
| 67 |
} |
|
| 68 | ||
| 69 |
lav_options_est_gls <- function(opt) {
|
|
| 70 |
# GLS #### |
|
| 71 |
# FIXME: catch categorical, clustered, ... |
|
| 72 |
# se |
|
| 73 | 6x |
if (opt$se == "default") {
|
| 74 | 6x |
opt$se <- "standard" |
| 75 |
} |
|
| 76 |
# test |
|
| 77 | 6x |
if (opt$test[1] == "default") {
|
| 78 | 6x |
opt$test <- "standard" |
| 79 |
} |
|
| 80 | 6x |
bad.idx <- which(!opt$test %in% c( |
| 81 | 6x |
"standard", "none", |
| 82 | 6x |
"browne.residual.nt", # == standard |
| 83 | 6x |
"browne.residual.nt.model", |
| 84 | 6x |
"browne.residual.adf", |
| 85 | 6x |
"browne.residual.adf.model" |
| 86 |
)) |
|
| 87 | 6x |
if (length(bad.idx) > 0L) {
|
| 88 | ! |
lav_msg_stop(gettextf( |
| 89 | ! |
"invalid value(s) in test= argument when estimator is GLS: %s.", |
| 90 | ! |
paste(opt$test[bad.idx], collapse = " "))) |
| 91 |
} |
|
| 92 |
# missing |
|
| 93 | 6x |
opt$missing <- "listwise" # also pairwise? |
| 94 | 6x |
opt |
| 95 |
} |
|
| 96 | ||
| 97 |
lav_options_est_ntrls <- function(opt) {
|
|
| 98 |
# NTRLS (experimental) #### |
|
| 99 |
# optim.gradient |
|
| 100 | ! |
opt$optim.gradien <- "numerical" |
| 101 |
# se |
|
| 102 | ! |
if (opt$se == "default") {
|
| 103 | ! |
opt$se <- "standard" |
| 104 |
} |
|
| 105 |
# test |
|
| 106 | ! |
if (opt$test[1] == "default") {
|
| 107 | ! |
opt$test <- "standard" |
| 108 |
} |
|
| 109 | ! |
bad.idx <- which(!opt$test %in% c( |
| 110 | ! |
"standard", "none", |
| 111 | ! |
"browne.residual.nt", |
| 112 | ! |
"browne.residual.nt.model", |
| 113 | ! |
"browne.residual.adf", |
| 114 | ! |
"browne.residual.adf.model" |
| 115 |
)) |
|
| 116 | ! |
if (length(bad.idx) > 0L) {
|
| 117 | ! |
lav_msg_stop(gettextf( |
| 118 | ! |
"invalid value(s) in test= argument when estimator is NTRLS: %s.", |
| 119 | ! |
paste(opt$test[bad.idx], collapse = " "))) |
| 120 |
} |
|
| 121 |
# missing |
|
| 122 | ! |
opt$missing <- "listwise" |
| 123 | ! |
opt |
| 124 |
} |
|
| 125 | ||
| 126 |
lav_options_est_catml <- function(opt) {
|
|
| 127 |
# catML (experimental) #### |
|
| 128 |
# optim.gradient |
|
| 129 | ! |
opt$optim.gradient <- "numerical" # for now |
| 130 |
# force correlation = TRUE, and categorical = FALSE |
|
| 131 | ! |
opt$correlation <- TRUE |
| 132 | ! |
opt$.categorical <- FALSE # we 'pretend' to have continuous data! |
| 133 |
# se |
|
| 134 | ! |
if (opt$se == "default") {
|
| 135 | ! |
opt$se <- "robust.sem" # for now |
| 136 |
} |
|
| 137 |
# test |
|
| 138 | ! |
if (opt$test[1] == "default") {
|
| 139 | ! |
opt$test <- "satorra.bentler" |
| 140 |
} |
|
| 141 |
# missing |
|
| 142 | ! |
if (opt$missing %in% c("listwise", "pairwise")) {
|
| 143 |
# nothing to do |
|
| 144 | ! |
} else if (opt$missing == "default") {
|
| 145 | ! |
opt$missing <- "listwise" |
| 146 |
} else {
|
|
| 147 | ! |
lav_msg_stop(gettext( |
| 148 | ! |
"missing argument should be listwise or pairwise if estimator is catML")) |
| 149 |
} |
|
| 150 | ! |
opt |
| 151 |
} |
|
| 152 | ||
| 153 |
lav_options_est_wls <- function(opt) {
|
|
| 154 |
# WLS #### |
|
| 155 |
# se |
|
| 156 | 2x |
if (opt$se == "default") {
|
| 157 | 2x |
opt$se <- "standard" |
| 158 |
} |
|
| 159 |
# test |
|
| 160 | 2x |
if (opt$test[1] == "default") {
|
| 161 | 2x |
opt$test <- "standard" |
| 162 |
} |
|
| 163 | 2x |
bad.idx <- which(!opt$test %in% c( |
| 164 | 2x |
"standard", "none", |
| 165 | 2x |
"browne.residual.nt", |
| 166 | 2x |
"browne.residual.nt.model", |
| 167 | 2x |
"browne.residual.adf", # == standard |
| 168 | 2x |
"browne.residual.adf.model" |
| 169 |
)) |
|
| 170 | 2x |
if (length(bad.idx) > 0L) {
|
| 171 | ! |
lav_msg_stop(gettextf( |
| 172 | ! |
"invalid value(s) in test= argument when estimator is WLS: %s.", |
| 173 | ! |
paste(opt$test[bad.idx], collapse = " "))) |
| 174 |
} |
|
| 175 |
# missing |
|
| 176 |
# opt$missing <- "listwise" (could be pairwise) |
|
| 177 | 2x |
opt |
| 178 |
} |
|
| 179 | ||
| 180 |
lav_options_est_dls <- function(opt) {
|
|
| 181 |
# DLS #### |
|
| 182 |
# se |
|
| 183 | ! |
if (opt$se == "default") {
|
| 184 | ! |
opt$se <- "robust.sem" |
| 185 |
} |
|
| 186 |
# test |
|
| 187 | ! |
if (opt$test[1] == "default") {
|
| 188 | ! |
opt$test <- "satorra.bentler" |
| 189 |
} |
|
| 190 | ! |
bad.idx <- which(!opt$test %in% c( |
| 191 | ! |
"standard", "none", |
| 192 | ! |
"satorra.bentler", |
| 193 | ! |
"browne.residual.nt", # == standard |
| 194 | ! |
"browne.residual.nt.model", |
| 195 | ! |
"browne.residual.adf", |
| 196 | ! |
"browne.residual.adf.model" |
| 197 |
)) |
|
| 198 | ! |
if (length(bad.idx) > 0L) {
|
| 199 | ! |
lav_msg_stop(gettextf( |
| 200 | ! |
"invalid value(s) in test= argument when estimator is DLS: %s.", |
| 201 | ! |
paste(opt$test[bad.idx], collapse = " "))) |
| 202 |
} |
|
| 203 |
# always include "satorra.bentler" |
|
| 204 | ! |
if (opt$test[1] %in% c( |
| 205 | ! |
"browne.residual.nt", "browne.residual.adf", |
| 206 | ! |
"browne.residual.nt.model", |
| 207 | ! |
"browne.residual.adf.model" |
| 208 |
)) {
|
|
| 209 | ! |
opt$test <- union("satorra.bentler", opt$test)
|
| 210 |
} |
|
| 211 |
# missing |
|
| 212 | ! |
opt$missing <- "listwise" |
| 213 |
# estimator.args |
|
| 214 | ! |
if (is.null(opt$estimator.args)) {
|
| 215 | ! |
opt$estimator.args <- list( |
| 216 | ! |
dls.a = 1.0, dls.GammaNT = "model", |
| 217 | ! |
dls.FtimesNmin1 = FALSE |
| 218 |
) |
|
| 219 |
} else {
|
|
| 220 | ! |
if (is.null(opt$estimator.args$dls.a)) {
|
| 221 | ! |
opt$estimator.args$dls.a <- 1.0 |
| 222 |
} else {
|
|
| 223 | ! |
stopifnot(is.numeric(opt$estimator.args$dls.a)) |
| 224 | ! |
if (opt$estimator.args$dls.a < 0.0 || |
| 225 | ! |
opt$estimator.args$dls.a > 1.0) {
|
| 226 | ! |
lav_msg_stop(gettext( |
| 227 | ! |
"dls.a value in estimator.args must be between 0 and 1.")) |
| 228 |
} |
|
| 229 |
} |
|
| 230 | ! |
if (is.null(opt$estimator.args$dls.GammaNT)) {
|
| 231 | ! |
opt$estimator.args$dls.GammaNT <- "model" |
| 232 |
} else {
|
|
| 233 | ! |
stopifnot(is.character(opt$estimator.args$dls.GammaNT)) |
| 234 | ! |
opt$estimator.args$dls.GammaNT <- |
| 235 | ! |
tolower(opt$estimator.args$dls.GammaNT) |
| 236 | ! |
if (!opt$estimator.args$dls.GammaNT %in% c("sample", "model")) {
|
| 237 | ! |
lav_msg_stop(gettextf( |
| 238 | ! |
"dls.GammaNT value in estimator.args must be either %s.", |
| 239 | ! |
lav_msg_view(c("sample", "model"), log.sep = "or")))
|
| 240 |
} |
|
| 241 |
} |
|
| 242 | ! |
if (is.null(opt$estimator.args$dls.FtimesNminus1)) {
|
| 243 | ! |
opt$estimator.args$dls.FtimesNminus1 <- FALSE |
| 244 |
} else {
|
|
| 245 | ! |
stopifnot(is.logical(opt$estimator.args$dls.FtimesNminus1)) |
| 246 |
} |
|
| 247 |
} |
|
| 248 | ! |
if (opt$estimator.args$dls.GammaNT == "sample") {
|
| 249 | ! |
if (opt$optim.method %in% c("nlminb", "gn")) {
|
| 250 |
# nothing to do |
|
| 251 | ! |
} else if (opt$optim.method == "default") {
|
| 252 | ! |
opt$optim.method <- "gn" |
| 253 |
} else {
|
|
| 254 | ! |
lav_msg_stop(gettext( |
| 255 | ! |
"optim.method must be either nlminb or gn if estimator is DLS.")) |
| 256 |
} |
|
| 257 |
} else {
|
|
| 258 | ! |
if (opt$optim.method %in% c("gn")) {
|
| 259 |
# nothing to do |
|
| 260 | ! |
} else if (opt$optim.method == "default") {
|
| 261 | ! |
opt$optim.method <- "gn" |
| 262 | ! |
} else if (opt$optim.method == "nlminb") {
|
| 263 | ! |
opt$optim.gradient <- "numerical" |
| 264 |
} else {
|
|
| 265 | ! |
lav_msg_stop(gettext( |
| 266 | ! |
"optim.method must be either nlminb or gn if estimator is DLS.")) |
| 267 |
} |
|
| 268 |
} |
|
| 269 | ! |
opt |
| 270 |
} |
|
| 271 | ||
| 272 |
lav_options_est_dwls <- function(opt) {
|
|
| 273 |
# DWLS, WLSM, WLSMV, WLSMVS #### |
|
| 274 |
# new in 0.6-17: if !categorical, give a warning |
|
| 275 | 2x |
if (!opt$.categorical) {
|
| 276 | ! |
lav_msg_warn(gettextf( |
| 277 | ! |
"estimator %s is not recommended for continuous data. |
| 278 | ! |
Did you forget to set the ordered= argument?", |
| 279 | ! |
dQuote(lav_options_estimatorgroup(opt$estimator)))) |
| 280 |
} |
|
| 281 |
# se |
|
| 282 | 2x |
if (opt$se == "bootstrap" && |
| 283 | 2x |
opt$estimator %in% c("wlsm", "wlsmv", "wlsmvs")) {
|
| 284 | ! |
lav_msg_stop(gettext("use (D)WLS estimator for bootstrap"))
|
| 285 | 2x |
} else if (opt$se == "default") {
|
| 286 | 2x |
if (opt$estimator == "dwls" && !opt$.categorical) {
|
| 287 |
# opt$se <- "standard" |
|
| 288 | ! |
opt$se <- "robust.sem.nt" # new in 0.6-21 |
| 289 |
} else {
|
|
| 290 | 2x |
opt$se <- "robust.sem" |
| 291 |
} |
|
| 292 | ! |
} else if (opt$se == "robust") {
|
| 293 | ! |
opt$se <- "robust.sem" |
| 294 |
} |
|
| 295 |
# test |
|
| 296 | 2x |
if (!opt$test[1] == "none") {
|
| 297 | 2x |
if (opt$estimator == "dwls") {
|
| 298 | ! |
if (opt$test[1] == "default" && !opt$.categorical) {
|
| 299 |
#opt$test <- "standard" |
|
| 300 | ! |
opt$test <- "browne.residual.nt" |
| 301 | ! |
opt$standard.test <- "browne.residual.nt" |
| 302 | ! |
opt$scaled.test <- "browne.residual.nt" |
| 303 | ! |
} else if (opt$test[1] == "default" && opt$.categorical) {
|
| 304 | ! |
opt$test <- "standard" # bad choice! |
| 305 |
} else {
|
|
| 306 | ! |
opt$test <- union("standard", opt$test)
|
| 307 |
} |
|
| 308 | 2x |
} else if (opt$estimator == "wlsm") {
|
| 309 | ! |
if (opt$test[1] == "default") {
|
| 310 | ! |
opt$test <- "satorra.bentler" |
| 311 |
} else {
|
|
| 312 | ! |
opt$test <- union("satorra.bentler", opt$test)
|
| 313 |
} |
|
| 314 | 2x |
} else if (opt$estimator == "wlsmv") {
|
| 315 | 2x |
if (opt$test[1] == "default") {
|
| 316 | 2x |
opt$test <- "scaled.shifted" |
| 317 |
} else {
|
|
| 318 | ! |
opt$test <- union("scaled.shifted", opt$test)
|
| 319 |
} |
|
| 320 | ! |
} else if (opt$estimator == "wlsmvs") {
|
| 321 | ! |
if (opt$test[1] == "default") {
|
| 322 | ! |
opt$test <- "mean.var.adjusted" |
| 323 |
} else {
|
|
| 324 | ! |
opt$test <- union("mean.var.adjusted", opt$test)
|
| 325 |
} |
|
| 326 |
} |
|
| 327 |
} |
|
| 328 | 2x |
opt |
| 329 |
} |
|
| 330 | ||
| 331 |
lav_options_est_uls <- function(opt) {
|
|
| 332 |
# ULS, ULSM, ULSMV, ULSMVS #### |
|
| 333 |
# se |
|
| 334 | ! |
if (opt$se == "bootstrap" && |
| 335 | ! |
opt$estimator %in% c("ulsm", "ulsmv", "ulsmvs")) {
|
| 336 | ! |
lav_msg_stop(gettext("use ULS estimator for bootstrap"))
|
| 337 | ! |
} else if (opt$se == "default") {
|
| 338 | ! |
if (opt$estimator == "uls" && !opt$.categorical) {
|
| 339 |
#opt$se <- "standard" |
|
| 340 | ! |
opt$se <- "robust.sem.nt" # new in 0.6-21 |
| 341 |
} else {
|
|
| 342 | ! |
opt$se <- "robust.sem" |
| 343 |
} |
|
| 344 | ! |
} else if (opt$se == "robust") {
|
| 345 | ! |
opt$se <- "robust.sem" |
| 346 |
} |
|
| 347 |
# test |
|
| 348 | ! |
if (!opt$test[1] == "none") {
|
| 349 | ! |
if (opt$estimator == "uls") {
|
| 350 | ! |
if (opt$test[1] == "default" && !opt$.categorical) {
|
| 351 | ! |
opt$test <- "browne.residual.nt" # new in 0.6-21 |
| 352 | ! |
opt$standard.test <- "browne.residual.nt" |
| 353 | ! |
opt$scaled.test <- "browne.residual.nt" |
| 354 | ! |
} else if (opt$test[1] == "default" && opt$.categorical) {
|
| 355 | ! |
opt$test <- "standard" |
| 356 |
} else {
|
|
| 357 | ! |
opt$test <- union("standard", opt$test)
|
| 358 |
} |
|
| 359 | ! |
} else if (opt$estimator == "ulsm") {
|
| 360 | ! |
if (opt$test[1] == "default") {
|
| 361 | ! |
opt$test <- "satorra.bentler" |
| 362 |
} else {
|
|
| 363 | ! |
opt$test <- union("satorra.bentler", opt$test)
|
| 364 |
} |
|
| 365 | ! |
} else if (opt$estimator == "ulsmv") {
|
| 366 | ! |
if (opt$test[1] == "default") {
|
| 367 | ! |
opt$test <- "scaled.shifted" |
| 368 |
} else {
|
|
| 369 | ! |
opt$test <- union("scaled.shifted", opt$test)
|
| 370 |
} |
|
| 371 | ! |
} else if (opt$estimator == "ulsmvs") {
|
| 372 | ! |
if (opt$test[1] == "default") {
|
| 373 | ! |
opt$test <- "mean.var.adjusted" |
| 374 |
} else {
|
|
| 375 | ! |
opt$test <- union("mean.var.adjusted", opt$test)
|
| 376 |
} |
|
| 377 |
} |
|
| 378 |
} |
|
| 379 | ! |
opt |
| 380 |
} |
|
| 381 | ||
| 382 |
lav_options_est_pml <- function(opt) {
|
|
| 383 |
# PML #### |
|
| 384 |
# se |
|
| 385 | ! |
if (opt$se == "default") {
|
| 386 | ! |
opt$se <- "robust.huber.white" |
| 387 |
} |
|
| 388 | ||
| 389 |
# information |
|
| 390 | ! |
opt$information[1] <- "observed" |
| 391 | ! |
if (length(opt$information) > 1L && |
| 392 | ! |
opt$information[2] == "default") {
|
| 393 | ! |
opt$information[2] <- "observed" |
| 394 |
} |
|
| 395 | ! |
if (length(opt$observed.information) > 1L && |
| 396 | ! |
opt$observed.information[2] == "default") {
|
| 397 | ! |
opt$observed.information[2] <- "hessian" |
| 398 |
} |
|
| 399 | ||
| 400 |
# test |
|
| 401 | ! |
if (length(opt$test) > 1L) {
|
| 402 | ! |
lav_msg_stop(gettext( |
| 403 | ! |
"only a single test statistic is allow when estimator is PML.")) |
| 404 |
} |
|
| 405 | ! |
if (!opt$test[1] == "none") {
|
| 406 | ! |
opt$test <- "mean.var.adjusted" |
| 407 |
} |
|
| 408 | ! |
opt |
| 409 |
} |
|
| 410 | ||
| 411 |
lav_options_est_fml <- function(opt) {
|
|
| 412 |
# FML - UMN #### |
|
| 413 |
# optim.gradient |
|
| 414 | ! |
opt$optim.gradient <- "numerical" |
| 415 |
# se |
|
| 416 | ! |
if (opt$se == "default") {
|
| 417 | ! |
opt$se <- "standard" |
| 418 |
} |
|
| 419 |
# information |
|
| 420 | ! |
opt$information[1] <- "observed" |
| 421 | ! |
if (length(opt$information) > 1L && |
| 422 | ! |
opt$information[2] == "default") {
|
| 423 | ! |
opt$information[2] <- "observed" |
| 424 |
} |
|
| 425 |
# test |
|
| 426 | ! |
if (!opt$test[1] == "none") {
|
| 427 | ! |
opt$test <- "standard" |
| 428 |
} |
|
| 429 | ! |
opt |
| 430 |
} |
|
| 431 | ||
| 432 |
lav_options_est_reml <- function(opt) {
|
|
| 433 |
# REML #### |
|
| 434 |
# se |
|
| 435 | ! |
if (opt$se == "default") {
|
| 436 | ! |
opt$se <- "standard" |
| 437 |
} |
|
| 438 |
# information |
|
| 439 | ! |
opt$information[1] <- "observed" |
| 440 | ! |
if (length(opt$information) > 1L && |
| 441 | ! |
opt$information[2] == "default") {
|
| 442 | ! |
opt$information[2] <- "observed" |
| 443 |
} |
|
| 444 |
# test |
|
| 445 | ! |
if (!opt$test[1] == "none") {
|
| 446 | ! |
opt$test <- "standard" |
| 447 |
} |
|
| 448 |
# missing |
|
| 449 | ! |
opt$missing <- "listwise" |
| 450 | ! |
opt |
| 451 |
} |
|
| 452 | ||
| 453 |
lav_options_est_mml <- function(opt) {
|
|
| 454 |
# MML #### |
|
| 455 |
# se |
|
| 456 | ! |
if (opt$se == "default") {
|
| 457 | ! |
opt$se <- "standard" |
| 458 |
} |
|
| 459 |
# information |
|
| 460 | ! |
opt$information[1] <- "observed" |
| 461 | ! |
opt$meanstructure <- TRUE |
| 462 | ! |
if (length(opt$information) > 1L && |
| 463 | ! |
opt$information[2] == "default") {
|
| 464 | ! |
opt$information[2] <- "observed" |
| 465 |
} |
|
| 466 |
# test |
|
| 467 | ! |
opt$test <- "none" |
| 468 |
# link |
|
| 469 | ! |
if (opt$link == "default") {
|
| 470 |
# opt$link <- "logit" |
|
| 471 | ! |
opt$link <- "probit" |
| 472 | ! |
} else if (opt$link %in% c("logit", "probit")) {
|
| 473 |
# nothing to do |
|
| 474 |
} else {
|
|
| 475 | ! |
lav_msg_stop(gettext("link must be `logit' or `probit'"))
|
| 476 |
} |
|
| 477 |
# parameterization |
|
| 478 | ! |
if (opt$parameterization == "default") {
|
| 479 | ! |
opt$parameterization <- "mml" |
| 480 |
} else {
|
|
| 481 | ! |
lav_msg_stop(gettext( |
| 482 | ! |
"parameterization argument is ignored if estimator = MML")) |
| 483 |
} |
|
| 484 | ! |
opt |
| 485 |
} |
|
| 486 | ||
| 487 |
lav_options_est_fabin <- function(opt) {
|
|
| 488 |
# FABIN, MULTIPLE-GROUP-METHOD (MGM), BENTLER1982, ... #### |
|
| 489 |
# experimental, for cfa or sam only |
|
| 490 |
# se |
|
| 491 | ! |
if (opt$se == "default") {
|
| 492 | ! |
opt$se <- "none" |
| 493 |
} |
|
| 494 |
# bounds |
|
| 495 | ! |
if (!is.null(opt$bounds) && opt$bounds == "default" && |
| 496 | ! |
length(opt$optim.bounds) == 0L) {
|
| 497 | ! |
opt$bounds <- "standard" |
| 498 |
} |
|
| 499 |
# test |
|
| 500 | ! |
if (opt$test == "default") {
|
| 501 | ! |
opt$test <- "none" # for now |
| 502 |
} |
|
| 503 |
# missing |
|
| 504 | ! |
opt$missing <- "listwise" # for now (until we have two-stage working) |
| 505 |
# options for fabin |
|
| 506 | ! |
if (lav_options_estimatorgroup(opt$estimator) %in% c("FABIN2", "FABIN3")) {
|
| 507 | ! |
if (is.null(opt$estimator.args)) {
|
| 508 | ! |
opt$estimator.args <- list(thetapsi.method = "GLS") |
| 509 |
} else {
|
|
| 510 | ! |
if (is.null(opt$estimator.args$thetapsi.method)) {
|
| 511 | ! |
opt$estimator.args$thetapsi.method <- "GLS" |
| 512 |
} else {
|
|
| 513 | ! |
opt$estimator.args$thetapsi.method <- |
| 514 | ! |
toupper(opt$estimator.args$thetapsi.method) |
| 515 | ! |
if (opt$estimator.args$thetapsi.method %in% c( |
| 516 | ! |
"ULS", |
| 517 | ! |
"GLS", "WLS", "ULS.ML", "GLS.ML", "WLS.ML" |
| 518 |
)) {
|
|
| 519 | ! |
if (opt$estimator.args$thetapsi.method == "WLS") {
|
| 520 | ! |
opt$estimator.args$thetapsi.method <- "GLS" |
| 521 |
} |
|
| 522 | ! |
if (opt$estimator.args$thetapsi.method == "WLS.ML") {
|
| 523 | ! |
opt$estimator.args$thetapsi.method <- "GLS.ML" |
| 524 |
} |
|
| 525 |
} else {
|
|
| 526 | ! |
lav_msg_stop(gettextf( |
| 527 | ! |
"unknown value for estimator.args$thetapsi.method option: %s.", |
| 528 | ! |
opt$estimator.args$thetapsi.method)) |
| 529 |
} |
|
| 530 |
} |
|
| 531 |
} |
|
| 532 |
} |
|
| 533 |
# options for Bentler |
|
| 534 | ! |
if (lav_options_estimatorgroup(opt$estimator) == "BENTLER1982") {
|
| 535 | ! |
if (is.null(opt$estimator.args)) {
|
| 536 | ! |
opt$estimator.args <- list(GLS = FALSE, quadprog = FALSE) |
| 537 |
} else {
|
|
| 538 | ! |
if (is.null(opt$estimator.args$GLS)) {
|
| 539 | ! |
opt$estimator.args$GLS <- FALSE |
| 540 |
} |
|
| 541 | ! |
if (is.null(opt$estimator.args$quadprog)) {
|
| 542 | ! |
opt$estimator.args$quadprog <- FALSE |
| 543 |
} |
|
| 544 |
} |
|
| 545 |
} |
|
| 546 |
# options for guttman1952 multiple group method |
|
| 547 | ! |
if (lav_options_estimatorgroup(opt$estimator) == "MGM") {
|
| 548 | ! |
if (is.null(opt$estimator.args)) {
|
| 549 | ! |
opt$estimator.args <- list( |
| 550 | ! |
zero.after.efa = TRUE, |
| 551 | ! |
psi.mapping = FALSE, |
| 552 | ! |
quadprog = FALSE |
| 553 |
) |
|
| 554 |
} else {
|
|
| 555 | ! |
if (is.null(opt$estimator.args$zero.after.efa)) {
|
| 556 | ! |
opt$estimator.args$zero.after.efa <- TRUE |
| 557 |
} |
|
| 558 | ! |
if (is.null(opt$estimator.args$psi.mapping)) {
|
| 559 | ! |
opt$estimator.args$psi.mapping <- FALSE |
| 560 |
} |
|
| 561 | ! |
if (is.null(opt$estimator.args$quadprog)) {
|
| 562 | ! |
opt$estimator.args$quadprog <- FALSE |
| 563 |
} |
|
| 564 |
} |
|
| 565 |
} |
|
| 566 |
# brute-force override |
|
| 567 | ! |
opt$optim.method <- "noniter" |
| 568 | ! |
opt$start <- "simple" |
| 569 | ! |
opt |
| 570 |
} |
|
| 571 | ||
| 572 |
lav_options_est_iv <- function(opt) {
|
|
| 573 |
# (MI)IV-2SLS and friends #### |
|
| 574 | ||
| 575 |
# brute-force override |
|
| 576 | ! |
opt$optim.method <- "noniter" |
| 577 | ! |
opt$marker.int.zero <- TRUE |
| 578 | ||
| 579 |
# se |
|
| 580 | ! |
if (opt$se == "default") {
|
| 581 | ! |
opt$se <- "standard" # for now |
| 582 |
} |
|
| 583 |
# bounds |
|
| 584 | ! |
if (!is.null(opt$bounds) && opt$bounds == "default" && |
| 585 | ! |
length(opt$optim.bounds) == 0L) {
|
| 586 | ! |
opt$bounds <- "standard" |
| 587 |
} |
|
| 588 |
# test |
|
| 589 | ! |
if (opt$test == "default") {
|
| 590 | ! |
opt$test <- "browne.residual.nt" # sample-based (especially for baseline) |
| 591 |
} |
|
| 592 | ! |
opt$standard.test <- opt$test |
| 593 | ||
| 594 |
# missing |
|
| 595 | ! |
opt$missing <- "listwise" # for now |
| 596 | ||
| 597 |
# estimator options |
|
| 598 | ! |
if (is.null(opt$estimator.args)) {
|
| 599 |
# create default list |
|
| 600 | ! |
opt$estimator.args <- list(iv.method = "2SLS", |
| 601 | ! |
iv.samplestats = FALSE, |
| 602 | ! |
iv.varcov.method = "RLS", |
| 603 | ! |
iv.varcov.se = TRUE, |
| 604 | ! |
iv.varcov.modelbased = TRUE) |
| 605 |
} else {
|
|
| 606 | ! |
if (is.null(opt$estimator.args$iv.method)) {
|
| 607 | ! |
opt$estimator.args$iv.method <- "2SLS" |
| 608 | ! |
} else if (!opt$estimator.args$iv.method %in% "2SLS") {
|
| 609 | ! |
lav_msg_stop(gettext("iv.method should be 2SLS (for now)."))
|
| 610 |
} |
|
| 611 | ! |
if (is.null(opt$estimator.args$iv.samplestats)) {
|
| 612 | ! |
opt$estimator.args$iv.samplestats <- FALSE |
| 613 |
} |
|
| 614 | ! |
if (opt$.categorical) {
|
| 615 | ! |
opt$estimator.args$iv.samplestats <- TRUE |
| 616 |
} |
|
| 617 | ! |
if (is.null(opt$estimator.args$iv.varcov.method)) {
|
| 618 | ! |
opt$estimator.args$iv.varcov.method <- "RLS" |
| 619 | ! |
} else if (!opt$estimator.args$iv.varcov.method %in% |
| 620 | ! |
c("ULS", "GLS", "2RLS", "RLS")) {
|
| 621 | ! |
lav_msg_stop(gettext("iv.varcov.method should ULS, GLS, 2RLS or RLS."))
|
| 622 |
} |
|
| 623 | ! |
if (is.null(opt$estimator.args$iv.varcov.se)) {
|
| 624 | ! |
opt$estimator.args$iv.varcov.se <- TRUE |
| 625 |
} |
|
| 626 | ! |
if (is.null(opt$estimator.args$iv.varcov.modelbased)) {
|
| 627 | ! |
opt$estimator.args$iv.varcov.modelbased <- TRUE |
| 628 |
} |
|
| 629 |
} |
|
| 630 | ||
| 631 | ! |
opt |
| 632 |
} |
|
| 633 | ||
| 634 |
lav_options_est_none <- function(opt) {
|
|
| 635 |
# NONE #### |
|
| 636 |
# se |
|
| 637 | ! |
if (opt$se == "default") {
|
| 638 | ! |
opt$se <- "none" |
| 639 |
} |
|
| 640 |
# test |
|
| 641 | ! |
if (opt$test[1] == "default") {
|
| 642 | ! |
opt$test <- "none" |
| 643 |
} |
|
| 644 | ! |
opt |
| 645 |
} |
| 1 |
lav_model_gradient_mml <- function(lavmodel = NULL, |
|
| 2 |
THETA = NULL, |
|
| 3 |
TH = NULL, |
|
| 4 |
GLIST = NULL, |
|
| 5 |
group = 1L, |
|
| 6 |
lavdata = NULL, |
|
| 7 |
sample.mean = NULL, |
|
| 8 |
sample.mean.x = NULL, |
|
| 9 |
lavcache = NULL) {
|
|
| 10 | ! |
if (lavmodel@link == "logit") {
|
| 11 | ! |
lav_msg_stop(gettext("logit link not implemented yet; use probit"))
|
| 12 |
} |
|
| 13 | ||
| 14 |
# shortcut |
|
| 15 | ! |
ov.y.dummy.ov.idx <- lavmodel@ov.y.dummy.ov.idx[[group]] |
| 16 | ! |
ov.x.dummy.ov.idx <- lavmodel@ov.x.dummy.ov.idx[[group]] |
| 17 | ! |
ov.y.dummy.lv.idx <- lavmodel@ov.y.dummy.lv.idx[[group]] |
| 18 | ! |
ov.x.dummy.lv.idx <- lavmodel@ov.x.dummy.lv.idx[[group]] |
| 19 | ! |
ov.dummy.idx <- c(ov.y.dummy.ov.idx, ov.x.dummy.ov.idx) |
| 20 | ! |
lv.dummy.idx <- c(ov.y.dummy.lv.idx, ov.x.dummy.lv.idx) |
| 21 | ! |
th.idx <- lavmodel@th.idx[[group]] |
| 22 | ! |
num.idx <- lavmodel@num.idx[[group]] |
| 23 | ! |
ord.idx <- unique(th.idx[th.idx > 0L]) |
| 24 | ||
| 25 | ||
| 26 |
# data for this group |
|
| 27 | ! |
X <- lavdata@X[[group]] |
| 28 | ! |
nobs <- nrow(X) |
| 29 | ! |
nvar <- ncol(X) |
| 30 | ! |
eXo <- lavdata@eXo[[group]] |
| 31 | ||
| 32 |
# MLIST (for veta and yhat) |
|
| 33 | ! |
mm.in.group <- 1:lavmodel@nmat[group] + cumsum(c(0, lavmodel@nmat))[group] |
| 34 | ! |
MLIST <- GLIST[mm.in.group] |
| 35 | ||
| 36 |
# quadrature points |
|
| 37 | ! |
GH <- lavcache[[group]]$GH |
| 38 | ! |
nGH <- nrow(GH$x) |
| 39 | ! |
nfac <- ncol(GH$x) |
| 40 | ||
| 41 |
# compute VETAx (latent lv only) |
|
| 42 |
# VETAx <- lav_lisrel_vetax(MLIST = MLIST, lv.dummy.idx = lv.dummy.idx) |
|
| 43 | ! |
VETAx <- lav_lisrel_vetax(MLIST = MLIST) |
| 44 |
# check for negative values? |
|
| 45 | ! |
if (any(diag(VETAx) < 0)) {
|
| 46 | ! |
lav_msg_warn(gettext("--- VETAx contains negative values"))
|
| 47 | ! |
print(VETAx) |
| 48 | ! |
return(0) |
| 49 |
} |
|
| 50 | ||
| 51 |
# cholesky? |
|
| 52 |
# if(is.null(lavmodel@control$cholesky)) {
|
|
| 53 | ! |
CHOLESKY <- TRUE |
| 54 |
# } else {
|
|
| 55 |
# CHOLESKY <- as.logical(lavmodel@control$cholesky) |
|
| 56 |
# if(nfac > 1L && !CHOLESKY) {
|
|
| 57 |
# warning("lavaan WARNING: CHOLESKY is OFF but nfac > 1L")
|
|
| 58 |
# } |
|
| 59 |
# } |
|
| 60 | ||
| 61 | ! |
if (!CHOLESKY) {
|
| 62 |
# we should still 'scale' the factors, if std.lv=FALSE |
|
| 63 | ! |
ETA.sd <- sqrt(diag(VETAx)) |
| 64 |
} else {
|
|
| 65 |
# cholesky takes care of scaling |
|
| 66 | ! |
ETA.sd <- rep(1, nfac) |
| 67 | ! |
tchol.VETA <- try(chol(VETAx), silent = TRUE) |
| 68 | ! |
if (inherits(tchol.VETA, "try-error")) {
|
| 69 | ! |
lav_msg_warn(gettext("--- VETAx not positive definite"))
|
| 70 | ! |
print(VETAx) |
| 71 | ! |
return(0) |
| 72 |
} |
|
| 73 | ! |
if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
|
| 74 | ! |
EETAx <- lav_lisrel_eetax( |
| 75 | ! |
MLIST = MLIST, eXo = eXo, N = nobs, |
| 76 | ! |
sample.mean = sample.mean, |
| 77 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 78 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 79 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 80 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 81 |
) |
|
| 82 |
# if(length(lv.dummy.idx) > 0L) {
|
|
| 83 |
# EETAx <- EETAx[,-lv.dummy.idx,drop=FALSE] |
|
| 84 |
# } |
|
| 85 |
} |
|
| 86 |
} |
|
| 87 | ||
| 88 |
# prepare common stuff |
|
| 89 |
# fix Lambda? |
|
| 90 | ! |
LAMBDA <- lav_lisrel_lambda( |
| 91 | ! |
MLIST = MLIST, |
| 92 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 93 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 94 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 95 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 96 |
) |
|
| 97 | ||
| 98 |
# fix ALPHA |
|
| 99 | ! |
ALPHA <- MLIST$alpha |
| 100 | ! |
if (is.null(ALPHA)) {
|
| 101 | ! |
ALPHA <- numeric(nfac) |
| 102 | ! |
} else if (length(lv.dummy.idx)) {
|
| 103 | ! |
ALPHA <- ALPHA[-lv.dummy.idx, , drop = FALSE] |
| 104 |
} |
|
| 105 | ||
| 106 |
# Beta? |
|
| 107 | ! |
BETA <- MLIST$beta |
| 108 | ! |
if (is.null(BETA)) {
|
| 109 | ! |
LAMBDA..IB.inv <- LAMBDA |
| 110 |
} else {
|
|
| 111 | ! |
tmp <- -BETA |
| 112 | ! |
nr <- nrow(BETA) |
| 113 | ! |
i <- seq_len(nr) |
| 114 | ! |
tmp[cbind(i, i)] <- 1 |
| 115 | ! |
IB.inv <- solve(tmp) |
| 116 | ! |
LAMBDA..IB.inv <- MLIST$lambda %*% IB.inv ## no need to FIX??? |
| 117 | ! |
if (length(lv.dummy.idx) > 0L) {
|
| 118 | ! |
LAMBDA..IB.inv <- LAMBDA..IB.inv[, -lv.dummy.idx, drop = FALSE] |
| 119 |
} |
|
| 120 | ||
| 121 |
# fix BETA |
|
| 122 | ! |
if (length(lv.dummy.idx)) {
|
| 123 | ! |
BETA <- MLIST$beta[-lv.dummy.idx, -lv.dummy.idx, drop = FALSE] |
| 124 |
} |
|
| 125 | ! |
tmp <- -BETA |
| 126 | ! |
nr <- nrow(BETA) |
| 127 | ! |
i <- seq_len(nr) |
| 128 | ! |
tmp[cbind(i, i)] <- 1 |
| 129 | ! |
IB.inv <- solve(tmp) |
| 130 |
} |
|
| 131 | ||
| 132 |
# fix GAMMA |
|
| 133 | ! |
GAMMA <- MLIST$gamma |
| 134 | ! |
if (is.null(GAMMA)) {
|
| 135 | ! |
ALPHA.GAMMA.eXo <- matrix(as.numeric(ALPHA), nobs, nfac, byrow = TRUE) |
| 136 | ! |
} else if (length(lv.dummy.idx)) {
|
| 137 | ! |
GAMMA <- GAMMA[-lv.dummy.idx, , drop = FALSE] |
| 138 | ! |
ALPHA.GAMMA.eXo <- sweep(eXo %*% t(GAMMA), |
| 139 | ! |
MARGIN = 2, STATS = as.numeric(ALPHA), FUN = "+" |
| 140 |
) |
|
| 141 |
} |
|
| 142 | ||
| 143 |
# Delta |
|
| 144 |
## DD <- lavcache[[group]]$DD |
|
| 145 | ! |
DD <- lav_model_gradient_DD(lavmodel, GLIST = GLIST, group = group) |
| 146 | ||
| 147 |
## FIXME!!! do this analytically... |
|
| 148 | ! |
x <- lav_model_get_parameters(lavmodel = lavmodel, GLIST = MLIST) |
| 149 | ! |
dVetadx <- function(x, lavmodel = lavmodel, g = 1L) {
|
| 150 | ! |
GLIST <- lav_model_x2glist(lavmodel, x = x, type = "free") |
| 151 | ! |
VETAx <- lav_model_vetax(lavmodel, GLIST = GLIST)[[g]] |
| 152 | ! |
if (CHOLESKY) {
|
| 153 | ! |
S <- chol(VETAx) ### FIXME or t(chol())???? |
| 154 |
} else {
|
|
| 155 | ! |
S <- diag(sqrt(diag(VETAx))) |
| 156 |
} |
|
| 157 | ! |
S |
| 158 |
} |
|
| 159 | ! |
Delta.S <- lav_func_jacobian_simple(func = dVetadx, x = x, lavmodel = lavmodel, g = group) |
| 160 | ! |
DD$S <- Delta.S |
| 161 | ||
| 162 |
# compute dL/dx for each node |
|
| 163 |
# dLdx <- matrix(0, nGH, lavmodel@nx.free) |
|
| 164 | ! |
dFYp <- matrix(0, nobs, lavmodel@nx.free) |
| 165 | ! |
SUM.LOG.FY <- matrix(0, nrow = nGH, ncol = nobs) |
| 166 | ! |
for (q in 1:nGH) {
|
| 167 |
# contribution to dFYp for this q |
|
| 168 | ! |
dFYp.q <- matrix(0, nobs, lavmodel@nx.free) |
| 169 | ||
| 170 |
# current value(s) for ETA |
|
| 171 | ! |
eta <- ksi <- GH$x[q, , drop = FALSE] |
| 172 | ||
| 173 |
# rescale/unwhiten |
|
| 174 | ! |
if (CHOLESKY) {
|
| 175 | ! |
eta <- eta %*% tchol.VETA |
| 176 |
} else {
|
|
| 177 |
# no unit scale? (un-standardize) |
|
| 178 | ! |
eta <- sweep(eta, MARGIN = 2, STATS = ETA.sd, FUN = "*") |
| 179 |
} |
|
| 180 | ||
| 181 |
# eta_i = alpha + BETA eta_i + GAMMA eta_i + error |
|
| 182 |
# |
|
| 183 |
# - direct effect of BETA is already in VETAx, and hence tchol.VETA |
|
| 184 |
# - need to add alpha, and GAMMA eta_i |
|
| 185 | ! |
if (!is.null(MLIST$alpha) || !is.null(MLIST$gamma)) {
|
| 186 | ! |
eta <- sweep(EETAx, MARGIN = 2, STATS = eta, FUN = "+") |
| 187 |
} |
|
| 188 | ||
| 189 |
# again, compute yhat for this node (eta) |
|
| 190 | ! |
if (lavmodel@conditional.x) {
|
| 191 | ! |
yhat <- lav_lisrel_eyetax( |
| 192 | ! |
MLIST = MLIST, eXo = eXo, |
| 193 | ! |
ETA = eta, sample.mean = sample.mean, |
| 194 | ! |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 195 | ! |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 196 | ! |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 197 | ! |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx |
| 198 |
) |
|
| 199 |
} else {
|
|
| 200 | ! |
yhat <- lav_lisrel_eyetax3( |
| 201 | ! |
MLIST = MLIST, |
| 202 | ! |
ETA = eta, sample.mean = sample.mean, |
| 203 | ! |
mean.x = sample.mean.x, |
| 204 | ! |
ov.y.dummy.ov.idx = lavmodel@ov.y.dummy.ov.idx[[group]], |
| 205 | ! |
ov.x.dummy.ov.idx = lavmodel@ov.x.dummy.ov.idx[[group]], |
| 206 | ! |
ov.y.dummy.lv.idx = lavmodel@ov.y.dummy.lv.idx[[group]], |
| 207 | ! |
ov.x.dummy.lv.idx = lavmodel@ov.x.dummy.lv.idx[[group]] |
| 208 |
) |
|
| 209 |
} |
|
| 210 | ||
| 211 |
# compute fy.var, for this node (eta): P(Y_i = y_i | eta_i, x_i) |
|
| 212 | ! |
log.fy.var <- lav_predict_fy_internal( |
| 213 | ! |
X = X, yhat = yhat, |
| 214 | ! |
TH = TH, THETA = THETA, |
| 215 | ! |
num.idx = num.idx, th.idx = th.idx, |
| 216 | ! |
link = lavmodel@link, log. = TRUE |
| 217 |
) |
|
| 218 | ||
| 219 |
# if log, fy is just the sum of log.fy.var |
|
| 220 | ! |
log.fy <- apply(log.fy.var, 1L, sum) |
| 221 | ||
| 222 |
# store log likelihoods for this node |
|
| 223 | ! |
SUM.LOG.FY[q, ] <- log.fy |
| 224 | ||
| 225 |
# FY |
|
| 226 | ! |
FY <- exp(log.fy.var) ### FIXME log/exp/log/... |
| 227 | ! |
LIK.eta <- apply(FY, 1, prod) |
| 228 |
# fyp <- LIK.eta * GH$w[q] |
|
| 229 | ||
| 230 |
######### dFY_p ########################################### |
|
| 231 |
# note, dFYp is actually 1/FY[,p] * dFYp |
|
| 232 | ||
| 233 | ! |
PRE <- matrix(0, nobs, nvar) |
| 234 | ! |
if (length(num.idx) > 0L) {
|
| 235 | ! |
tmp <- X[, num.idx, drop = FALSE] - yhat[, num.idx, drop = FALSE] |
| 236 | ! |
theta.var <- diag(THETA)[num.idx] |
| 237 | ! |
PRE[, num.idx] <- sweep(tmp, MARGIN = 2, STATS = 1 / theta.var, FUN = "*") |
| 238 |
} |
|
| 239 | ||
| 240 | ! |
if (length(ord.idx) > 0L) {
|
| 241 | ! |
for (p in ord.idx) {
|
| 242 |
# just in case we need theta[v,v] after all... |
|
| 243 | ! |
sd.v.inv <- 1 / sqrt(THETA[p, p]) |
| 244 | ||
| 245 |
# lav_probit |
|
| 246 | ! |
y <- X[, p] |
| 247 | ! |
th.y <- TH[th.idx == p] |
| 248 | ! |
TH.Y <- c(-Inf, th.y, Inf) |
| 249 | ! |
ncat <- length(th.y) + 1L |
| 250 | ! |
nth <- ncat - 1L |
| 251 | ! |
Y1 <- matrix(1:nth, nobs, nth, byrow = TRUE) == y |
| 252 | ! |
Y2 <- matrix(1:nth, nobs, nth, byrow = TRUE) == (y - 1L) |
| 253 | ! |
z1 <- pmin(100, TH.Y[y + 1L] - yhat[, p]) |
| 254 | ! |
z2 <- pmax(-100, TH.Y[y + 1L - 1L] - yhat[, p]) |
| 255 | ! |
p1 <- dnorm(z1) |
| 256 | ! |
p2 <- dnorm(z2) |
| 257 |
# probits = p1 - p2 |
|
| 258 | ||
| 259 | ! |
PRE[, p] <- -1 * (p1 - p2) * sd.v.inv * (1 / FY[, p]) |
| 260 | ||
| 261 |
# [nobx * n.th] |
|
| 262 |
# dth <- -1 * (Y2*p2 - Y1*p1) * sd.v.inv |
|
| 263 | ! |
dth <- -1 * (Y2 * p2 - Y1 * p1) * sd.v.inv * (1 / FY[, p]) |
| 264 | ! |
dFYp.q <- dFYp.q + |
| 265 | ! |
(dth %*% DD$tau[which(th.idx == p), , drop = FALSE]) |
| 266 |
} |
|
| 267 |
} |
|
| 268 | ||
| 269 | ! |
if (length(num.idx) > 0L) {
|
| 270 |
# THETA (num only) |
|
| 271 | ! |
dsigma2 <- sweep(0.5 * PRE[, num.idx] * PRE[, num.idx], |
| 272 | ! |
MARGIN = 2, |
| 273 | ! |
STATS = 1 / (2 * theta.var), FUN = "-" |
| 274 |
) |
|
| 275 | ! |
dFYp.q <- dFYp.q + (dsigma2 %*% DD$theta) |
| 276 | ||
| 277 |
# NU (num only) |
|
| 278 | ! |
dnu <- PRE[, num.idx] |
| 279 | ! |
dFYp.q <- dFYp.q + (dnu %*% DD$nu) |
| 280 |
} |
|
| 281 | ||
| 282 |
# LAMBDA |
|
| 283 | ! |
if (nrow(eta) == 1L) {
|
| 284 | ! |
dlambda <- PRE %*% eta |
| 285 |
### FIXME!!!!! |
|
| 286 |
} else {
|
|
| 287 | ! |
dlambda <- matrix(apply(PRE, 2, function(x) x * eta), nobs, ) |
| 288 |
# dlambda <- sweep(PRE, MARGIN=1, STATS=eta, FUN="*") |
|
| 289 |
} |
|
| 290 | ! |
dFYp.q <- dFYp.q + (dlambda %*% DD$lambda) |
| 291 | ||
| 292 |
# PSI |
|
| 293 |
# if(nrow(ksi) == 1L) {
|
|
| 294 | ! |
dpsi <- PRE %*% kronecker(LAMBDA[, , drop = FALSE], ksi) |
| 295 |
# } else {
|
|
| 296 |
# dpsi <- PRE * kronecker(LAMBDA[,,drop=FALSE], ksi) |
|
| 297 |
# } |
|
| 298 | ! |
dFYp.q <- dFYp.q + (dpsi %*% DD$S) |
| 299 | ||
| 300 |
# KAPPA |
|
| 301 | ! |
if (length(ov.y.dummy.ov.idx) > 0L) {
|
| 302 | ! |
dkappa <- matrix(apply( |
| 303 | ! |
PRE[, ov.y.dummy.ov.idx, drop = FALSE], 2, |
| 304 | ! |
function(x) x * eXo |
| 305 | ! |
), nobs, ) |
| 306 | ! |
dFYp.q <- dFYp.q + (dkappa %*% DD$kappa) |
| 307 |
} |
|
| 308 | ||
| 309 |
# GAMMA |
|
| 310 | ! |
if (!is.null(eXo)) {
|
| 311 | ! |
dgamma <- matrix(apply( |
| 312 | ! |
PRE %*% LAMBDA..IB.inv, 2, |
| 313 | ! |
function(x) x * eXo |
| 314 | ! |
), nobs, ) |
| 315 | ! |
dFYp.q <- dFYp.q + (dgamma %*% DD$gamma) |
| 316 |
} |
|
| 317 | ||
| 318 |
# BETA |
|
| 319 | ! |
if (!is.null(BETA)) {
|
| 320 |
# tmp <- kronecker(LAMBDA, ALPHA.GAMMA.eXo) %*% |
|
| 321 |
# t( kronecker(t(IB.inv), IB.inv) ) |
|
| 322 |
# dbeta <- apply(matrix(as.numeric(PRE) * tmp, nobs, ), 1, sum) |
|
| 323 | ! |
dbeta <- matrix(apply( |
| 324 | ! |
PRE %*% LAMBDA..IB.inv, 2, |
| 325 | ! |
function(x) x * ALPHA.GAMMA.eXo |
| 326 | ! |
), nobs, ) |
| 327 | ! |
dFYp.q <- dFYp.q + (dbeta %*% DD$beta) |
| 328 |
} |
|
| 329 | ||
| 330 | ! |
dFYp <- dFYp + ((LIK.eta * GH$w[q]) * dFYp.q) |
| 331 |
} |
|
| 332 | ||
| 333 | ! |
lik <- as.numeric(t(GH$w) %*% exp(SUM.LOG.FY)) |
| 334 |
# avoid underflow |
|
| 335 | ! |
idx <- which(lik < exp(-600)) |
| 336 | ! |
if (length(idx) > 0L) {
|
| 337 | ! |
lik[idx] <- exp(-600) |
| 338 |
} |
|
| 339 | ||
| 340 | ! |
dFYp <- 1 / lik * dFYp |
| 341 | ||
| 342 | ! |
dx <- apply(dFYp, 2, sum) |
| 343 | ||
| 344 |
# integration |
|
| 345 |
# dx <- apply(as.numeric(GH$w) * dLdx, 2, sum) |
|
| 346 | ||
| 347 |
# minimize |
|
| 348 | ! |
dx <- -1 * dx |
| 349 | ||
| 350 | ! |
dx |
| 351 |
} |
| 1 |
# Albert (1944a/b) & Ihara & Kano 1986 method to estimate residual variances |
|
| 2 |
# of indicators using a PArtitioned Covariance matrix Estimator (PACE) |
|
| 3 |
# |
|
| 4 |
# The implementation is based on Cudeck 1991: |
|
| 5 | ||
| 6 |
# Cudeck, R. (1991). Noniterative factor analysis estimators, with algorithms |
|
| 7 |
# for subset and instrumental variable selection. Journal of Educational |
|
| 8 |
# Statistics, 16(1), 35-52. |
|
| 9 | ||
| 10 |
# YR -- 14 FEB 2020 |
|
| 11 | ||
| 12 |
# - 'fast' version; only (2*nfactors + 1) iterations are needed |
|
| 13 |
# - scale-invariant (by default) |
|
| 14 |
# - always assuming unit variances for the factors |
|
| 15 |
lav_efa_pace <- function(S, nfactors = 1L, p.idx = seq_len(ncol(S)), |
|
| 16 |
reflect = TRUE, order.lv.by = "none", |
|
| 17 |
use.R = TRUE, theta.only = TRUE) {
|
|
| 18 | ! |
S <- unname(S) |
| 19 | ! |
nvar <- ncol(S) |
| 20 | ! |
theta <- numeric(nvar) |
| 21 | ! |
stopifnot(nfactors < nvar / 2) |
| 22 | ||
| 23 |
# because subset selection is not scale-invariant, we transform |
|
| 24 |
# S to R, compute theta based on R, and then rescale again |
|
| 25 | ! |
if (use.R) {
|
| 26 | ! |
s.var <- diag(S) |
| 27 | ! |
R <- stats::cov2cor(S) |
| 28 |
} else {
|
|
| 29 | ! |
R <- S |
| 30 |
} |
|
| 31 | ||
| 32 |
# find principal variables ('largest' sub-block)
|
|
| 33 | ! |
A <- R |
| 34 | ||
| 35 |
# row indices |
|
| 36 | ! |
v.r <- integer(0L) |
| 37 |
# column indices |
|
| 38 | ! |
v.c <- integer(0L) |
| 39 | ||
| 40 | ! |
for (h in seq_len(nfactors)) {
|
| 41 |
# mask |
|
| 42 | ! |
mask.idx <- c(v.r, v.c) |
| 43 | ! |
tmp <- abs(A) |
| 44 | ! |
if (length(mask.idx) > 0L) {
|
| 45 | ! |
tmp[mask.idx, ] <- 0 |
| 46 | ! |
tmp[, mask.idx] <- 0 |
| 47 |
} |
|
| 48 | ! |
diag(tmp) <- 0 |
| 49 | ||
| 50 |
# find maximum off-diagonal element |
|
| 51 | ! |
idx <- which(tmp == max(tmp), arr.ind = TRUE, useNames = FALSE)[1, ] |
| 52 | ! |
k <- idx[1] |
| 53 | ! |
l <- idx[2] |
| 54 | ! |
v.r <- c(v.r, k) |
| 55 | ! |
v.c <- c(v.c, l) |
| 56 | ||
| 57 |
# non-symmetric sweep operator |
|
| 58 | ! |
a.kl <- A[k, l] |
| 59 | ! |
if (abs(a.kl) < sqrt(.Machine$double.eps)) {
|
| 60 | ! |
out <- A |
| 61 | ! |
out[k, ] <- 0 |
| 62 | ! |
out[, l] <- 0 |
| 63 |
} else {
|
|
| 64 | ! |
out <- A - tcrossprod(A[, l], A[k, ]) / a.kl |
| 65 | ! |
out[k, ] <- A[k, ] / a.kl |
| 66 | ! |
out[, l] <- -A[, l] / a.kl |
| 67 | ! |
out[k, l] <- 1 / a.kl |
| 68 |
} |
|
| 69 | ! |
A <- out |
| 70 |
} |
|
| 71 |
# diagonal elements are estimates of theta |
|
| 72 |
# for all variables not in (v.r, v.c) |
|
| 73 | ! |
all.idx <- seq_len(nvar) |
| 74 | ! |
v.r.init <- v.r |
| 75 | ! |
v.c.init <- v.c |
| 76 | ! |
other.idx <- all.idx[-c(v.r, v.c)] |
| 77 | ! |
theta[other.idx] <- diag(A)[other.idx] |
| 78 | ||
| 79 | ||
| 80 |
# now fill in theta for the 2*m remaining variables in c(v.r.init, v.c.init) |
|
| 81 | ! |
for (i in p.idx) {
|
| 82 | ! |
if (i %in% other.idx) {
|
| 83 | ! |
next |
| 84 |
} |
|
| 85 | ||
| 86 |
# row indices |
|
| 87 | ! |
v.r <- integer(0L) |
| 88 |
# column indices |
|
| 89 | ! |
v.c <- integer(0L) |
| 90 | ||
| 91 | ! |
A <- R |
| 92 | ! |
for (h in seq_len(nfactors)) {
|
| 93 |
# mask |
|
| 94 | ! |
mask.idx <- c(i, v.r, v.c) |
| 95 | ! |
tmp <- abs(A) |
| 96 | ! |
tmp[mask.idx, ] <- 0 |
| 97 | ! |
tmp[, mask.idx] <- 0 |
| 98 | ! |
diag(tmp) <- 0 |
| 99 | ||
| 100 |
# find maximum off-diagonal element |
|
| 101 | ! |
idx <- which(tmp == max(tmp), arr.ind = TRUE, useNames = FALSE)[1, ] |
| 102 | ! |
k <- idx[1] |
| 103 | ! |
l <- idx[2] |
| 104 | ! |
v.r <- c(v.r, k) |
| 105 | ! |
v.c <- c(v.c, l) |
| 106 | ||
| 107 |
# non-symmetric sweep operator |
|
| 108 | ! |
a.kl <- A[k, l] |
| 109 | ! |
if (abs(a.kl) < sqrt(.Machine$double.eps)) {
|
| 110 | ! |
out <- A |
| 111 | ! |
out[k, ] <- 0 |
| 112 | ! |
out[, l] <- 0 |
| 113 |
} else {
|
|
| 114 | ! |
out <- A - tcrossprod(A[, l], A[k, ]) / a.kl |
| 115 | ! |
out[k, ] <- A[k, ] / a.kl |
| 116 | ! |
out[, l] <- -A[, l] / a.kl |
| 117 | ! |
out[k, l] <- 1 / a.kl |
| 118 |
} |
|
| 119 | ! |
A <- out |
| 120 |
} |
|
| 121 | ||
| 122 |
# diagonal element is estimate of theta |
|
| 123 | ! |
theta[i] <- A[i, i] |
| 124 |
} |
|
| 125 | ||
| 126 |
# return theta elements only |
|
| 127 | ! |
if (theta.only) {
|
| 128 |
# rescale back to S metric |
|
| 129 | ! |
if (use.R) {
|
| 130 | ! |
theta <- theta * s.var |
| 131 |
} |
|
| 132 | ! |
return(theta[p.idx]) |
| 133 |
} |
|
| 134 | ||
| 135 |
# compute LAMBDA using the 'eigenvalue' method |
|
| 136 | ! |
EV <- eigen(R, symmetric = TRUE) |
| 137 | ! |
S.sqrt <- EV$vectors %*% sqrt(diag(EV$values)) %*% t(EV$vectors) |
| 138 | ! |
S.inv.sqrt <- EV$vectors %*% sqrt(diag(1 / EV$values)) %*% t(EV$vectors) |
| 139 | ! |
RTR <- S.inv.sqrt %*% diag(theta) %*% S.inv.sqrt |
| 140 | ||
| 141 | ! |
EV <- eigen(RTR, symmetric = TRUE) |
| 142 | ! |
Omega.m <- EV$vectors[, 1L + nvar - seq_len(nfactors), drop = FALSE] |
| 143 | ! |
gamma.m <- EV$values[1L + nvar - seq_len(nfactors)] |
| 144 | ! |
Gamma.m <- diag(gamma.m, nrow = nfactors, ncol = nfactors) |
| 145 | ||
| 146 |
# Cuceck 1991 page 37 bottom of the page: |
|
| 147 | ! |
LAMBDA.dot <- S.sqrt %*% Omega.m %*% sqrt(diag(nfactors) - Gamma.m) |
| 148 | ||
| 149 | ! |
if (use.R) {
|
| 150 |
# IF (and only if) the input is a correlation matrix, |
|
| 151 |
# we must rescale so that the diag(R.implied) == 1 |
|
| 152 | ||
| 153 |
# R.unscaled <- tcrossprod(LAMBDA.dot) + diag(theta) |
|
| 154 |
# r.var.inv <- 1/diag(R.unscaled) |
|
| 155 | ||
| 156 |
# LAMBDA/THETA in correlation metric |
|
| 157 |
# LAMBDA.R <- sqrt(r.var.inv) * LAMBDA.dot |
|
| 158 |
# THETA.R <- diag(r.var.inv * theta) |
|
| 159 | ||
| 160 |
# convert to 'S' metric |
|
| 161 | ! |
LAMBDA <- sqrt(s.var) * LAMBDA.dot |
| 162 | ! |
THETA <- diag(s.var * theta) |
| 163 |
} else {
|
|
| 164 | ! |
LAMBDA <- LAMBDA.dot |
| 165 | ! |
THETA <- diag(theta) |
| 166 |
} |
|
| 167 | ||
| 168 |
# reflect so that column sum is always positive |
|
| 169 | ! |
if (reflect) {
|
| 170 | ! |
SUM <- colSums(LAMBDA) |
| 171 | ! |
neg.idx <- which(SUM < 0) |
| 172 | ! |
if (length(neg.idx) > 0L) {
|
| 173 | ! |
LAMBDA[, neg.idx] <- -1 * LAMBDA[, neg.idx, drop = FALSE] |
| 174 |
} |
|
| 175 |
} |
|
| 176 | ||
| 177 |
# reorder the columns |
|
| 178 | ! |
if (order.lv.by == "sumofsquares") {
|
| 179 | ! |
L2 <- LAMBDA * LAMBDA |
| 180 | ! |
order.idx <- base::order(colSums(L2), decreasing = TRUE) |
| 181 | ! |
} else if (order.lv.by == "index") {
|
| 182 |
# reorder using Asparouhov & Muthen 2009 criterion (see Appendix D) |
|
| 183 | ! |
max.loading <- apply(abs(LAMBDA), 2, max) |
| 184 |
# 1: per factor, number of the loadings that are at least 0.8 of the |
|
| 185 |
# highest loading of the factor |
|
| 186 |
# 2: mean of the index numbers |
|
| 187 | ! |
average.index <- sapply(seq_len(ncol(LAMBDA)), function(i) {
|
| 188 | ! |
mean(which(abs(LAMBDA[, i]) >= 0.8 * max.loading[i])) |
| 189 |
}) |
|
| 190 |
# order of the factors |
|
| 191 | ! |
order.idx <- base::order(average.index) |
| 192 | ! |
} else if (order.lv.by == "none") {
|
| 193 | ! |
order.idx <- seq_len(ncol(LAMBDA)) |
| 194 |
} else {
|
|
| 195 | ! |
lav_msg_stop(gettext("order must be index, sumofsquares or none"))
|
| 196 |
} |
|
| 197 | ! |
LAMBDA <- LAMBDA[, order.idx, drop = FALSE] |
| 198 | ||
| 199 | ! |
list(LAMBDA = LAMBDA, THETA = THETA) |
| 200 |
} |
| 1 |
lav_beziersq_beziersc <- function(x) {
|
|
| 2 |
# x contains the beziers points P1, P, P2 (P = control) for quadratic beziers |
|
| 3 |
# x is a matrix with 2 rows and 3 columns |
|
| 4 |
# returns rtval which contains P1, C1, C2, P2 so that the cubic beziers |
|
| 5 |
# with control points C1 and C2 is as 'high' as the quadratic one |
|
| 6 |
# rtval is a matrix with 2 rows and 4 columns |
|
| 7 | ! |
matrix(c(x[ , 1L], x[ , 1L] / 3 + 2 * x[ ,2L] / 3, |
| 8 | ! |
x[ , 3L] / 3 + 2 * x[ ,2L] / 3, x [ ,3L]), nrow = 2) |
| 9 |
} |
|
| 10 |
lav_node_coordinates <- function(nodeid, anker, nodes, maxrij) {
|
|
| 11 | ! |
nodenr <- which(nodes$id == nodeid) |
| 12 | ! |
middelpunt <- c(nodes$kolom[nodenr], maxrij - nodes$rij[nodenr]) |
| 13 | ! |
delta <- switch(anker, n = c(0, 0.3), ne = c(0.3, 0.3), e = c(0.3, 0), |
| 14 | ! |
se = c(0.3, -0.3), s = c(0, -0.3), sw = c(-0.3, -0.3), |
| 15 | ! |
w = c(-0.3, 0), nw = c(-0.3, 0.3)) |
| 16 | ! |
middelpunt + delta |
| 17 |
} |
|
| 18 |
lav_plotinfo_tikzcode <- function(plotinfo, |
|
| 19 |
outfile = "", |
|
| 20 |
cex = 1.3, |
|
| 21 |
sloped.labels = TRUE, |
|
| 22 |
standalone = FALSE, |
|
| 23 |
mlovcolors = c("lightgreen", "lightblue"),
|
|
| 24 |
lightness = 1, |
|
| 25 |
italic = TRUE, |
|
| 26 |
auto.subscript = TRUE |
|
| 27 |
) {
|
|
| 28 | ! |
tmpcol <- col2rgb(mlovcolors) |
| 29 | ! |
wovcol <- paste(round(tmpcol[, 1L]/255, 2), collapse = ",") |
| 30 | ! |
bovcol <- paste(round(tmpcol[, 2L]/255, 2), collapse = ",") |
| 31 | ! |
nodenaam <- function(nm, blk) {
|
| 32 | ! |
if (blk > 0L) return(gsub("_", "", paste0("B", blk, nm)))
|
| 33 | ! |
return(gsub("_", "", nm))
|
| 34 |
} |
|
| 35 | ! |
mlrij <- plotinfo$mlrij |
| 36 | ! |
if (is.null(mlrij)) |
| 37 | ! |
lav_msg_stop(gettext( |
| 38 | ! |
"plotinfo hasn't been processed by lav_plotinfo_positions!")) |
| 39 | ! |
nodes <- plotinfo$nodes |
| 40 | ! |
edges <- plotinfo$edges |
| 41 | ! |
if (lightness != 1) {
|
| 42 | ! |
mlrij <- lightness * mlrij |
| 43 | ! |
nodes$kolom <- lightness * nodes$kolom |
| 44 | ! |
nodes$rij <- lightness * nodes$rij |
| 45 | ! |
edges$controlpt.kol <- lightness * edges$controlpt.kol |
| 46 | ! |
edges$controlpt.rij <- lightness * edges$controlpt.rij |
| 47 |
} |
|
| 48 | ! |
if (is.character(outfile)) {
|
| 49 | ! |
zz <- file(outfile, open = "w") |
| 50 | ! |
closezz <- TRUE |
| 51 |
} else {
|
|
| 52 | ! |
zz <- outfile |
| 53 | ! |
closezz <- FALSE |
| 54 |
} |
|
| 55 | ! |
if (standalone) writeLines(c( |
| 56 | ! |
"\\documentclass{article}",
|
| 57 | ! |
"\\usepackage{amsmath, amssymb}",
|
| 58 | ! |
"\\usepackage{amsfonts}",
|
| 59 | ! |
"\\usepackage[utf8]{inputenc}",
|
| 60 | ! |
"\\usepackage[english]{babel}",
|
| 61 | ! |
"\\usepackage{color}",
|
| 62 | ! |
"\\usepackage{tikz}"), zz)
|
| 63 | ! |
commstyle <- paste0("draw, minimum size=", round(6 * cex), "mm")
|
| 64 | ! |
writeLines (c( |
| 65 | ! |
"\\usetikzlibrary {shapes.geometric}",
|
| 66 | ! |
paste0("\\definecolor{wovcol}{rgb}{", wovcol, "}"),
|
| 67 | ! |
paste0("\\definecolor{bovcol}{rgb}{", bovcol, "}"),
|
| 68 | ! |
"\\tikzset{",
|
| 69 | ! |
">=stealth,", |
| 70 | ! |
paste0("x={(", cex, "cm,0cm)}, y={(0cm,", cex, "cm)},"),
|
| 71 | ! |
paste0("lv/.style={circle, ", commstyle, ", thick},"),
|
| 72 | ! |
paste0("varlv/.style={circle, draw, minimum size=", round(4 * cex), "mm, semithick},"),
|
| 73 | ! |
paste0("cv/.style={regular polygon, regular polygon sides=6, ", commstyle, ", thick},"),
|
| 74 | ! |
paste0("ov/.style={rectangle, ", commstyle,", thick},"),
|
| 75 | ! |
paste0("wov/.style={rectangle, rounded corners, fill=wovcol, ", commstyle, ", thick},"),
|
| 76 | ! |
paste0("bov/.style={rectangle, rounded corners, fill=bovcol, ", commstyle, ", thick},"),
|
| 77 | ! |
paste0("const/.style={regular polygon, regular polygon sides=3, ", commstyle, ", thick}"),
|
| 78 | ! |
"}"), zz) |
| 79 | ! |
if (standalone) writeLines("\\begin{document}", zz)
|
| 80 | ! |
writeLines("\\begin{tikzpicture}", zz)
|
| 81 | ! |
maxrij <- max(nodes$rij) |
| 82 | ! |
maxcol <- max(nodes$kolom) |
| 83 | ! |
if (mlrij > 0L) {
|
| 84 | ! |
writeLines(paste("\\draw (0, ", maxrij - mlrij, ") -- (", maxcol, ",", maxrij - mlrij,
|
| 85 | ! |
");", sep = ""), zz) |
| 86 |
} |
|
| 87 | ! |
for (j in seq.int(nrow(nodes))) {
|
| 88 | ! |
xpos <- nodes$kolom[j] |
| 89 | ! |
ypos <- maxrij - nodes$rij[j] |
| 90 | ! |
writeLines(paste( |
| 91 | ! |
"\\node[", nodes$tiepe[j], "] (", nodenaam(nodes$naam[j], nodes$blok[j]),
|
| 92 | ! |
") at (", xpos, ",", ypos, ") {",
|
| 93 | ! |
lav_label_code(nodes$naam[j], italic = italic, |
| 94 | ! |
auto.subscript = auto.subscript)$tikz, "};", sep = ""), zz) |
| 95 |
} |
|
| 96 | ! |
varlv <-any(nodes$tiepe == "varlv") |
| 97 | ! |
for (j in seq.int(nrow(edges))) {
|
| 98 | ! |
van <- which(nodes$id == edges$van[j]) |
| 99 | ! |
vannaam <- nodenaam(nodes$naam[van], nodes$blok[van]) |
| 100 | ! |
naar <- which(nodes$id == edges$naar[j]) |
| 101 | ! |
naarnaam <- nodenaam(nodes$naam[naar], nodes$blok[naar]) |
| 102 | ! |
nodelabel <- lav_label_code(edges$label[j], italic = italic, |
| 103 | ! |
auto.subscript = auto.subscript)$tikz |
| 104 | ! |
if (van == naar) { # self
|
| 105 | ! |
if (nodes$kolom[van] == 1L) {
|
| 106 | ! |
writeLines(paste("\\path[<->] (", vannaam,
|
| 107 | ! |
") edge [in=160, out=-160, looseness=8] node[right] {",
|
| 108 | ! |
nodelabel, "} (",
|
| 109 | ! |
vannaam, ");", |
| 110 | ! |
sep = ""), zz) |
| 111 | ! |
} else if (nodes$rij[van] == maxrij) {
|
| 112 | ! |
writeLines(paste("\\path[<->] (", vannaam,
|
| 113 | ! |
") edge [in=-110, out=-70, looseness=8] node[above] {",
|
| 114 | ! |
nodelabel, "} (",
|
| 115 | ! |
vannaam, ");", |
| 116 | ! |
sep = ""), zz) |
| 117 | ! |
} else if (nodes$kolom[van] == maxcol) {
|
| 118 | ! |
writeLines(paste("\\path[<->] (", vannaam,
|
| 119 | ! |
") edge [in=20, out=-20, looseness=8] node[left] {",
|
| 120 | ! |
nodelabel, "} (",
|
| 121 | ! |
vannaam, ");", |
| 122 | ! |
sep = ""), zz) |
| 123 |
} else {
|
|
| 124 | ! |
writeLines(paste("\\path[<->] (", vannaam,
|
| 125 | ! |
") edge [in=110, out=70, looseness=8] node[below] {",
|
| 126 | ! |
nodelabel, "} (",
|
| 127 | ! |
vannaam, ");", |
| 128 | ! |
sep = ""), zz) |
| 129 |
} |
|
| 130 |
} else {
|
|
| 131 | ! |
anchorv <- switch(edges$vananker[j], |
| 132 | ! |
n = ".north", e = ".east", s = ".south", w = ".west") |
| 133 | ! |
anchorn <- switch(edges$naaranker[j], |
| 134 | ! |
n = ".north", e = ".east", s = ".south", w = ".west") |
| 135 | ! |
if (is.na(edges$controlpt.kol[j])) {
|
| 136 | ! |
pathtype <- " -- " |
| 137 |
} else {
|
|
| 138 | ! |
vanadr <- lav_node_coordinates(edges$van[j], edges$vananker[j], nodes, maxrij) |
| 139 | ! |
naaradr <- lav_node_coordinates(edges$naar[j], edges$naaranker[j], nodes, maxrij) |
| 140 | ! |
controlq <- c(edges$controlpt.kol[j], maxrij - edges$controlpt.rij[j]) |
| 141 | ! |
beziersc <- lav_beziersq_beziersc( |
| 142 | ! |
matrix(c(vanadr, controlq, naaradr), nrow = 2L) |
| 143 |
) |
|
| 144 | ! |
pathtype <- paste0(" .. controls (", beziersc[1L, 2L] , ",",
|
| 145 | ! |
beziersc[2L, 2L], ") and (", beziersc[1L, 3L] , ",",
|
| 146 | ! |
beziersc[2L, 3L], ") .. ") |
| 147 |
} |
|
| 148 | ! |
thelabel <- lav_label_code(edges$label[j], italic = italic, |
| 149 | ! |
auto.subscript = auto.subscript)$tikz |
| 150 | ! |
if (thelabel != "") {
|
| 151 | ! |
thelabel <- paste0("node[pos=0.5,",
|
| 152 | ! |
ifelse(edges$labelbelow[j], "below", "above"), |
| 153 | ! |
ifelse(sloped.labels, ",sloped", ""), |
| 154 | ! |
"] {", thelabel, "} ")
|
| 155 |
} |
|
| 156 | ! |
pijl <- ifelse(edges$tiepe[j] %in% c("~~", "~~~"), "<->", "->")
|
| 157 | ! |
writeLines(paste0("\\draw[", pijl, "] (", vannaam, anchorv, ")",
|
| 158 | ! |
pathtype, "(", naarnaam, anchorn, ") ",
|
| 159 | ! |
thelabel, ";", sep = ""), zz) |
| 160 |
} |
|
| 161 |
} |
|
| 162 | ! |
writeLines("\\end{tikzpicture}", zz)
|
| 163 | ! |
if(standalone) writeLines("\\end{document}", zz)
|
| 164 | ! |
if (closezz) close(zz) |
| 165 | ! |
return(invisible(NULL)) |
| 166 |
} |
| 1 |
# functions related to AIC and other information criteria |
|
| 2 | ||
| 3 |
# lower-level functions: |
|
| 4 |
# - lav_fit_aic |
|
| 5 |
# - lav_fit_bic |
|
| 6 |
# - lav_fit_sabic |
|
| 7 | ||
| 8 |
# higher-level functions: |
|
| 9 |
# - lav_fit_aic_lavobject |
|
| 10 | ||
| 11 |
# Y.R. 21 July 2022 |
|
| 12 | ||
| 13 |
lav_fit_aic <- function(logl = NULL, npar = NULL) {
|
|
| 14 | 118x |
AIC <- (-2 * logl) + (2 * npar) |
| 15 | 118x |
AIC |
| 16 |
} |
|
| 17 | ||
| 18 |
lav_fit_bic <- function(logl = NULL, npar = NULL, N = NULL) {
|
|
| 19 | 118x |
BIC <- (-2 * logl) + (npar * log(N)) |
| 20 | 118x |
BIC |
| 21 |
} |
|
| 22 | ||
| 23 |
lav_fit_sabic <- function(logl = NULL, npar = NULL, N = NULL) {
|
|
| 24 | 118x |
N.star <- (N + 2) / 24 |
| 25 | 118x |
SABIC <- (-2 * logl) + (npar * log(N.star)) |
| 26 | 118x |
SABIC |
| 27 |
} |
|
| 28 | ||
| 29 |
lav_fit_aic_lavobject <- function(lavobject = NULL, fit.measures = "aic", |
|
| 30 |
standard.test = "standard", |
|
| 31 |
scaled.test = "none", |
|
| 32 |
estimator = "ML") {
|
|
| 33 |
# check lavobject |
|
| 34 | 19x |
stopifnot(inherits(lavobject, "lavaan")) |
| 35 |
# check object |
|
| 36 | 19x |
lavobject <- lav_object_check_version(lavobject) |
| 37 | ||
| 38 |
# tests |
|
| 39 | 19x |
TEST <- lavobject@test |
| 40 | 19x |
test.names <- sapply(lavobject@test, "[[", "test") |
| 41 | 19x |
if (test.names[1] == "none" || standard.test == "none") {
|
| 42 | ! |
return(list()) |
| 43 |
} |
|
| 44 | 19x |
test.idx <- which(test.names == standard.test)[1] |
| 45 | 19x |
if (length(test.idx) == 0L) {
|
| 46 | ! |
return(list()) |
| 47 |
} |
|
| 48 | ||
| 49 | 19x |
scaled.flag <- FALSE |
| 50 | 19x |
if (!scaled.test %in% c("none", "standard", "default")) {
|
| 51 | 1x |
scaled.idx <- which(test.names == scaled.test) |
| 52 | 1x |
if (length(scaled.idx) > 0L) {
|
| 53 | 1x |
scaled.idx <- scaled.idx[1] # only the first one |
| 54 | 1x |
scaled.flag <- TRUE |
| 55 |
} |
|
| 56 |
} |
|
| 57 | ||
| 58 |
# estimator? |
|
| 59 | 19x |
if (missing(estimator)) {
|
| 60 | ! |
estimator <- lavobject@Options$estimator |
| 61 |
} |
|
| 62 | ||
| 63 |
# supported fit measures in this function |
|
| 64 | 19x |
if (estimator == "MML") {
|
| 65 | ! |
fit.logl <- c("logl", "aic", "bic", "ntotal", "bic2")
|
| 66 |
} else {
|
|
| 67 | 19x |
fit.logl <- c( |
| 68 | 19x |
"logl", "unrestricted.logl", "aic", "bic", |
| 69 | 19x |
"ntotal", "bic2" |
| 70 |
) |
|
| 71 |
} |
|
| 72 | 19x |
if (scaled.flag && |
| 73 | 19x |
scaled.test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
|
| 74 | 1x |
fit.logl <- c(fit.logl, "scaling.factor.h1", "scaling.factor.h0") |
| 75 |
} |
|
| 76 | ||
| 77 |
# which one do we need? |
|
| 78 | 19x |
if (missing(fit.measures)) {
|
| 79 |
# default set |
|
| 80 | ! |
fit.measures <- fit.logl |
| 81 |
} else {
|
|
| 82 |
# remove any not-CFI related index from fit.measures |
|
| 83 | 19x |
rm.idx <- which(!fit.measures %in% fit.logl) |
| 84 | 19x |
if (length(rm.idx) > 0L) {
|
| 85 | 19x |
fit.measures <- fit.measures[-rm.idx] |
| 86 |
} |
|
| 87 | 19x |
if (length(fit.measures) == 0L) {
|
| 88 | ! |
return(list()) |
| 89 |
} |
|
| 90 |
} |
|
| 91 | ||
| 92 |
# output container |
|
| 93 | 19x |
indices <- list() |
| 94 | ||
| 95 |
# non-ML values |
|
| 96 | 19x |
indices["logl"] <- as.numeric(NA) |
| 97 | 19x |
indices["unrestricted.logl"] <- as.numeric(NA) |
| 98 | 19x |
indices["aic"] <- as.numeric(NA) |
| 99 | 19x |
indices["bic"] <- as.numeric(NA) |
| 100 | 19x |
indices["ntotal"] <- lavobject@SampleStats@ntotal |
| 101 | 19x |
indices["bic2"] <- as.numeric(NA) |
| 102 | ||
| 103 | 19x |
if (estimator %in% c("ML", "MML")) {
|
| 104 |
# do we have a @h1 slot? |
|
| 105 | 19x |
if (length(lavobject@h1) > 0L) {
|
| 106 | 19x |
indices["unrestricted.logl"] <- lavobject@h1$logl$loglik |
| 107 |
} else {
|
|
| 108 | ! |
lavh1 <- lav_h1_implied_logl( |
| 109 | ! |
lavdata = lavobject@Data, |
| 110 | ! |
lavsamplestats = lavobject@SampleStats, |
| 111 | ! |
lavoptions = lavobject@Options |
| 112 |
) |
|
| 113 | ! |
indices["unrestricted.logl"] <- lavh1$logl$loglik |
| 114 |
} |
|
| 115 | ||
| 116 |
# logl H0 |
|
| 117 | 19x |
loglik <- lavobject@loglik |
| 118 | 19x |
indices["logl"] <- loglik$loglik |
| 119 | 19x |
indices["aic"] <- loglik$AIC |
| 120 | 19x |
indices["bic"] <- loglik$BIC |
| 121 | 19x |
indices["ntotal"] <- loglik$ntotal |
| 122 | 19x |
indices["bic2"] <- loglik$BIC2 |
| 123 | ||
| 124 |
# scaling factor for MLR |
|
| 125 | 19x |
if (scaled.test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
|
| 126 | 1x |
indices["scaling.factor.h1"] <- TEST[[scaled.idx]]$scaling.factor.h1 |
| 127 | 1x |
indices["scaling.factor.h0"] <- TEST[[scaled.idx]]$scaling.factor.h0 |
| 128 |
} |
|
| 129 |
} # ML |
|
| 130 | ||
| 131 |
# return only those that were requested |
|
| 132 | 19x |
indices[fit.measures] |
| 133 |
} |
| 1 |
# Displays a message (... concatenated with spaces in between) with header |
|
| 2 |
# 'lavaan(function):', except when showheader == FALSE, and formatted to have |
|
| 3 |
# a maximum line length of 'txt.width' while all but the first line start with |
|
| 4 |
# 'indent' spaces. If a footer is specified it is appended to the formatted text |
|
| 5 |
# 'as is'. The message is shown via R function 'message()'. |
|
| 6 |
lav_msg_note <- function(..., showheader = FALSE, footer = "") {
|
|
| 7 | ! |
wat <- unlist(list(...), use.names = FALSE) |
| 8 | ! |
if (!showheader) wat <- c("lavaan NOTE: ___", wat)
|
| 9 | ! |
msg <- lav_msg(wat, showheader = showheader) |
| 10 | ! |
if (footer != "") msg <- paste(msg, footer, sep = "\n") |
| 11 | ! |
message(msg, domain = NA) |
| 12 |
} |
|
| 13 | ||
| 14 |
# Displays a message with header and formatted as |
|
| 15 |
# above via R function 'warning()'. |
|
| 16 |
lav_msg_warn <- function(..., footer = "") {
|
|
| 17 | 18x |
if (!lav_warn()) return() |
| 18 | 112x |
wat <- unlist(list(...), use.names = FALSE) |
| 19 | 112x |
msg <- lav_msg(wat) |
| 20 | 28x |
if (footer != "") msg <- paste(msg, footer, sep = "\n") |
| 21 | 112x |
warning(msg, call. = FALSE, domain = NA) |
| 22 |
} |
|
| 23 | ||
| 24 |
# Displays a message with header and formatted as |
|
| 25 |
# above via R function 'stop()'. |
|
| 26 |
lav_msg_stop <- function(..., footer = "") {
|
|
| 27 | 9x |
wat <- unlist(list(...), use.names = FALSE) |
| 28 | 9x |
msg <- lav_msg(wat) |
| 29 | 8x |
if (footer != "") msg <- paste(msg, footer, sep = "\n") |
| 30 | 9x |
stop(msg, call. = FALSE, domain = NA) |
| 31 |
} |
|
| 32 | ||
| 33 |
# Displays a message with header and formatted as |
|
| 34 |
# above via R function 'stop()', where the message is prepended with "FIXME:", |
|
| 35 |
# to indicate an internal error, e.g. an error condition which was supposed |
|
| 36 |
# to be handled in the calling functions. Such error message do not have to |
|
| 37 |
# be created by [n]gettext[f] because they don't have to be translated!!! |
|
| 38 |
lav_msg_fixme <- function(...) {
|
|
| 39 | ! |
wat <- c("FIXME: ", unlist(list(...), use.names = FALSE))
|
| 40 | ! |
stop(lav_msg(wat), call. = FALSE, domain = NA) |
| 41 |
} |
|
| 42 | ||
| 43 |
# subroutine for above functions |
|
| 44 |
lav_msg <- function(wat, txt.width = getOption("width", 80L),
|
|
| 45 |
indent = 3L, showheader = TRUE) {
|
|
| 46 | 121x |
if (showheader) {
|
| 47 | 121x |
ignore.in.stack <- c( |
| 48 | 121x |
"^eval$", "^try", "^doTryCatch", "^lav_msg", "^stop$", "^warning$", |
| 49 | 121x |
"^which$", "^unique$", "^as\\.", "^unlist$", "^message$", |
| 50 | 121x |
"^source$", "^withVisible$", "^tryCatch.W.E$", "^withCallingHandlers$", |
| 51 | 121x |
"^do.call$", "^paste" |
| 52 |
) |
|
| 53 | 121x |
sc <- sys.calls() |
| 54 | 121x |
sc.i <- length(sc) |
| 55 | 121x |
sc.naam <- "" |
| 56 | 121x |
while (sc.i > 0L) {
|
| 57 | 363x |
x <- tryCatch( |
| 58 | 363x |
as.character(sc[[sc.i]][[1L]]), |
| 59 | ! |
error = function(e) {"unknown"}
|
| 60 |
) |
|
| 61 | 363x |
if (length(x) == 3L) {
|
| 62 |
# needed if a function specified in namespace, e.g. |
|
| 63 |
# as.character(str2lang("lavaan::sem(m, d)")[[1L]])
|
|
| 64 | ! |
x <- x[[3L]] |
| 65 |
} |
|
| 66 | 363x |
skip <- FALSE |
| 67 | 363x |
for (re in ignore.in.stack) {
|
| 68 | 3025x |
if (grepl(re, x)) {
|
| 69 | 242x |
skip <- TRUE |
| 70 | 242x |
break |
| 71 |
} |
|
| 72 |
} |
|
| 73 | 363x |
if (!skip) {
|
| 74 | 121x |
sc.naam <- x |
| 75 | 121x |
break |
| 76 |
} |
|
| 77 | 242x |
sc.i <- sc.i - 1L |
| 78 |
} |
|
| 79 | 121x |
if (sc.naam == "") {
|
| 80 | ! |
header <- "lavaan: ___" |
| 81 |
} else {
|
|
| 82 | 121x |
header <- paste0("lavaan->", sc.naam, "(): ___")
|
| 83 |
} |
|
| 84 |
} else {
|
|
| 85 | ! |
header <- "" |
| 86 |
} |
|
| 87 | 121x |
txt.width <- txt.width - indent # whitespace at the right |
| 88 |
# make sure we only have a single string |
|
| 89 | 121x |
txt <- paste(wat, collapse = " ") |
| 90 |
# split the txt in little chunks |
|
| 91 | 121x |
chunks <- strsplit(paste(header, txt), "\\s+", fixed = FALSE)[[1]] |
| 92 | ||
| 93 |
# chunk size (number of characters) |
|
| 94 | 121x |
chunk.size <- nchar(chunks) |
| 95 | ||
| 96 |
# remove empty chunk in position 1 (if txt starts with whitespace) |
|
| 97 | 121x |
if (chunk.size[1L] == 0L) {
|
| 98 | ! |
chunks <- chunks[-1L] |
| 99 | ! |
chunk.size <- chunk.size[-1] |
| 100 |
} |
|
| 101 | ||
| 102 | 121x |
nstart <- 1L |
| 103 | 121x |
nstop <- 1L |
| 104 | 121x |
corr.line1 <- 7L # first line possibly contains "error: " |
| 105 | 121x |
while (nstart <= length(chunks)) {
|
| 106 | 242x |
while (nstop < length(chunks) && |
| 107 | 242x |
sum(chunk.size[seq.int(nstart, nstop + 1L)]) + corr.line1 + |
| 108 | 242x |
nstop - nstart + indent < txt.width && chunks[nstop + 1L] != "___") {
|
| 109 | 877x |
nstop <- nstop + 1 |
| 110 |
} |
|
| 111 | 242x |
corr.line1 <- 0L |
| 112 | 242x |
if (nstop < length(chunks) && chunks[nstop + 1L] == "___") {
|
| 113 |
# forced line break |
|
| 114 | 121x |
chunks[nstop + 1L] <- "" |
| 115 | 121x |
nstop <- nstop + 1L |
| 116 |
} |
|
| 117 | 242x |
if (nstop < length(chunks)) {
|
| 118 | 121x |
chunks[nstop + 1L] <- paste0( |
| 119 | 121x |
"\n", strrep(" ", indent),
|
| 120 | 121x |
chunks[nstop + 1L] |
| 121 |
) |
|
| 122 |
} |
|
| 123 | 242x |
nstart <- nstop + 1L |
| 124 | 242x |
nstop <- nstart |
| 125 |
} |
|
| 126 | 121x |
paste(chunks, collapse = " ") |
| 127 |
} |
|
| 128 | ||
| 129 |
# Transforms a value to a character representation for use in messages |
|
| 130 |
# if logsep = "array" (default), letters[1:3] is transformed to ("a", "b", "c")
|
|
| 131 |
# if logsep = "none", c("x", "y", "z") is transformed to "x", "y", "z"
|
|
| 132 |
# if logsep = "and", 1:3 is transformed to 1, 2 and 3 |
|
| 133 |
# if logsep = "or", c("a", "b", "c") is transformed to "a", "b" or "c"
|
|
| 134 |
# The type of quote can be modified via parameter qd (default = TRUE). |
|
| 135 |
# If the object has names, the names will be prepended with a colon before the |
|
| 136 |
# value, e.g. c(x = 2.3, y = 4) --> (x : 2.3, y : 4). |
|
| 137 |
lav_msg_view <- function(x, |
|
| 138 |
log.sep = c("array", "none", "and", "or"),
|
|
| 139 |
qd = TRUE) {
|
|
| 140 | ! |
if (missing(x)) {
|
| 141 | ! |
return("NULL")
|
| 142 |
} |
|
| 143 | ! |
log.sep <- match.arg(log.sep) |
| 144 | ! |
xn <- names(x) |
| 145 | ! |
if (is.list(x)) {
|
| 146 | ! |
xx <- sapply(x, lav_msg_view) |
| 147 |
} else {
|
|
| 148 | ! |
if (is.character(x)) {
|
| 149 | ! |
if (qd) {
|
| 150 | ! |
xx <- dQuote(x, q = FALSE) |
| 151 |
} else {
|
|
| 152 | ! |
xx <- sQuote(x, q = FALSE) |
| 153 |
} |
|
| 154 |
} else {
|
|
| 155 | ! |
xx <- as.character(x) |
| 156 |
} |
|
| 157 | ! |
xx[is.na(x)] <- "NA" |
| 158 |
} |
|
| 159 | ! |
if (!is.null(xn)) xx <- paste(xn, ":", xx) |
| 160 | ! |
if (length(xx) == 1) {
|
| 161 | ! |
rv <- xx |
| 162 |
} else {
|
|
| 163 | ! |
if (log.sep == "array") rv <- paste0("(", paste(xx, collapse = ", "), ")")
|
| 164 | ! |
if (log.sep == "none") rv <- paste(xx, collapse = ", ") |
| 165 | ! |
if (log.sep == "and") rv <- paste(paste(xx[-length(xx)], collapse = ", "), gettext("and"), xx[length(xx)])
|
| 166 | ! |
if (log.sep == "or") rv <- paste(paste(xx[-length(xx)], collapse = ", "), gettext("or"), xx[length(xx)])
|
| 167 |
} |
|
| 168 | ! |
rv |
| 169 |
} |
|
| 170 |
# Warning for deprecated functions |
|
| 171 |
# Like base::.Deprecated but specialised for lavaan |
|
| 172 |
# parameter times specifies how many times the warning should be generated |
|
| 173 |
# during one "lavaan-package-session" |
|
| 174 |
lav_deprecated <- function(new, |
|
| 175 |
old = as.character(sys.call(sys.parent()))[1L], |
|
| 176 |
times = 1L) {
|
|
| 177 | 2x |
dprmsg <- get0(paste0("dpr_", old), lavaan_cache_env,
|
| 178 | 2x |
ifnotfound = as.integer(times)) |
| 179 | 1x |
if (dprmsg <= 0L) return(invisible(NULL)) |
| 180 | 1x |
assign(paste0("dpr_", old), dprmsg - 1L, lavaan_cache_env)
|
| 181 | 1x |
msg <- c(gettextf("'%s' is deprecated.\n", old),
|
| 182 | 1x |
gettextf("Use '%s' instead.\n", new),
|
| 183 | 1x |
gettext("See help(\"Deprecated\")"))
|
| 184 | 1x |
msg <- paste(msg, collapse = "") |
| 185 | 1x |
warning(warningCondition(msg, old = old, new = new, package = NULL, |
| 186 | 1x |
class = "deprecatedWarning")) |
| 187 |
} |
|
| 188 | ||
| 189 |
# Warning for deprecated arguments-parameter for another parameter in a function |
|
| 190 |
# method.par specifies the name of the parameter used for a 'method' |
|
| 191 |
# arg.par specifies the name of the deprecated parameter |
|
| 192 |
# parameter times specifies how many times the warning should be generated |
|
| 193 |
# during one "lavaan-package-session" |
|
| 194 |
lav_deprecated_args <- function(method.par, arg.par, times = 1L) {
|
|
| 195 | ! |
dprmsg <- get0(paste0("dpr_", method.par, arg.par), lavaan_cache_env,
|
| 196 | ! |
ifnotfound = as.integer(times)) |
| 197 | ! |
if (dprmsg <= 0L) return(invisible(NULL)) |
| 198 | ! |
assign(paste0("dpr_", method.par, arg.par), dprmsg - 1L, lavaan_cache_env)
|
| 199 | ! |
msg <- c(gettextf("Argument '%s' is deprecated.\n", arg.par),
|
| 200 | ! |
gettextf("The arguments for '%s' can now be provided in '%s' itself.\n",
|
| 201 | ! |
method.par, method.par)) |
| 202 | ! |
msg <- paste(msg, collapse = "") |
| 203 | ! |
warning(warningCondition(msg, old = arg.par, new = method.par, package = NULL, |
| 204 | ! |
class = "deprecatedWarning")) |
| 205 |
} |
|
| 206 | ||
| 207 |
# --------------- examples of use ---------------------- |
|
| 208 |
# # warning if argument x is missing |
|
| 209 |
# lav_msg_warn(gettextf( |
|
| 210 |
# "argument %1$s is missing, using %2$s.", |
|
| 211 |
# x, lav_msg_view(usedvalue) |
|
| 212 |
# )) |
|
| 213 |
# |
|
| 214 |
# # warning if length of an argument x is greater then 1 and cannot be |
|
| 215 |
# lav_msg_warn(gettextf("%1$s argument should be a single character string.
|
|
| 216 |
# Only the first one (%2$s) is used.", xname, x[[1]])) |
|
| 217 |
# |
|
| 218 |
# # error if argument is unknown (show value) |
|
| 219 |
# lav_msg_stop(gettextf( |
|
| 220 |
# "%1$s argument unknown: %2$s", |
|
| 221 |
# xname, lav_msg_view(xvalue) |
|
| 222 |
# )) |
|
| 223 |
# |
|
| 224 |
# # error if argument isn't one of the allowed values, show values allowed |
|
| 225 |
# if (length(allowed) == 2L) {
|
|
| 226 |
# lav_msg_stop(gettextf( |
|
| 227 |
# "%1$s argument must be either %2$s", |
|
| 228 |
# x, lav_msg_view(allowed, "or") |
|
| 229 |
# )) |
|
| 230 |
# } else {
|
|
| 231 |
# lav_msg_stop(gettextf( |
|
| 232 |
# "%1$s argument must be one of %2$s", |
|
| 233 |
# x, lav_msg_view(allowed, "or") |
|
| 234 |
# )) |
|
| 235 |
# } |
|
| 236 |
# |
|
| 237 |
# # error if argument isn't one of the allowed values (show invalid ones) |
|
| 238 |
# lav_msg_stop(sprintf( |
|
| 239 |
# ngettext( |
|
| 240 |
# length(invalids), |
|
| 241 |
# "invalid value in %1$s argument: %2$s.", |
|
| 242 |
# "invalid values in %1$s argument: %2$s." |
|
| 243 |
# ), |
|
| 244 |
# x, lav_msg_view(invalids, log.sep = "none") |
|
| 245 |
# )) |
| 1 |
# routines for numerical intregration |
|
| 2 | ||
| 3 |
# integrate (-infty to +infty) a product of univariate Gaussian densities |
|
| 4 |
# with givens means (mus) and standard deviations (sds) (or variances, vars) |
|
| 5 |
lav_integration_gaussian_product <- function(mus = NULL, sds = NULL, vars = NULL) {
|
|
| 6 | ! |
n <- length(mus) |
| 7 | ! |
if (is.null(vars)) {
|
| 8 | ! |
vars <- sds^2 |
| 9 |
} |
|
| 10 | ||
| 11 |
# variance product |
|
| 12 | ! |
var.prod <- 1 / sum(1 / vars) |
| 13 | ||
| 14 |
# mean product |
|
| 15 | ! |
mu.prod <- sum(mus / vars) * var.prod |
| 16 | ||
| 17 |
# normalization constant |
|
| 18 | ! |
const <- 1 / sqrt((2 * pi)^(n - 1)) * sqrt(var.prod) * sqrt(1 / prod(vars)) * exp(-0.5 * (sum(mus^2 / vars) - mu.prod^2 / var.prod)) |
| 19 | ||
| 20 | ! |
const |
| 21 |
} |
|
| 22 | ||
| 23 | ||
| 24 | ||
| 25 |
# return Gauss-Hermite quadrature rule for given order (n) |
|
| 26 |
# return list: x = nodes, w = quadrature weights |
|
| 27 |
# |
|
| 28 | ||
| 29 |
# As noted by Wilf (1962, chapter 2, ex 9), the nodes are given by |
|
| 30 |
# the eigenvalues of the Jacobi matrix; weights are given by the squares of the |
|
| 31 |
# first components of the (normalized) eigenvectors, multiplied by sqrt(pi) |
|
| 32 |
# |
|
| 33 |
# (This is NOT identical to Golub & Welsch, 1968: as they used a specific |
|
| 34 |
# method tailored for tridiagonal symmetric matrices) |
|
| 35 |
# |
|
| 36 |
# TODO: look at https://github.com/ajt60gaibb/FastGaussQuadrature.jl/blob/master/src/gausshermite.jl |
|
| 37 |
# featuring the work of Ignace Bogaert (UGent) |
|
| 38 |
# |
|
| 39 |
# approximation of the integral of 'f(x) * exp(-x*x)' from -inf to +inf |
|
| 40 |
# by sum( f(x_i) * w_i ) |
|
| 41 |
# |
|
| 42 |
# CHECK: sum(w_i) should be always sqrt(pi) = 1.772454 |
|
| 43 |
lav_integration_gauss_hermite_xw <- function(n = 21L, revert = FALSE) {
|
|
| 44 |
# force n to be an integer |
|
| 45 | ! |
n <- as.integer(n) |
| 46 | ! |
stopifnot(n > 0L) |
| 47 | ||
| 48 | ! |
if (n == 1L) {
|
| 49 | ! |
x <- 0 |
| 50 | ! |
w <- sqrt(pi) |
| 51 |
} else {
|
|
| 52 |
# construct symmetric, tridiagonal Jacobi matrix |
|
| 53 |
# diagonal = 0, -1/+1 diagonal is sqrt(1:(n-1)/2) |
|
| 54 | ! |
u <- sqrt(seq.int(n - 1L) / 2) # upper diagonal of J |
| 55 | ! |
Jn <- matrix(0, n, n) |
| 56 | ! |
didx <- lav_matrix_diag_idx(n) |
| 57 | ! |
Jn[(didx + 1)[-n]] <- u |
| 58 |
# Jn[(didx-1)[-1]] <- u # only lower matrix is used anyway |
|
| 59 | ||
| 60 |
# eigen decomposition |
|
| 61 |
# FIXME: use specialized function for tridiagonal symmetrix matrix |
|
| 62 | ! |
ev <- eigen(Jn, symmetric = TRUE) |
| 63 | ! |
x <- ev$values |
| 64 | ! |
tmp <- ev$vectors[1L, ] |
| 65 | ! |
w <- sqrt(pi) * tmp * tmp |
| 66 |
} |
|
| 67 | ||
| 68 |
# revert? (minus to plus) |
|
| 69 | ! |
if (revert) {
|
| 70 | ! |
x <- -x |
| 71 |
} |
|
| 72 | ||
| 73 | ! |
list(x = x, w = w) |
| 74 |
} |
|
| 75 | ||
| 76 |
# generate GH points + weights |
|
| 77 |
lav_integration_gauss_hermite <- function(n = 21L, |
|
| 78 |
dnorm = FALSE, |
|
| 79 |
mean = 0, sd = 1, |
|
| 80 |
ndim = 1L, |
|
| 81 |
revert = TRUE, |
|
| 82 |
prune = FALSE) {
|
|
| 83 | ! |
XW <- lav_integration_gauss_hermite_xw(n = n, revert = revert) |
| 84 | ||
| 85 |
# dnorm kernel? |
|
| 86 | ! |
if (dnorm) {
|
| 87 |
# scale/shift x |
|
| 88 | ! |
x <- XW$x * sqrt(2) * sd + mean |
| 89 | ||
| 90 |
# scale w |
|
| 91 | ! |
w <- XW$w / sqrt(pi) |
| 92 |
} else {
|
|
| 93 | ! |
x <- XW$x |
| 94 | ! |
w <- XW$w |
| 95 |
} |
|
| 96 | ||
| 97 | ! |
if (ndim > 1L) {
|
| 98 |
# cartesian product |
|
| 99 | ! |
x <- as.matrix(expand.grid(rep(list(x), ndim), KEEP.OUT.ATTRS = FALSE)) |
| 100 | ! |
w <- as.matrix(expand.grid(rep(list(w), ndim), KEEP.OUT.ATTRS = FALSE)) |
| 101 | ! |
w <- apply(w, 1, prod) |
| 102 |
} else {
|
|
| 103 | ! |
x <- as.matrix(x) |
| 104 | ! |
w <- as.matrix(w) |
| 105 |
} |
|
| 106 | ||
| 107 |
# prune? |
|
| 108 | ! |
if (is.logical(prune) && prune) {
|
| 109 |
# always divide by N=21 |
|
| 110 | ! |
lower.limit <- XW$w[1] * XW$w[floor((n + 1) / 2)] / 21 |
| 111 | ! |
keep.idx <- which(w > lower.limit) |
| 112 | ! |
w <- w[keep.idx] |
| 113 | ! |
x <- x[keep.idx, , drop = FALSE] |
| 114 | ! |
} else if (is.numeric(prune) && prune > 0) {
|
| 115 | ! |
lower.limit <- quantile(w, probs = prune) |
| 116 | ! |
keep.idx <- which(w > lower.limit) |
| 117 | ! |
w <- w[keep.idx] |
| 118 | ! |
x <- x[keep.idx, , drop = FALSE] |
| 119 |
} |
|
| 120 | ||
| 121 | ! |
list(x = x, w = w) |
| 122 |
} |
|
| 123 | ||
| 124 |
# backwards compatibility |
|
| 125 |
lav_integration_gauss_hermite_dnorm <- function(n = 21L, mean = 0, sd = 1, |
|
| 126 |
ndim = 1L, |
|
| 127 |
revert = TRUE, |
|
| 128 |
prune = FALSE) {
|
|
| 129 | ! |
lav_integration_gauss_hermite( |
| 130 | ! |
n = n, dnorm = TRUE, mean = mean, sd = sd, |
| 131 | ! |
ndim = ndim, revert = revert, prune = prune |
| 132 |
) |
|
| 133 |
} |
|
| 134 | ||
| 135 |
# plot 2-dim |
|
| 136 |
# out <- lavaan:::lav_integration_gauss_hermite_dnorm(n = 20, ndim = 2) |
|
| 137 |
# plot(out$x, cex = -10/log(out$w), col = "darkgrey", pch=19) |
|
| 138 | ||
| 139 |
# integrand g(x) has the form g(x) = f(x) dnorm(x, m, s^2) |
|
| 140 |
lav_integration_f_dnorm <- function(func = NULL, # often ly.prod |
|
| 141 |
dnorm.mean = 0, # dnorm mean |
|
| 142 |
dnorm.sd = 1, # dnorm sd |
|
| 143 |
XW = NULL, # GH points |
|
| 144 |
n = 21L, # number of nodes |
|
| 145 |
adaptive = FALSE, # adaptive? |
|
| 146 |
iterative = FALSE, # iterative? |
|
| 147 |
max.iter = 20L, # max iterations |
|
| 148 |
...) { # optional args for 'f'
|
|
| 149 | ||
| 150 |
# create GH rule |
|
| 151 | ! |
if (is.null(XW)) {
|
| 152 | ! |
XW <- lav_integration_gauss_hermite_xw(n = n, revert = TRUE) |
| 153 |
} |
|
| 154 | ||
| 155 | ! |
if (!adaptive) {
|
| 156 | ! |
w.star <- XW$w / sqrt(pi) |
| 157 | ! |
x.star <- dnorm.sd * (sqrt(2) * XW$x) + dnorm.mean |
| 158 | ! |
out <- sum(func(x.star, ...) * w.star) |
| 159 |
} else {
|
|
| 160 |
# Naylor & Smith (1982, 1988) |
|
| 161 | ! |
if (iterative) {
|
| 162 | ! |
mu.est <- 0 |
| 163 | ! |
sd.est <- 1 |
| 164 | ||
| 165 | ! |
for (i in 1:max.iter) {
|
| 166 | ! |
w.star <- sqrt(2) * sd.est * dnorm(sqrt(2) * sd.est * XW$x + mu.est, dnorm.mean, dnorm.sd) * exp(XW$x^2) * XW$w |
| 167 | ! |
x.star <- sqrt(2) * sd.est * XW$x + mu.est |
| 168 | ! |
LIK <- sum(func(x.star, ...) * w.star) |
| 169 | ||
| 170 |
# update mu |
|
| 171 | ! |
mu.est <- sum(x.star * (func(x.star, ...) * w.star) / LIK) |
| 172 | ||
| 173 |
# update sd |
|
| 174 | ! |
var.est <- sum(x.star^2 * (func(x.star, ...) * w.star) / LIK) - mu.est^2 |
| 175 | ! |
sd.est <- sqrt(var.est) |
| 176 | ||
| 177 | ! |
if (lav_verbose()) {
|
| 178 | ! |
cat( |
| 179 | ! |
"i = ", i, "LIK = ", LIK, "mu.est = ", mu.est, |
| 180 | ! |
"sd.est = ", sd.est, "\n" |
| 181 |
) |
|
| 182 |
} |
|
| 183 |
} |
|
| 184 | ! |
out <- LIK |
| 185 | ||
| 186 |
# Liu and Pierce (1994) |
|
| 187 |
} else {
|
|
| 188 |
# integrand g(x) = func(x) * dnorm(x; m, s^2) |
|
| 189 | ! |
log.g <- function(x, ...) {
|
| 190 |
## FIXME: should we take the log right away? |
|
| 191 | ! |
log(func(x, ...) * dnorm(x, mean = dnorm.mean, sd = dnorm.sd)) |
| 192 |
} |
|
| 193 |
# find mu hat and sd hat |
|
| 194 | ! |
mu.est <- optimize( |
| 195 | ! |
f = log.g, interval = c(-10, 10), |
| 196 | ! |
maximum = TRUE, tol = .Machine$double.eps, ... |
| 197 | ! |
)$maximum |
| 198 | ! |
H <- as.numeric(numDeriv::hessian(func = log.g, x = mu.est, ...)) |
| 199 | ! |
sd.est <- sqrt(1 / -H) |
| 200 | ||
| 201 | ! |
w.star <- sqrt(2) * sd.est * dnorm(sd.est * (sqrt(2) * XW$x) + mu.est, dnorm.mean, dnorm.sd) * exp(XW$x^2) * XW$w |
| 202 | ! |
x.star <- sd.est * (sqrt(2) * XW$x) + mu.est |
| 203 | ||
| 204 | ! |
out <- sum(func(x.star, ...) * w.star) |
| 205 |
} |
|
| 206 |
} |
|
| 207 | ||
| 208 | ! |
out |
| 209 |
} |
|
| 210 | ||
| 211 |
# integrand g(z) has the form g(z) = f(sz+m) dnorm(z, 0, 1) |
|
| 212 |
lav_integration_f_dnorm_z <- function(func = NULL, # often ly.prod |
|
| 213 |
f.mean = 0, # f mean |
|
| 214 |
f.sd = 1, # f sd |
|
| 215 |
XW = NULL, # GH points |
|
| 216 |
n = 21L, # number of nodes |
|
| 217 |
adaptive = FALSE, # adaptive? |
|
| 218 |
iterative = FALSE, # iterative? |
|
| 219 |
max.iter = 20L, # max iterations |
|
| 220 |
...) { # optional args for 'f'
|
|
| 221 | ||
| 222 |
# create GH rule |
|
| 223 | ! |
if (is.null(XW)) {
|
| 224 | ! |
XW <- lav_integration_gauss_hermite_xw(n = n, revert = TRUE) |
| 225 |
} |
|
| 226 | ||
| 227 | ! |
if (!adaptive) {
|
| 228 | ! |
w.star <- XW$w / sqrt(pi) |
| 229 | ! |
x.star <- sqrt(2) * XW$x |
| 230 | ! |
out <- sum(func(f.sd * x.star + f.mean, ...) * w.star) |
| 231 |
} else {
|
|
| 232 |
# Naylor & Smith (1982, 1988) |
|
| 233 | ! |
if (iterative) {
|
| 234 | ! |
mu.est <- 0 |
| 235 | ! |
sd.est <- 1 |
| 236 | ||
| 237 | ! |
for (i in 1:max.iter) {
|
| 238 | ! |
w.star <- sqrt(2) * sd.est * dnorm(sd.est * sqrt(2) * XW$x + mu.est, 0, 1) * exp(XW$x^2) * XW$w |
| 239 | ! |
x.star <- sd.est * (sqrt(2) * XW$x) + mu.est |
| 240 | ! |
LIK <- sum(func(f.sd * x.star + f.mean, ...) * w.star) |
| 241 | ||
| 242 |
# update mu |
|
| 243 | ! |
mu.est <- sum(x.star * (func(f.sd * x.star + f.mean, ...) * w.star) / LIK) |
| 244 | ||
| 245 |
# update sd |
|
| 246 | ! |
var.est <- sum(x.star^2 * (func(f.sd * x.star + f.mean, ...) * w.star) / LIK) - mu.est^2 |
| 247 | ! |
sd.est <- sqrt(var.est) |
| 248 | ||
| 249 | ! |
if (lav_verbose()) {
|
| 250 | ! |
cat( |
| 251 | ! |
"i = ", i, "LIK = ", LIK, "mu.est = ", mu.est, |
| 252 | ! |
"sd.est = ", sd.est, "\n" |
| 253 |
) |
|
| 254 |
} |
|
| 255 |
} |
|
| 256 | ! |
out <- LIK |
| 257 | ||
| 258 |
# Liu and Pierce (1994) |
|
| 259 |
} else {
|
|
| 260 |
# integrand g(x) = func(x) * dnorm(x; m, s^2) |
|
| 261 | ! |
log.gz <- function(x, ...) {
|
| 262 |
## FIXME: should we take the log right away? |
|
| 263 | ! |
log(func(f.sd * x + f.mean, ...) * dnorm(x, mean = 0, sd = 1)) |
| 264 |
} |
|
| 265 |
# find mu hat and sd hat |
|
| 266 | ! |
mu.est <- optimize( |
| 267 | ! |
f = log.gz, interval = c(-10, 10), |
| 268 | ! |
maximum = TRUE, tol = .Machine$double.eps, ... |
| 269 | ! |
)$maximum |
| 270 | ! |
H <- as.numeric(numDeriv::hessian(func = log.gz, x = mu.est, ...)) |
| 271 | ! |
sd.est <- sqrt(1 / -H) |
| 272 | ||
| 273 | ! |
w.star <- sqrt(2) * sd.est * dnorm(sd.est * (sqrt(2) * XW$x) + mu.est, 0, 1) * exp(XW$x^2) * XW$w |
| 274 | ! |
x.star <- sd.est * (sqrt(2) * XW$x) + mu.est |
| 275 | ||
| 276 | ! |
out <- sum(func(f.sd * x.star + f.mean, ...) * w.star) |
| 277 |
} |
|
| 278 |
} |
|
| 279 | ||
| 280 | ! |
out |
| 281 |
} |
| 1 |
# the univariate (weighted) linear model |
|
| 2 | ||
| 3 |
# - scores/gradient/hessian |
|
| 4 |
# - including the residual variance! |
|
| 5 | ||
| 6 |
# YR - 30 Dec 2019 (replacing the old lav_ols.R routines) |
|
| 7 | ||
| 8 |
lav_uvreg_fit <- function(y = NULL, |
|
| 9 |
X = NULL, |
|
| 10 |
wt = NULL, |
|
| 11 |
optim.method = "nlminb", |
|
| 12 |
control = list(), |
|
| 13 |
output = "list") {
|
|
| 14 |
# check weights |
|
| 15 | 40x |
if (is.null(wt)) {
|
| 16 | 40x |
wt <- rep(1, length(y)) |
| 17 |
} else {
|
|
| 18 | ! |
if (length(y) != length(wt)) {
|
| 19 | ! |
lav_msg_stop(gettext("length y is not the same as length wt"))
|
| 20 |
} |
|
| 21 | ! |
if (any(wt < 0)) {
|
| 22 | ! |
lav_msg_stop(gettext("all weights should be positive"))
|
| 23 |
} |
|
| 24 |
} |
|
| 25 | ||
| 26 |
# optim.method |
|
| 27 | 40x |
minObjective <- lav_uvreg_min_objective |
| 28 | 40x |
minGradient <- lav_uvreg_min_gradient |
| 29 | 40x |
minHessian <- lav_uvreg_min_hessian |
| 30 | 40x |
if (optim.method == "nlminb" || optim.method == "nlminb2") {
|
| 31 |
# nothing to do |
|
| 32 | ! |
} else if (optim.method == "nlminb0") {
|
| 33 | ! |
minGradient <- minHessian <- NULL |
| 34 | ! |
} else if (optim.method == "nlminb1") {
|
| 35 | ! |
minHessian <- NULL |
| 36 |
} |
|
| 37 | ||
| 38 |
# create cache environment |
|
| 39 | 40x |
cache <- lav_uvreg_init_cache(y = y, X = X, wt = wt) |
| 40 | ||
| 41 |
# optimize -- only changes from defaults |
|
| 42 | 40x |
control.nlminb <- list( |
| 43 | 40x |
eval.max = 20000L, iter.max = 10000L, |
| 44 | 40x |
trace = 0L, abs.tol = (.Machine$double.eps * 10) |
| 45 |
) |
|
| 46 | 40x |
control.nlminb <- modifyList(control.nlminb, control) |
| 47 | ||
| 48 | 40x |
optim <- nlminb( |
| 49 | 40x |
start = cache$theta, objective = minObjective, |
| 50 | 40x |
gradient = minGradient, hessian = minHessian, |
| 51 | 40x |
control = control.nlminb, cache = cache |
| 52 |
) |
|
| 53 | ||
| 54 | 40x |
if (output == "cache") {
|
| 55 | 20x |
return(cache) |
| 56 |
} |
|
| 57 | ||
| 58 |
# return results as a list (to be compatible with lav_polychor.R) |
|
| 59 | 20x |
out <- list( |
| 60 | 20x |
theta = optim$par, |
| 61 | 20x |
nexo = cache$nexo, |
| 62 | 20x |
int.idx = cache$int.idx, |
| 63 | 20x |
slope.idx = cache$slope.idx, |
| 64 | 20x |
beta.idx = cache$beta.idx, |
| 65 | 20x |
var.idx = cache$var.idx, |
| 66 | 20x |
y = cache$y, |
| 67 | 20x |
wt = cache$wt, |
| 68 | 20x |
X = cache$X1[, -1L, drop = FALSE], |
| 69 | 20x |
yhat = cache$yhat |
| 70 |
) |
|
| 71 |
} |
|
| 72 | ||
| 73 |
# prepare cache environment |
|
| 74 |
lav_uvreg_init_cache <- function(y = NULL, |
|
| 75 |
X = NULL, |
|
| 76 |
wt = rep(1, length(y)), |
|
| 77 |
parent = parent.frame()) {
|
|
| 78 |
# y |
|
| 79 | 40x |
y <- as.vector(y) |
| 80 | ||
| 81 |
# X |
|
| 82 | 40x |
if (is.null(X)) {
|
| 83 | ! |
nexo <- 0L |
| 84 | ! |
X1 <- matrix(1, length(y), 1) |
| 85 |
} else {
|
|
| 86 | 40x |
X <- unname(X) |
| 87 | 40x |
nexo <- ncol(X) |
| 88 | 40x |
X1 <- cbind(1, X, deparse.level = 0) |
| 89 | ||
| 90 |
# new in 0.6-17: check if X is full rank |
|
| 91 | 40x |
if (!anyNA(X)) {
|
| 92 | 40x |
if (qr(X)$rank < ncol(X)) {
|
| 93 | ! |
lav_msg_stop(gettext("matrix of exogenous covariates is rank deficient!
|
| 94 | ! |
(i.e., some x variables contain redundant information)")) |
| 95 |
} |
|
| 96 |
} |
|
| 97 |
} |
|
| 98 | ||
| 99 |
# nobs |
|
| 100 | 40x |
if (is.null(wt)) {
|
| 101 | ! |
N <- length(y) |
| 102 |
} else {
|
|
| 103 | 40x |
N <- sum(wt) |
| 104 |
} |
|
| 105 | ||
| 106 | ||
| 107 |
# indices of free parameters |
|
| 108 | 40x |
int.idx <- 1L |
| 109 | 40x |
slope.idx <- seq_len(nexo) + 1L |
| 110 | 40x |
beta.idx <- c(int.idx, slope.idx) |
| 111 | 40x |
var.idx <- 1L + nexo + 1L |
| 112 | ||
| 113 |
# starting values + crossprod |
|
| 114 | 40x |
if (any(is.na(y)) || any(is.na(X1))) {
|
| 115 | 40x |
missing.idx <- which(apply(cbind(y, X1), 1, function(x) any(is.na(x)))) |
| 116 | 40x |
y.tmp <- y[-missing.idx] |
| 117 | 40x |
X1.tmp <- X1[-missing.idx, , drop = FALSE] |
| 118 | 40x |
wt.tmp <- wt[-missing.idx] |
| 119 | 40x |
fit.lm <- stats::lm.wfit(y = y.tmp, x = X1.tmp, w = wt.tmp) |
| 120 | 40x |
theta.evar <- sum(fit.lm$residuals * wt.tmp * fit.lm$residuals) / sum(wt.tmp) |
| 121 | ||
| 122 | 40x |
lav_crossprod <- lav_matrix_crossprod |
| 123 |
} else {
|
|
| 124 | ! |
fit.lm <- stats::lm.wfit(y = y, x = X1, w = wt) |
| 125 | ! |
theta.evar <- sum(fit.lm$residuals * wt * fit.lm$residuals) / sum(wt) |
| 126 | ||
| 127 | ! |
lav_crossprod <- base::crossprod |
| 128 |
} |
|
| 129 | 40x |
theta.beta <- unname(fit.lm$coefficients) |
| 130 | 40x |
theta <- c(theta.beta, theta.evar) |
| 131 | ||
| 132 | 40x |
out <- list2env( |
| 133 | 40x |
list( |
| 134 | 40x |
y = y, X1 = X1, wt = wt, N = N, |
| 135 | 40x |
int.idx = int.idx, beta.idx = beta.idx, |
| 136 | 40x |
var.idx = var.idx, slope.idx = slope.idx, nexo = nexo, |
| 137 | 40x |
lav_crossprod = lav_crossprod, |
| 138 | 40x |
theta = theta |
| 139 |
), |
|
| 140 | 40x |
parent = parent |
| 141 |
) |
|
| 142 | ||
| 143 | 40x |
out |
| 144 |
} |
|
| 145 | ||
| 146 |
# compute total (log)likelihood |
|
| 147 |
lav_uvreg_loglik <- function(y = NULL, |
|
| 148 |
X = NULL, |
|
| 149 |
wt = rep(1, length(y)), |
|
| 150 |
cache = NULL) {
|
|
| 151 | ! |
if (is.null(cache)) {
|
| 152 | ! |
cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache") |
| 153 |
} |
|
| 154 | ! |
lav_uvreg_loglik_cache(cache = cache) |
| 155 |
} |
|
| 156 | ||
| 157 |
lav_uvreg_loglik_cache <- function(cache = NULL) {
|
|
| 158 | 124x |
with(cache, {
|
| 159 |
# free parameters |
|
| 160 | 124x |
beta <- theta[beta.idx] |
| 161 | 124x |
evar <- theta[var.idx] |
| 162 | ||
| 163 | 124x |
yhat <- drop(X1 %*% beta) |
| 164 | 124x |
logliki <- dnorm(y, mean = yhat, sd = sqrt(evar), log = TRUE) |
| 165 | ||
| 166 |
# total weighted log-likelihood |
|
| 167 | 124x |
loglik <- sum(wt * logliki, na.rm = TRUE) |
| 168 | ||
| 169 | 124x |
return(loglik) |
| 170 |
}) |
|
| 171 |
} |
|
| 172 | ||
| 173 |
# casewise scores |
|
| 174 |
lav_uvreg_scores <- function(y = NULL, |
|
| 175 |
X = NULL, |
|
| 176 |
wt = rep(1, length(y)), |
|
| 177 |
cache = NULL) {
|
|
| 178 | 20x |
if (is.null(cache)) {
|
| 179 | 20x |
cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache") |
| 180 |
} |
|
| 181 | 20x |
lav_uvreg_scores_cache(cache = cache) |
| 182 |
} |
|
| 183 | ||
| 184 |
lav_uvreg_scores_cache <- function(cache = NULL) {
|
|
| 185 | 20x |
with(cache, {
|
| 186 | 20x |
res <- y - yhat |
| 187 | 20x |
resw <- res * wt |
| 188 | 20x |
evar2 <- evar * evar |
| 189 | ||
| 190 | 20x |
scores.beta <- 1 / evar * X1 * resw |
| 191 | 20x |
scores.evar <- -wt / (2 * evar) + 1 / (2 * evar2) * res * resw |
| 192 | ||
| 193 | 20x |
return(cbind(scores.beta, scores.evar, deparse.level = 0)) |
| 194 |
}) |
|
| 195 |
} |
|
| 196 | ||
| 197 |
# gradient |
|
| 198 |
lav_uvreg_gradient <- function(y = NULL, |
|
| 199 |
X = NULL, |
|
| 200 |
wt = rep(1, length(y)), |
|
| 201 |
cache = NULL) {
|
|
| 202 | ! |
if (is.null(cache)) {
|
| 203 | ! |
cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache") |
| 204 |
} |
|
| 205 | ! |
lav_uvreg_gradient_cache(cache = cache) |
| 206 |
} |
|
| 207 | ||
| 208 |
lav_uvreg_gradient_cache <- function(cache = NULL) {
|
|
| 209 | 44x |
with(cache, {
|
| 210 | 44x |
res <- y - yhat |
| 211 | 44x |
resw <- res * wt |
| 212 | 44x |
evar2 <- evar * evar |
| 213 | ||
| 214 | 44x |
dx.beta <- colSums(1 / evar * X1 * resw, na.rm = TRUE) |
| 215 | 44x |
dx.var <- sum(-wt / (2 * evar) + 1 / (2 * evar2) * res * resw, na.rm = TRUE) |
| 216 | ||
| 217 | 44x |
return(c(dx.beta, dx.var)) |
| 218 |
}) |
|
| 219 |
} |
|
| 220 | ||
| 221 |
# compute total Hessian |
|
| 222 |
lav_uvreg_hessian <- function(y = NULL, |
|
| 223 |
X = NULL, |
|
| 224 |
wt = rep(1, length(y)), |
|
| 225 |
cache = NULL) {
|
|
| 226 | ! |
if (is.null(cache)) {
|
| 227 | ! |
cache <- lav_uvreg_fit(y = y, X = X, wt = wt, output = "cache") |
| 228 |
} |
|
| 229 | ! |
lav_uvreg_hessian_cache(cache = cache) |
| 230 |
} |
|
| 231 | ||
| 232 |
lav_uvreg_hessian_cache <- function(cache = NULL) {
|
|
| 233 | 44x |
with(cache, {
|
| 234 | 44x |
dx2.beta <- -1 / evar * lav_crossprod(X1 * wt, X1) |
| 235 | 44x |
dx.beta.var <- -1 / (evar2) * lav_crossprod(X1, resw) |
| 236 | ||
| 237 | 44x |
sq.evar <- sqrt(evar) |
| 238 | 44x |
sq.evar6 <- sq.evar * sq.evar * sq.evar * sq.evar * sq.evar * sq.evar |
| 239 | 44x |
dx2.var <- (sum(wt, na.rm = TRUE) / (2 * evar2) - |
| 240 | 44x |
1 / sq.evar6 * sum(resw * res, na.rm = TRUE)) |
| 241 | ||
| 242 | 44x |
Hessian <- rbind(cbind(dx2.beta, dx.beta.var, deparse.level = 0), |
| 243 | 44x |
cbind(t(dx.beta.var), dx2.var, deparse.level = 0), |
| 244 | 44x |
deparse.level = 0 |
| 245 |
) |
|
| 246 | 44x |
return(Hessian) |
| 247 |
}) |
|
| 248 |
} |
|
| 249 | ||
| 250 |
# compute total (log)likelihood, for specific 'x' (nlminb) |
|
| 251 |
lav_uvreg_min_objective <- function(x, cache = NULL) {
|
|
| 252 | 124x |
cache$theta <- x |
| 253 | 124x |
-1 * lav_uvreg_loglik_cache(cache = cache) / cache$N |
| 254 |
} |
|
| 255 | ||
| 256 |
# compute gradient, for specific 'x' (nlminb) |
|
| 257 |
lav_uvreg_min_gradient <- function(x, cache = NULL) {
|
|
| 258 |
# check if x has changed |
|
| 259 | 44x |
if (!all(x == cache$theta)) {
|
| 260 | ! |
cache$theta <- x |
| 261 | ! |
tmp <- lav_uvreg_loglik_cache(cache = cache) |
| 262 |
} |
|
| 263 | 44x |
-1 * lav_uvreg_gradient_cache(cache = cache) / cache$N |
| 264 |
} |
|
| 265 | ||
| 266 |
# compute hessian, for specific 'x' (nlminb) |
|
| 267 |
lav_uvreg_min_hessian <- function(x, cache = NULL) {
|
|
| 268 |
# check if x has changed |
|
| 269 | 44x |
if (!all(x == cache$theta)) {
|
| 270 | ! |
cache$theta <- x |
| 271 | ! |
tmp <- lav_uvreg_loglik_cache(cache = cache) |
| 272 | ! |
tmp <- lav_uvreg_gradient_cache(cache = cache) |
| 273 |
} |
|
| 274 | 44x |
-1 * lav_uvreg_hessian_cache(cache = cache) / cache$N |
| 275 |
} |
|
| 276 | ||
| 277 |
# update fit object with new parameters |
|
| 278 |
lav_uvreg_update_fit <- function(fit.y = NULL, |
|
| 279 |
evar.new = NULL, beta.new = NULL) {
|
|
| 280 | 80x |
if (is.null(evar.new) && is.null(beta.new)) {
|
| 281 | 80x |
return(fit.y) |
| 282 |
} |
|
| 283 | ||
| 284 | ! |
if (!is.null(evar.new)) {
|
| 285 | ! |
fit.y$theta[fit.y$var.idx] <- evar.new |
| 286 |
} |
|
| 287 | ! |
if (!is.null(beta.new)) {
|
| 288 | ! |
fit.y$theta[fit.y$beta.idx] <- beta.new |
| 289 |
} |
|
| 290 | ||
| 291 | ! |
beta <- fit.y$theta[fit.y$beta.idx] |
| 292 | ! |
X <- fit.y$X |
| 293 | ! |
X1 <- cbind(1, X, deparse.level = 0) |
| 294 | ||
| 295 | ! |
fit.y$yhat <- drop(X1 %*% beta) |
| 296 | ||
| 297 | ! |
fit.y |
| 298 |
} |
| 1 |
# EFA: exploratory factor analysis |
|
| 2 |
# |
|
| 3 |
# EFA is implemented as a special version of ESEM |
|
| 4 |
# - it is therefore a wrapper around the lavaan() function to simplify |
|
| 5 |
# the input |
|
| 6 |
# - a lavaan model is generated with a single 'block' that can be rotated |
|
| 7 |
# - the 'default' output produces output that is more in line with traditional |
|
| 8 |
# EFA software (in R) like factanal() and fa() from the psych package |
|
| 9 | ||
| 10 |
# YR 20 Sept 2022 - first version |
|
| 11 | ||
| 12 |
efa <- function(data = NULL, |
|
| 13 |
nfactors = 1L, |
|
| 14 |
sample.cov = NULL, |
|
| 15 |
sample.nobs = NULL, |
|
| 16 |
rotation = "geomin", |
|
| 17 |
rotation.args = list(), |
|
| 18 |
ov.names = NULL, |
|
| 19 |
bounds = "pos.var", |
|
| 20 |
..., |
|
| 21 |
output = "efa") {
|
|
| 22 |
# rotation.args deprecation handling |
|
| 23 | 1x |
if (!missing(rotation.args)) {
|
| 24 | ! |
lav_deprecated_args("rotation", "rotation.args")
|
| 25 |
} |
|
| 26 | 1x |
if (is.list(rotation)) {
|
| 27 | ! |
rotation.args <- modifyList(list(), rotation) |
| 28 | ! |
rotation <- rotation[[1L]] |
| 29 |
} |
|
| 30 | ||
| 31 |
# handle dotdotdot |
|
| 32 | 1x |
dotdotdot <- list(...) |
| 33 | ||
| 34 |
# twolevel? |
|
| 35 | 1x |
twolevel.flag <- !is.null(dotdotdot$cluster) |
| 36 | ||
| 37 |
# sampling weights? |
|
| 38 | 1x |
sampling.weights.flag <- !is.null(dotdotdot$sampling.weights) |
| 39 | ||
| 40 |
# check for unallowed arguments |
|
| 41 | 1x |
if (!is.null(dotdotdot$group)) {
|
| 42 | ! |
lav_msg_stop(gettext("efa has no support for multiple groups (for now);
|
| 43 | ! |
consider using the cfa() function in combination |
| 44 | ! |
with the efa() modifier.")) |
| 45 |
} |
|
| 46 |
#if (!is.null(dotdotdot$sampling.weights)) {
|
|
| 47 |
# lav_msg_stop(gettext("efa has no support for sampling weights (for now);
|
|
| 48 |
# consider using the cfa() function in combination |
|
| 49 |
# with the efa() modifier.")) |
|
| 50 |
#} |
|
| 51 | ||
| 52 |
# if data= argument is used, convert to data.frame (eg matrix, tibble, ...) |
|
| 53 | 1x |
if (!is.null(data) && !inherits(data, "lavMoments")) {
|
| 54 | 1x |
data <- as.data.frame(data) |
| 55 |
} |
|
| 56 | ||
| 57 |
# handle ov.names |
|
| 58 | 1x |
if (!is.null(data) && inherits(data, "lavMoments")) {
|
| 59 | ! |
if ("sample.cov" %in% names(data)) {
|
| 60 | ! |
ov.names <- rownames(data$sample.cov) |
| 61 | ! |
if (is.null(ov.names)) {
|
| 62 | ! |
ov.names <- colnames(data$sample.cov) |
| 63 |
} |
|
| 64 |
} else {
|
|
| 65 | ! |
lav_msg_stop(gettext( |
| 66 | ! |
"When data= is of class lavMoments, it must contain sample.cov")) |
| 67 |
} |
|
| 68 | ||
| 69 | 1x |
} else if (!is.null(data) && inherits(data, "data.frame")) {
|
| 70 | 1x |
if (length(ov.names) > 0L) {
|
| 71 | ! |
NAMES <- ov.names |
| 72 | ! |
if (twolevel.flag) {
|
| 73 | ! |
NAMES <- c(NAMES, dotdotdot$cluster) |
| 74 |
} |
|
| 75 | ! |
if (sampling.weights.flag) {
|
| 76 | ! |
NAMES <- c(NAMES, dotdotdot$sampling.weights) |
| 77 |
} |
|
| 78 | ! |
data <- data[, NAMES, drop = FALSE] |
| 79 |
} else {
|
|
| 80 | 1x |
ov.names <- names(data) |
| 81 | 1x |
if (twolevel.flag) {
|
| 82 | ! |
ov.names <- ov.names[-which(ov.names == dotdotdot$cluster)] |
| 83 |
} |
|
| 84 | 1x |
if( sampling.weights.flag) {
|
| 85 | ! |
ov.names <- ov.names[-which(ov.names == dotdotdot$sampling.weights)] |
| 86 |
} |
|
| 87 |
} |
|
| 88 | ! |
} else if (!is.null(sample.cov)) {
|
| 89 | ! |
ov.names <- rownames(sample.cov) |
| 90 | ! |
if (is.null(ov.names)) {
|
| 91 | ! |
ov.names <- colnames(sample.cov) |
| 92 |
} |
|
| 93 |
} |
|
| 94 |
# ov.names? |
|
| 95 | 1x |
if (length(ov.names) == 0L) {
|
| 96 | ! |
lav_msg_stop(gettext( |
| 97 | ! |
"could not extract variable names from data or sample.cov")) |
| 98 |
} |
|
| 99 | ||
| 100 |
# check nfactors |
|
| 101 | 1x |
if (any(nfactors < 1L)) {
|
| 102 | ! |
lav_msg_stop(gettext("nfactors must be greater than zero."))
|
| 103 |
} else {
|
|
| 104 |
# check for maximum number of factors |
|
| 105 |
# Fixme: can we do this more efficiently? also holds for categorical? |
|
| 106 | 1x |
nvar <- length(ov.names) |
| 107 | 1x |
p.star <- nvar * (nvar + 1) / 2 |
| 108 | 1x |
nfac.max <- 0L |
| 109 | 1x |
for (nfac in seq_len(nvar)) {
|
| 110 |
# compute number of free parameters |
|
| 111 | 8x |
npar <- nfac * nvar + nfac * (nfac + 1L) / 2 + nvar - nfac^2 |
| 112 | 8x |
if (npar > p.star) {
|
| 113 | 1x |
nfac.max <- nfac - 1L |
| 114 | 1x |
break |
| 115 |
} |
|
| 116 |
} |
|
| 117 | 1x |
if (any(nfactors > nfac.max)) {
|
| 118 | ! |
lav_msg_stop(gettextf("when nvar = %1$s the maximum number of factors
|
| 119 | ! |
is %2$s", nvar, nfac.max)) |
| 120 |
} |
|
| 121 |
} |
|
| 122 | ||
| 123 |
# output |
|
| 124 | 1x |
output <- tolower(output) |
| 125 | 1x |
if (!output %in% c("lavaan", "efa")) {
|
| 126 | ! |
lav_msg_stop(gettext("output= must be either \"lavaan\" or \"efa\""))
|
| 127 |
} |
|
| 128 | 1x |
if (output == "lavaan" && length(nfactors) > 1L) {
|
| 129 | ! |
lav_msg_stop(gettext("when output = \"lavaan\", nfactors must be a
|
| 130 | ! |
single (integer) number.")) |
| 131 |
} |
|
| 132 | ||
| 133 |
# fit models |
|
| 134 | 1x |
nfits <- length(nfactors) |
| 135 | 1x |
out <- vector("list", length = nfits)
|
| 136 | 1x |
for (f in seq_len(nfits)) {
|
| 137 |
# generate model syntax |
|
| 138 | 4x |
model.syntax <- lav_syntax_efa( |
| 139 | 4x |
ov.names = ov.names, |
| 140 | 4x |
nfactors = nfactors[f], |
| 141 | 4x |
twolevel = twolevel.flag |
| 142 |
) |
|
| 143 |
# call lavaan (using sem()) |
|
| 144 | 4x |
FIT <- do.call("sem",
|
| 145 | 4x |
args = c( |
| 146 | 4x |
list( |
| 147 | 4x |
model = model.syntax, |
| 148 | 4x |
data = data, |
| 149 | 4x |
sample.cov = sample.cov, |
| 150 | 4x |
sample.nobs = sample.nobs, |
| 151 | 4x |
rotation = rotation, |
| 152 | 4x |
rotation.args = rotation.args, |
| 153 | 4x |
bounds = bounds |
| 154 |
), |
|
| 155 | 4x |
dotdotdot |
| 156 |
) |
|
| 157 |
) |
|
| 158 | ||
| 159 | 4x |
if (output == "efa") {
|
| 160 | 4x |
FIT@Options$model.type <- "efa" |
| 161 |
} |
|
| 162 | ||
| 163 | 4x |
out[[f]] <- FIT |
| 164 |
} |
|
| 165 | ||
| 166 |
# class |
|
| 167 | 1x |
if (nfits == 1L && output == "lavaan") {
|
| 168 | ! |
out <- out[[1]] |
| 169 |
} else {
|
|
| 170 | 1x |
names(out) <- paste0("nf", nfactors)
|
| 171 |
# add loadings element to the end of the list |
|
| 172 |
# so we an use the non-generic but useful loadings() function |
|
| 173 |
# from the stats package |
|
| 174 | 1x |
out$loadings <- lav_efa_get_loadings(out) |
| 175 | 1x |
class(out) <- c("efaList", "list")
|
| 176 |
} |
|
| 177 | ||
| 178 | 1x |
out |
| 179 |
} |
| 1 |
# for blavaan |
|
| 2 |
# TDJ: add "..." to make the generic actually generic, for lavaan.mi objects |
|
| 3 | ||
| 4 |
# S3 generic for S3 dispatch |
|
| 5 |
fitMeasures <- function(object, fit.measures = "all", |
|
| 6 |
baseline.model = NULL, h1.model = NULL, |
|
| 7 |
fm.args = list( |
|
| 8 |
standard.test = "default", |
|
| 9 |
scaled.test = "default", |
|
| 10 |
rmsea.ci.level = 0.90, |
|
| 11 |
rmsea.close.h0 = 0.05, |
|
| 12 |
rmsea.notclose.h0 = 0.08, |
|
| 13 |
robust = TRUE, |
|
| 14 |
cat.check.pd = TRUE |
|
| 15 |
), |
|
| 16 |
output = "vector", ...) {
|
|
| 17 | 1x |
UseMethod("fitMeasures", object)
|
| 18 |
} |
|
| 19 |
fitmeasures <- function(object, fit.measures = "all", |
|
| 20 |
baseline.model = NULL, h1.model = NULL, |
|
| 21 |
fm.args = list( |
|
| 22 |
standard.test = "default", |
|
| 23 |
scaled.test = "default", |
|
| 24 |
rmsea.ci.level = 0.90, |
|
| 25 |
rmsea.close.h0 = 0.05, |
|
| 26 |
rmsea.notclose.h0 = 0.08, |
|
| 27 |
robust = TRUE, |
|
| 28 |
cat.check.pd = TRUE |
|
| 29 |
), |
|
| 30 |
output = "vector", ...) {
|
|
| 31 | ! |
UseMethod("fitmeasures", object)
|
| 32 |
} |
|
| 33 | ||
| 34 | ||
| 35 |
# S4 generic for S4 dispatch |
|
| 36 |
setGeneric( |
|
| 37 |
"fitMeasures", |
|
| 38 |
function(object, fit.measures = "all", |
|
| 39 |
baseline.model = NULL, h1.model = NULL, |
|
| 40 |
fm.args = list( |
|
| 41 |
standard.test = "default", |
|
| 42 |
scaled.test = "default", |
|
| 43 |
rmsea.ci.level = 0.90, |
|
| 44 |
rmsea.close.h0 = 0.05, |
|
| 45 |
rmsea.notclose.h0 = 0.08, |
|
| 46 |
robust = TRUE, |
|
| 47 |
cat.check.pd = TRUE |
|
| 48 |
), |
|
| 49 |
output = "vector", ...) {
|
|
| 50 | 61x |
standardGeneric("fitMeasures")
|
| 51 |
} |
|
| 52 |
) |
|
| 53 |
setGeneric( |
|
| 54 |
"fitmeasures", |
|
| 55 |
function(object, fit.measures = "all", |
|
| 56 |
baseline.model = NULL, h1.model = NULL, |
|
| 57 |
fm.args = list( |
|
| 58 |
standard.test = "default", |
|
| 59 |
scaled.test = "default", |
|
| 60 |
rmsea.ci.level = 0.90, |
|
| 61 |
rmsea.close.h0 = 0.05, |
|
| 62 |
rmsea.notclose.h0 = 0.08, |
|
| 63 |
robust = TRUE, |
|
| 64 |
cat.check.pd = TRUE |
|
| 65 |
), |
|
| 66 |
output = "vector", ...) {
|
|
| 67 | ! |
standardGeneric("fitmeasures")
|
| 68 |
} |
|
| 69 |
) |
|
| 70 | ||
| 71 | ||
| 72 |
# S3 generics |
|
| 73 |
lavInspect <- function(object, what = "free", |
|
| 74 |
add.labels = TRUE, |
|
| 75 |
add.class = TRUE, |
|
| 76 |
list.by.group = TRUE, |
|
| 77 |
drop.list.single.group = TRUE) {
|
|
| 78 | 705x |
UseMethod("lavInspect", object)
|
| 79 |
} |
|
| 80 | ||
| 81 |
inspect <- function(object, what = "free", ...) {
|
|
| 82 | ! |
UseMethod("inspect", object)
|
| 83 |
} |
|
| 84 | ||
| 85 |
lavTech <- function(object, what = "free", |
|
| 86 |
add.labels = FALSE, |
|
| 87 |
add.class = FALSE, |
|
| 88 |
list.by.group = FALSE, |
|
| 89 |
drop.list.single.group = FALSE) {
|
|
| 90 | 212x |
UseMethod("lavTech", object)
|
| 91 |
} |
| 1 |
# print only (standardized) loadings |
|
| 2 |
lav_efa_print <- function(x, nd = 3L, cutoff = 0.3, |
|
| 3 |
dot.cutoff = 0.1, alpha.level = 0.01, ...) {
|
|
| 4 |
# unclass |
|
| 5 | ! |
y <- unclass(x) |
| 6 | ||
| 7 | ! |
if (!y$header$optim.converged) {
|
| 8 | ! |
cat("** WARNING ** Optimizer did not end normally\n")
|
| 9 | ! |
cat("** WARNING ** Estimates below are most likely unreliable\n")
|
| 10 |
} |
|
| 11 | ||
| 12 |
# loadings per block |
|
| 13 | ! |
for (b in seq_len(y$efa$nblocks)) {
|
| 14 | ! |
cat("\n")
|
| 15 | ! |
if (length(y$efa$block.label) > 0L) {
|
| 16 | ! |
cat(y$efa$block.label[[b]], ":\n\n", sep = "") |
| 17 |
} |
|
| 18 | ! |
LAMBDA <- unclass(y$efa$lambda[[b]]) |
| 19 | ! |
lav_print_loadings(LAMBDA, |
| 20 | ! |
nd = nd, cutoff = cutoff, |
| 21 | ! |
dot.cutoff = dot.cutoff, |
| 22 | ! |
alpha.level = alpha.level, |
| 23 | ! |
x.se = y$efa$lambda.se[[b]] |
| 24 |
) |
|
| 25 | ! |
cat("\n")
|
| 26 |
} |
|
| 27 | ||
| 28 | ! |
invisible(LAMBDA) |
| 29 |
} |
|
| 30 | ||
| 31 |
# print efaList |
|
| 32 |
lav_efalist_print <- function(x, nd = 3L, cutoff = 0.3, |
|
| 33 |
dot.cutoff = 0.1, alpha.level = 0.01, ...) {
|
|
| 34 |
# unclass |
|
| 35 | ! |
y <- unclass(x) |
| 36 | ||
| 37 |
# kill loadings element if present |
|
| 38 | ! |
y[["loadings"]] <- NULL |
| 39 | ||
| 40 | ! |
nfits <- length(y) |
| 41 | ! |
RES <- vector("list", nfits)
|
| 42 | ! |
for (ff in seq_len(nfits)) {
|
| 43 | ! |
res <- lav_object_summary(y[[ff]], |
| 44 | ! |
fit.measures = FALSE, |
| 45 | ! |
estimates = FALSE, |
| 46 | ! |
modindices = FALSE, |
| 47 | ! |
efa = TRUE, |
| 48 | ! |
efa.args = list( |
| 49 | ! |
lambda = TRUE, |
| 50 | ! |
theta = FALSE, |
| 51 | ! |
psi = FALSE, |
| 52 | ! |
eigenvalues = FALSE, |
| 53 | ! |
sumsq.table = FALSE, |
| 54 | ! |
lambda.structure = FALSE, |
| 55 | ! |
fs.determinacy = FALSE, |
| 56 | ! |
se = FALSE, |
| 57 | ! |
zstat = FALSE, |
| 58 | ! |
pvalue = FALSE |
| 59 |
) |
|
| 60 |
) |
|
| 61 | ! |
RES[[ff]] <- lav_efa_print(res, |
| 62 | ! |
nd = nd, cutoff = cutoff, |
| 63 | ! |
dot.cutoff = dot.cutoff, |
| 64 | ! |
alpha.level = alpha.level, ... |
| 65 |
) |
|
| 66 |
} |
|
| 67 | ||
| 68 | ! |
invisible(RES) |
| 69 |
} |
|
| 70 | ||
| 71 | ||
| 72 |
# print summary efaList |
|
| 73 |
lav_efalist_summary_print <- function(x, nd = 3L, cutoff = 0.3, |
|
| 74 |
dot.cutoff = 0.1, alpha.level = 0.01, |
|
| 75 |
...) {
|
|
| 76 |
# unclass |
|
| 77 | 1x |
y <- unclass(x) |
| 78 | ||
| 79 |
# get nd, if it is stored as an attribute |
|
| 80 | 1x |
ND <- attr(y, "nd") |
| 81 | 1x |
if (!is.null(ND) && is.numeric(ND)) {
|
| 82 | 1x |
nd <- as.integer(ND) |
| 83 |
} |
|
| 84 |
# get cutoff, if it is stored as an attribute |
|
| 85 | 1x |
CT <- attr(y, "cutoff") |
| 86 | 1x |
if (!is.null(CT) && is.numeric(CT)) {
|
| 87 | 1x |
cutoff <- CT |
| 88 |
} |
|
| 89 |
# get dot.cutoff, if it is stored as an attribute |
|
| 90 | 1x |
DC <- attr(y, "dot.cutoff") |
| 91 | 1x |
if (!is.null(DC) && is.numeric(DC)) {
|
| 92 | 1x |
dot.cutoff <- DC |
| 93 |
} |
|
| 94 |
# get alpha.level, if it is stored as an attribute |
|
| 95 | 1x |
AL <- attr(y, "alpha.level") |
| 96 | 1x |
if (!is.null(AL) && is.numeric(AL)) {
|
| 97 | 1x |
alpha.level <- AL |
| 98 |
} |
|
| 99 | ||
| 100 | 1x |
cat("This is ",
|
| 101 | 1x |
sprintf("lavaan %s", x$lavaan.version),
|
| 102 | 1x |
" -- running exploratory factor analysis\n", |
| 103 | 1x |
sep = "" |
| 104 |
) |
|
| 105 | ||
| 106 |
# everything converged? |
|
| 107 | 1x |
if (!x$converged.flag) {
|
| 108 | ! |
cat("lavaan WARNING: not all models did converge!\n")
|
| 109 |
} |
|
| 110 | 1x |
cat("\n")
|
| 111 | ||
| 112 | ||
| 113 |
# estimator |
|
| 114 | 1x |
c1 <- c("Estimator")
|
| 115 |
# second column |
|
| 116 | 1x |
tmp.est <- toupper(x$estimator) |
| 117 | 1x |
if (tmp.est == "DLS") {
|
| 118 | ! |
dls.first.letter <- substr( |
| 119 | ! |
x$estimator.args$dls.GammaNT, |
| 120 | ! |
1L, 1L |
| 121 |
) |
|
| 122 | ! |
tmp.est <- paste("DLS-", toupper(dls.first.letter), sep = "")
|
| 123 |
} |
|
| 124 | 1x |
c2 <- tmp.est |
| 125 | ||
| 126 |
# additional estimator args |
|
| 127 | 1x |
if (!is.null(x$estimator.args) && |
| 128 | 1x |
length(x$estimator.args) > 0L) {
|
| 129 | ! |
if (x$estimator == "DLS") {
|
| 130 | ! |
c1 <- c(c1, "Estimator DLS value for a") |
| 131 | ! |
c2 <- c(c2, x$estimator.args$dls.a) |
| 132 |
} |
|
| 133 |
} |
|
| 134 | ||
| 135 |
# rotation method |
|
| 136 | 1x |
c1 <- c(c1, "Rotation method") |
| 137 | 1x |
if (x$rotation == "none") {
|
| 138 | ! |
MM <- toupper(x$rotation) |
| 139 | 1x |
} else if (x$rotation.args$orthogonal) {
|
| 140 | ! |
MM <- paste(toupper(x$rotation), " ", "ORTHOGONAL", |
| 141 | ! |
sep = "" |
| 142 |
) |
|
| 143 |
} else {
|
|
| 144 | 1x |
MM <- paste(toupper(x$rotation), " ", "OBLIQUE", |
| 145 | 1x |
sep = "" |
| 146 |
) |
|
| 147 |
} |
|
| 148 | 1x |
c2 <- c(c2, MM) |
| 149 | ||
| 150 | 1x |
if (x$rotation != "none") {
|
| 151 |
# method options |
|
| 152 | 1x |
if (x$rotation == "geomin") {
|
| 153 | 1x |
c1 <- c(c1, "Geomin epsilon") |
| 154 | 1x |
c2 <- c(c2, x$rotation.args$geomin.epsilon) |
| 155 | ! |
} else if (x$rotation == "orthomax") {
|
| 156 | ! |
c1 <- c(c1, "Orthomax gamma") |
| 157 | ! |
c2 <- c(c2, x$rotation.args$orthomax.gamma) |
| 158 | ! |
} else if (x$rotation == "cf") {
|
| 159 | ! |
c1 <- c(c1, "Crawford-Ferguson gamma") |
| 160 | ! |
c2 <- c(c2, x$rotation.args$cf.gamma) |
| 161 | ! |
} else if (x$rotation == "oblimin") {
|
| 162 | ! |
c1 <- c(c1, "Oblimin gamma") |
| 163 | ! |
c2 <- c(c2, x$rotation.args$oblimin.gamma) |
| 164 | ! |
} else if (x$rotation == "promax") {
|
| 165 | ! |
c1 <- c(c1, "Promax kappa") |
| 166 | ! |
c2 <- c(c2, x$rotation.args$promax.kappa) |
| 167 |
} |
|
| 168 | ||
| 169 |
# rotation algorithm |
|
| 170 | 1x |
c1 <- c(c1, "Rotation algorithm (rstarts)") |
| 171 | 1x |
tmp <- paste(toupper(x$rotation.args$algorithm), |
| 172 | 1x |
" (", x$rotation.args$rstarts, ")",
|
| 173 | 1x |
sep = "" |
| 174 |
) |
|
| 175 | 1x |
c2 <- c(c2, tmp) |
| 176 | ||
| 177 |
# Standardized metric (or not) |
|
| 178 | 1x |
c1 <- c(c1, "Standardized metric") |
| 179 | 1x |
if (x$rotation.args$std.ov) {
|
| 180 | 1x |
c2 <- c(c2, "TRUE") |
| 181 |
} else {
|
|
| 182 | ! |
c2 <- c(c2, "FALSE") |
| 183 |
} |
|
| 184 | ||
| 185 |
# Row weights |
|
| 186 | 1x |
c1 <- c(c1, "Row weights") |
| 187 | 1x |
tmp.txt <- x$rotation.args$row.weights |
| 188 | 1x |
c2 <- c(c2, paste(toupper(substring(tmp.txt, 1, 1)), |
| 189 | 1x |
substring(tmp.txt, 2), |
| 190 | 1x |
sep = "" |
| 191 |
)) |
|
| 192 |
} |
|
| 193 | ||
| 194 |
# format c1/c2 |
|
| 195 | 1x |
c1 <- format(c1, width = 33L) |
| 196 | 1x |
c2 <- format(c2, |
| 197 | 1x |
width = 18L + max(0, (nd - 3L)) * 4L, |
| 198 | 1x |
justify = "right" |
| 199 |
) |
|
| 200 | ||
| 201 |
# create character matrix |
|
| 202 | 1x |
M <- cbind(c1, c2, deparse.level = 0) |
| 203 | 1x |
colnames(M) <- rep("", ncol(M))
|
| 204 | 1x |
rownames(M) <- rep(" ", nrow(M))
|
| 205 | ||
| 206 |
|
|
| 207 | 1x |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 208 | ||
| 209 |
# data |
|
| 210 | 1x |
if (!is.null(x$lavdata)) {
|
| 211 | 1x |
cat("\n")
|
| 212 | 1x |
lav_data_print_short(x$lavdata, nd = nd) |
| 213 |
} |
|
| 214 | ||
| 215 |
# number of models |
|
| 216 | 1x |
nfits <- length(x$model.list) |
| 217 | ||
| 218 |
# number of factors |
|
| 219 | 1x |
nfactors <- x$nfactors |
| 220 | ||
| 221 |
# fit measures |
|
| 222 | 1x |
if (!is.null(x$fit.table)) {
|
| 223 | 1x |
cat("\n")
|
| 224 | 1x |
if (nfits > 1L) {
|
| 225 | 1x |
cat("Overview models:\n")
|
| 226 |
} else {
|
|
| 227 | ! |
cat("Fit measures:\n")
|
| 228 |
} |
|
| 229 | 1x |
print(x$fit.table, nd = nd, shift = 2L) |
| 230 |
} |
|
| 231 | ||
| 232 |
# eigenvalues |
|
| 233 | 1x |
if (!is.null(x$model.list[[1]]$efa$eigvals[[1]])) {
|
| 234 | 1x |
cat("\n")
|
| 235 | 1x |
if (x$model.list[[1]]$efa$std.ov) {
|
| 236 | 1x |
cat("Eigenvalues correlation matrix:\n")
|
| 237 |
} else {
|
|
| 238 | ! |
cat("Eigenvalues covariance matrix:\n")
|
| 239 |
} |
|
| 240 | 1x |
for (b in seq_len(x$model.list[[1]]$efa$nblocks)) {
|
| 241 | 1x |
cat("\n")
|
| 242 | 1x |
if (length(x$model.list[[1]]$efa$block.label) > 0L) {
|
| 243 | ! |
cat(x$model.list[[1]]$efa$block.label[[b]], ":\n\n", sep = "") |
| 244 |
} |
|
| 245 | 1x |
print(x$model.list[[1]]$efa$eigvals[[b]], nd = nd, shift = 2L) |
| 246 |
} # blocks |
|
| 247 |
} |
|
| 248 | ||
| 249 |
# print summary for each model |
|
| 250 | 1x |
for (f in seq_len(nfits)) {
|
| 251 | 4x |
res <- x$model.list[[f]] |
| 252 | 4x |
attr(res, "nd") <- nd |
| 253 | 4x |
attr(res, "cutoff") <- cutoff |
| 254 | 4x |
attr(res, "dot.cutoff") <- dot.cutoff |
| 255 | 4x |
attr(res, "alpha.level") <- alpha.level |
| 256 | ||
| 257 | 4x |
if (nfits > 1L) {
|
| 258 | 4x |
if (f == 1L) {
|
| 259 | 1x |
cat("\n")
|
| 260 |
} |
|
| 261 | 4x |
cat("Number of factors: ", nfactors[f], "\n")
|
| 262 |
} |
|
| 263 |
# lav_summary_print() prints the $efa element (only) or res |
|
| 264 | 4x |
print(res) |
| 265 |
} |
|
| 266 | ||
| 267 | 1x |
invisible(y) |
| 268 |
} |
| 1 |
# the Multivariate normal distribution, unrestricted (h1), missing values |
|
| 2 | ||
| 3 |
# 1) loglikelihood --> same as h0 but where Mu and Sigma are unrestricted |
|
| 4 |
# 2) 3) 4) 5) --> (idem) |
|
| 5 | ||
| 6 |
# YR 26 Mar 2016: first version |
|
| 7 |
# YR 20 Jan 2017: added _h1_omega_sw() |
|
| 8 | ||
| 9 |
# here, we estimate Mu and Sigma from Y with missing values, assuming normality |
|
| 10 |
# this is a rewrite of the 'estimate.moments.EM' function in <= 0.5-22 |
|
| 11 |
lav_mvnorm_missing_h1_estimate_moments <- function(Y = NULL, |
|
| 12 |
Mp = NULL, |
|
| 13 |
Yp = NULL, |
|
| 14 |
wt = NULL, |
|
| 15 |
Sinv.method = "eigen", |
|
| 16 |
max.iter = 500L, |
|
| 17 |
tol = 1e-05) {
|
|
| 18 |
# check input |
|
| 19 | 8x |
Y <- as.matrix(Y) |
| 20 | 8x |
P <- NCOL(Y) |
| 21 | 8x |
if (!is.null(wt)) {
|
| 22 | ! |
N <- sum(wt) |
| 23 |
} else {
|
|
| 24 | 8x |
N <- NROW(Y) |
| 25 |
} |
|
| 26 | ||
| 27 |
# missing patterns |
|
| 28 | 8x |
if (is.null(Mp)) {
|
| 29 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 30 |
} |
|
| 31 | 8x |
if (is.null(Yp)) {
|
| 32 | ! |
Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt) |
| 33 |
} |
|
| 34 | ||
| 35 |
# covariances with zero coverage (perhaps planned?) |
|
| 36 | 8x |
zero.coverage.flag <- FALSE |
| 37 | 8x |
zero.coverage.idx <- which(Mp$coverage == 0) # as a vector |
| 38 | 8x |
if (length(zero.coverage.idx) > 0L) {
|
| 39 | ! |
zero.coverage.flag <- TRUE |
| 40 |
# this is a problem; the current implementation of the E-step does not |
|
| 41 |
# take this into account; for now, we need to switch to nlminb() instead |
|
| 42 | ! |
lav_msg_warn( |
| 43 | ! |
gettext("some covariances have zero coverage; the current implementation
|
| 44 | ! |
of the EM algorithm will ignore this!")) |
| 45 |
} |
|
| 46 | ||
| 47 | 8x |
if (is.null(max.iter)) {
|
| 48 | ! |
max.iter <- 500L |
| 49 |
} |
|
| 50 | 8x |
if (is.null(tol)) {
|
| 51 | ! |
tol <- 1e-05 |
| 52 |
} |
|
| 53 | ||
| 54 |
# remove empty cases |
|
| 55 | 8x |
N.full <- N |
| 56 | 8x |
if (length(Mp$empty.idx) > 0L) {
|
| 57 | ! |
if (!is.null(wt)) {
|
| 58 | ! |
N <- N - sum(wt[Mp$empty.idx]) |
| 59 |
} else {
|
|
| 60 | ! |
N <- N - length(Mp$empty.idx) |
| 61 |
} |
|
| 62 |
} |
|
| 63 | ||
| 64 |
# verbose? |
|
| 65 | 8x |
if (lav_verbose()) {
|
| 66 | ! |
cat("\n")
|
| 67 | ! |
cat("lav_mvnorm_missing_h1_estimate_moments: start EM steps\n")
|
| 68 |
} |
|
| 69 | ||
| 70 |
# starting values; zero covariances to guarantee a pd matrix |
|
| 71 | 8x |
if (!is.null(wt)) {
|
| 72 | ! |
tmp <- na.omit(cbind(wt, Y)) |
| 73 | ! |
if (nrow(tmp) > 2L) {
|
| 74 | ! |
Y.tmp <- tmp[, -1, drop = FALSE] |
| 75 | ! |
wt.tmp <- tmp[, 1] |
| 76 | ! |
out <- stats::cov.wt(Y.tmp, wt = wt.tmp, method = "ML") |
| 77 | ! |
Mu0 <- out$center |
| 78 | ! |
var0 <- diag(out$cov) |
| 79 |
} else {
|
|
| 80 | ! |
Mu0 <- base::.colMeans(Y, m = N.full, n = P, na.rm = TRUE) |
| 81 | ! |
Yc <- t(t(Y) - Mu0) |
| 82 | ! |
var0 <- base::.colMeans(Yc * Yc, m = N.full, n = P, na.rm = TRUE) |
| 83 |
} |
|
| 84 |
} else {
|
|
| 85 | 8x |
Mu0 <- base::.colMeans(Y, m = N.full, n = P, na.rm = TRUE) |
| 86 | 8x |
Yc <- t(t(Y) - Mu0) |
| 87 | 8x |
var0 <- base::.colMeans(Yc * Yc, m = N.full, n = P, na.rm = TRUE) |
| 88 |
} |
|
| 89 |
# sanity check |
|
| 90 | 8x |
bad.idx <- which(!is.finite(var0) | var0 == 0) |
| 91 | 8x |
if (length(bad.idx) > 0L) {
|
| 92 | ! |
var0[bad.idx] <- 1 |
| 93 |
} |
|
| 94 | 8x |
bad.idx <- which(!is.finite(Mu0)) |
| 95 | 8x |
if (length(bad.idx) > 0L) {
|
| 96 | ! |
Mu0[bad.idx] <- 0 |
| 97 |
} |
|
| 98 | 8x |
Sigma0 <- diag(x = var0, nrow = P) |
| 99 | 8x |
Mu <- Mu0 |
| 100 | 8x |
Sigma <- Sigma0 |
| 101 | ||
| 102 |
# report |
|
| 103 | 8x |
if (lav_verbose()) {
|
| 104 |
# fx0 <- lav_model_objective_fiml(Sigma.hat=Sigma, Mu.hat=Mu, M=Yp) |
|
| 105 | ! |
fx0 <- lav_mvnorm_missing_loglik_samplestats( |
| 106 | ! |
Yp = Yp, |
| 107 | ! |
Mu = Mu, Sigma = Sigma, |
| 108 | ! |
log2pi = FALSE, |
| 109 | ! |
minus.two = TRUE |
| 110 | ! |
) / N |
| 111 | ! |
cat( |
| 112 | ! |
" EM iteration:", sprintf("%4d", 0),
|
| 113 | ! |
" fx = ", sprintf("%15.10f", fx0),
|
| 114 | ! |
"\n" |
| 115 |
) |
|
| 116 |
} |
|
| 117 | ||
| 118 |
# EM steps |
|
| 119 | 8x |
for (i in 1:max.iter) {
|
| 120 |
# E-step |
|
| 121 | 36x |
Estep <- lav_mvnorm_missing_estep( |
| 122 | 36x |
Y = Y, Mp = Mp, wt = wt, |
| 123 | 36x |
Mu = Mu, Sigma = Sigma, |
| 124 | 36x |
Sinv.method = Sinv.method |
| 125 |
) |
|
| 126 | 36x |
T1 <- Estep$T1 |
| 127 | 36x |
T2 <- Estep$T2 |
| 128 | ||
| 129 |
# M-step |
|
| 130 | 36x |
Mu <- T1 / N |
| 131 | 36x |
Sigma <- T2 / N - tcrossprod(Mu) |
| 132 | ||
| 133 |
# check if Sigma is near-pd (+ poor fix) |
|
| 134 | 36x |
ev <- eigen(Sigma, symmetric = TRUE, only.values = TRUE) |
| 135 | 36x |
evtol <- 1e-6 # FIXME! |
| 136 | 36x |
if (any(ev$values < evtol)) {
|
| 137 |
# too.small <- which( ev$values < tol ) |
|
| 138 |
# ev$values[too.small] <- tol |
|
| 139 |
# ev$values <- ev$values + tol |
|
| 140 |
# Sigma <- ev$vectors %*% diag(ev$values) %*% t(ev$vectors) |
|
| 141 | ||
| 142 |
# ridge |
|
| 143 | ! |
diag(Sigma) <- diag(Sigma) + max(diag(Sigma)) * 1e-08 |
| 144 |
} |
|
| 145 | ||
| 146 |
# max absolute difference in parameter values |
|
| 147 | 36x |
DELTA <- max(abs(c(Mu, lav_matrix_vech(Sigma)) - |
| 148 | 36x |
c(Mu0, lav_matrix_vech(Sigma0)))) |
| 149 | ||
| 150 |
# report fx |
|
| 151 | 36x |
if (lav_verbose()) {
|
| 152 |
# fx <- lav_model_objective_fiml(Sigma.hat=Sigma, Mu.hat=Mu, M=Yp) |
|
| 153 | ! |
fx <- lav_mvnorm_missing_loglik_samplestats( |
| 154 | ! |
Yp = Yp, |
| 155 | ! |
Mu = Mu, Sigma = Sigma, |
| 156 | ! |
log2pi = FALSE, |
| 157 | ! |
minus.two = TRUE |
| 158 | ! |
) / N |
| 159 | ! |
cat( |
| 160 | ! |
" EM iteration:", sprintf("%4d", i),
|
| 161 | ! |
" fx = ", sprintf("%15.10f", fx),
|
| 162 | ! |
" delta par = ", sprintf("%9.8f", DELTA),
|
| 163 | ! |
"\n" |
| 164 |
) |
|
| 165 |
} |
|
| 166 | ||
| 167 |
# convergence check: using parameter values: |
|
| 168 | 36x |
if (DELTA < tol) {
|
| 169 | 8x |
break |
| 170 |
} |
|
| 171 | ||
| 172 |
# again |
|
| 173 | 28x |
Mu0 <- Mu |
| 174 | 28x |
Sigma0 <- Sigma |
| 175 |
} # EM iterations |
|
| 176 | ||
| 177 | 8x |
if (lav_verbose()) {
|
| 178 | ! |
cat("\nSigma:\n")
|
| 179 | ! |
print(Sigma) |
| 180 | ! |
cat("\nMu:\n")
|
| 181 | ! |
print(Mu) |
| 182 | ! |
cat("\n")
|
| 183 |
} |
|
| 184 | ||
| 185 |
# compute fx if we haven't already |
|
| 186 | 8x |
if (!lav_verbose()) {
|
| 187 |
# fx <- lav_model_objective_fiml(Sigma.hat = Sigma, Mu.hat = Mu, M = Yp) |
|
| 188 | 8x |
fx <- lav_mvnorm_missing_loglik_samplestats( |
| 189 | 8x |
Yp = Yp, |
| 190 | 8x |
Mu = Mu, Sigma = Sigma, |
| 191 | 8x |
log2pi = FALSE, |
| 192 | 8x |
minus.two = TRUE |
| 193 | 8x |
) / N |
| 194 |
} |
|
| 195 | ||
| 196 |
# warning? |
|
| 197 | 8x |
if (i == max.iter) {
|
| 198 | ! |
lav_msg_warn( |
| 199 | ! |
gettext("Maximum number of iterations reached when computing the sample
|
| 200 | ! |
moments using EM; use the em.h1.iter.max= argument to increase |
| 201 | ! |
the number of iterations") |
| 202 |
) |
|
| 203 |
} |
|
| 204 | ||
| 205 | 8x |
ev <- eigen(Sigma, symmetric = TRUE, only.values = TRUE)$values |
| 206 | 8x |
if (any(ev < 1e-05)) { # make an option?
|
| 207 | ! |
lav_msg_warn( |
| 208 | ! |
gettext("The smallest eigenvalue of the EM estimated variance-covariance
|
| 209 | ! |
matrix (Sigma) is smaller than 1e-05; this may cause numerical |
| 210 | ! |
instabilities; interpret the results with caution.") |
| 211 |
) |
|
| 212 |
} |
|
| 213 | ||
| 214 | 8x |
list(Sigma = Sigma, Mu = Mu, fx = fx) |
| 215 |
} |
|
| 216 | ||
| 217 |
# if we cannot use the EM algorithm (zero coverage?), we can always use |
|
| 218 |
# plain FIML and nlminb() instead |
|
| 219 |
# |
|
| 220 |
# single level only |
|
| 221 |
lav_mvnorm_missing_h1_estimate_moments_chol <- function(lavdata = NULL, |
|
| 222 |
lavsamplestats = NULL, |
|
| 223 |
lavoptions = NULL, |
|
| 224 |
group = 1L) {
|
|
| 225 |
# not for multilevel |
|
| 226 | ! |
stopifnot(lavdata@nlevels == 1L) |
| 227 | ||
| 228 |
# no ov.names.x in lavdata |
|
| 229 | ! |
lavdata@ov.names.x <- vector("list", length = lavdata@ngroups)
|
| 230 | ||
| 231 |
# construct unrestricted partable (using chol parameterization) |
|
| 232 |
# for this group only |
|
| 233 | ! |
lavpartable <- lav_partable_unrestricted_chol( |
| 234 | ! |
lavdata = lavdata, lavoptions = lavoptions, |
| 235 | ! |
lavpta = NULL, group = group) |
| 236 | ||
| 237 | ! |
lavoptions2 <- lavoptions |
| 238 | ! |
lavoptions2$estimator <- "ML" |
| 239 | ! |
lavoptions2$missing <- "ml" |
| 240 | ! |
lavoptions2$se <- "none" |
| 241 | ! |
lavoptions2$test <- "none" |
| 242 | ! |
lavoptions2$do.fit <- TRUE |
| 243 | ! |
lavoptions2$optim.method <- "nlminb" |
| 244 | ! |
lavoptions2$h1 <- FALSE |
| 245 | ! |
lavoptions2$implied <- TRUE |
| 246 | ! |
lavoptions2$loglik <- TRUE |
| 247 | ! |
lavoptions2$baseline <- FALSE |
| 248 | ! |
lavoptions2$fixed.x <- FALSE # even if model uses fixed.x=TRUE |
| 249 | ! |
lavoptions2$model.type <- "unrestricted" |
| 250 | ! |
lavoptions2$optim.attempts <- 4L |
| 251 | ! |
lavoptions2$check.gradient <- FALSE |
| 252 | ! |
lavoptions2$optim.force.convergence <- TRUE # for now... |
| 253 | ! |
lavoptions2$control <- list(rel.tol = 1e-7) |
| 254 | ! |
lavoptions2$start <- "simple" # add this point, we have no lavh1 yet! |
| 255 | ! |
FIT <- lavaan(lavpartable, |
| 256 | ! |
slotOptions = lavoptions2, |
| 257 | ! |
slotSampleStats = lavsamplestats, |
| 258 | ! |
slotData = lavdata, |
| 259 | ! |
warn = FALSE |
| 260 |
) |
|
| 261 | ||
| 262 | ! |
out <- list(Sigma = FIT@implied$cov[[1]], |
| 263 | ! |
Mu = FIT@implied$mean[[1]], |
| 264 | ! |
fx = FIT@optim$fx) |
| 265 | ||
| 266 | ! |
out |
| 267 |
} |
|
| 268 | ||
| 269 |
# compute N times ACOV(Mu, vech(Sigma)) |
|
| 270 |
# in the literature: - `Omega_{SW}'
|
|
| 271 |
# - `Gamma for incomplete data' |
|
| 272 |
# - (N times the) sandwich estimator for acov(mu,vech(Sigma)) |
|
| 273 |
lav_mvnorm_missing_h1_omega_sw <- function(Y = NULL, |
|
| 274 |
Mp = NULL, |
|
| 275 |
wt = NULL, |
|
| 276 |
cluster.idx = NULL, |
|
| 277 |
Yp = NULL, |
|
| 278 |
Sinv.method = "eigen", |
|
| 279 |
Mu = NULL, |
|
| 280 |
Sigma = NULL, |
|
| 281 |
x.idx = integer(0L), |
|
| 282 |
Sigma.inv = NULL, |
|
| 283 |
information = "observed") {
|
|
| 284 |
# missing patterns |
|
| 285 | ! |
if (is.null(Mp)) {
|
| 286 | ! |
Mp <- lav_data_missing_patterns(Y) |
| 287 |
} |
|
| 288 | ||
| 289 |
# sample stats per pattern |
|
| 290 | ! |
if (is.null(Yp) && (information == "observed" || is.null(Sigma))) {
|
| 291 | ! |
Yp <- lav_samplestats_missing_patterns(Y = Y, Mp = Mp, wt = wt) |
| 292 |
} |
|
| 293 | ||
| 294 |
# Sigma and Mu |
|
| 295 | ! |
if (is.null(Sigma) || is.null(Mu)) {
|
| 296 | ! |
out <- lav_mvnorm_missing_h1_estimate_moments(Y = Y, Mp = Mp, Yp = Yp) |
| 297 | ! |
Mu <- out$Mu |
| 298 | ! |
Sigma <- out$Sigma |
| 299 |
} |
|
| 300 | ||
| 301 |
# information matrices |
|
| 302 | ! |
info <- lav_mvnorm_missing_information_both( |
| 303 | ! |
Y = Y, Mp = Mp, Mu = Mu, |
| 304 | ! |
wt = wt, cluster.idx = cluster.idx, |
| 305 | ! |
Sigma = Sigma, x.idx = x.idx, Sinv.method = Sinv.method, |
| 306 | ! |
Sigma.inv = Sigma.inv, information = information |
| 307 |
) |
|
| 308 | ||
| 309 | ! |
A <- info$Abeta |
| 310 | ! |
A.inv <- lav_matrix_symmetric_inverse( |
| 311 | ! |
S = A, logdet = FALSE, |
| 312 | ! |
Sinv.method = Sinv.method |
| 313 |
) |
|
| 314 | ! |
B <- info$Bbeta |
| 315 | ||
| 316 |
# sandwich |
|
| 317 | ! |
SW <- A.inv %*% B %*% A.inv |
| 318 | ||
| 319 | ! |
SW |
| 320 |
} |
|
| 321 | ||
| 322 |
| 1 |
# user visible function to add 'matrix' entries in the parameter table |
|
| 2 |
lavMatrixRepresentation <- function(partable, representation = "LISREL", |
|
| 3 |
allow.composites = TRUE, # new in 0.6-20 |
|
| 4 |
add.attributes = FALSE, |
|
| 5 |
as.data.frame. = TRUE) {
|
|
| 6 |
# check parameter table |
|
| 7 | ! |
partable <- lav_partable_complete(partable) |
| 8 | ||
| 9 |
# get model matrices |
|
| 10 | ! |
if (representation == "LISREL") {
|
| 11 | ! |
REP <- lav_lisrel(partable, target = NULL, extra = add.attributes, |
| 12 | ! |
allow.composites = allow.composites) |
| 13 | ! |
} else if (representation == "RAM") {
|
| 14 | ! |
REP <- lav_ram(partable, target = NULL, extra = add.attributes) |
| 15 |
} else {
|
|
| 16 | ! |
lav_msg_stop(gettext("representation must either \"LISREL\" or \"RAM\"."))
|
| 17 |
} |
|
| 18 | ||
| 19 | ! |
partable$mat <- REP$mat |
| 20 | ! |
partable$row <- REP$row |
| 21 | ! |
partable$col <- REP$col |
| 22 | ||
| 23 | ! |
if (as.data.frame.) {
|
| 24 | ! |
partable <- as.data.frame(partable, stringsAsFactors = FALSE) |
| 25 | ! |
class(partable) <- c("lavaan.data.frame", "data.frame")
|
| 26 |
} |
|
| 27 | ||
| 28 | ! |
if (add.attributes) {
|
| 29 | ! |
if (representation == "LISREL") {
|
| 30 | ! |
attr(partable, "ov.dummy.names.nox") <- attr(REP, "ov.dummy.names.nox") |
| 31 | ! |
attr(partable, "ov.dummy.names.x") <- attr(REP, "ov.dummy.names.x") |
| 32 | ! |
} else if (representation == "RAM") {
|
| 33 | ! |
attr(partable, "ov.idx") <- attr(REP, "ov.idx") |
| 34 |
} |
|
| 35 | ! |
attr(partable, "mmNames") <- attr(REP, "mmNames") |
| 36 | ! |
attr(partable, "mmNumber") <- attr(REP, "mmNumber") |
| 37 | ! |
attr(partable, "mmRows") <- attr(REP, "mmRows") |
| 38 | ! |
attr(partable, "mmCols") <- attr(REP, "mmCols") |
| 39 | ! |
attr(partable, "mmDimNames") <- attr(REP, "mmDimNames") |
| 40 | ! |
attr(partable, "mmSymmetric") <- attr(REP, "mmSymmetric") |
| 41 |
} |
|
| 42 | ||
| 43 | ! |
partable |
| 44 |
} |
| 1 |
# functions to deal with binary/ordinal univariate data |
|
| 2 | ||
| 3 |
# - probit regression |
|
| 4 |
# - ordinal probit regression |
|
| 5 |
# - logit regression |
|
| 6 |
# - ordinal logit regression |
|
| 7 | ||
| 8 |
# Note: the idea of using 'o1' and 'o2' when computing z1/z2 comes from |
|
| 9 |
# the dissertation of Christensen, 2012 (see also his `ordinal' package) |
|
| 10 | ||
| 11 |
# YR - 25 Nov 2019 (replacing the old lav_probit.R routines) |
|
| 12 | ||
| 13 |
lav_uvord_fit <- function(y = NULL, |
|
| 14 |
X = NULL, |
|
| 15 |
wt = rep(1, length(y)), |
|
| 16 |
lower = -Inf, |
|
| 17 |
upper = +Inf, |
|
| 18 |
optim.method = "nlminb", |
|
| 19 |
logistic = FALSE, # probit is the default |
|
| 20 |
control = list(), |
|
| 21 |
output = "list") {
|
|
| 22 |
# y |
|
| 23 | 16x |
if (!is.integer(y)) {
|
| 24 |
# brute force, no checking! (this is a lower-level function) |
|
| 25 | 16x |
y <- as.integer(y) |
| 26 |
} |
|
| 27 | 16x |
if (!min(y, na.rm = TRUE) == 1L) {
|
| 28 | ! |
y <- as.integer(ordered(y)) |
| 29 |
} |
|
| 30 | ||
| 31 |
# check weights |
|
| 32 | 16x |
if (is.null(wt)) {
|
| 33 | 16x |
wt <- rep(1, length(y)) |
| 34 |
} else {
|
|
| 35 | ! |
if (length(y) != length(wt)) {
|
| 36 | ! |
lav_msg_stop(gettext("length y is not the same as length wt"))
|
| 37 |
} |
|
| 38 | ! |
if (any(wt < 0)) {
|
| 39 | ! |
lav_msg_stop(gettext("all weights should be positive"))
|
| 40 |
} |
|
| 41 |
} |
|
| 42 | ||
| 43 |
# check lower/upper |
|
| 44 |
# TODO |
|
| 45 | ||
| 46 |
# optim.method |
|
| 47 | 16x |
minObjective <- lav_uvord_min_objective |
| 48 | 16x |
y.ncat <- length(tabulate(y)) # number of response categories |
| 49 | 16x |
if (y.ncat > 1L) {
|
| 50 | 16x |
minGradient <- lav_uvord_min_gradient |
| 51 | 16x |
minHessian <- lav_uvord_min_hessian |
| 52 |
} else {
|
|
| 53 | ! |
minGradient <- NULL |
| 54 | ! |
minHessian <- NULL |
| 55 |
} |
|
| 56 | 16x |
if (optim.method == "nlminb" || optim.method == "nlminb2") {
|
| 57 |
# nothing to do |
|
| 58 | ! |
} else if (optim.method == "nlminb0") {
|
| 59 | ! |
minGradient <- minHessian <- NULL |
| 60 | ! |
} else if (optim.method == "nlminb1") {
|
| 61 | ! |
minHessian <- NULL |
| 62 |
} |
|
| 63 | ||
| 64 |
# create cache environment |
|
| 65 | 16x |
cache <- lav_uvord_init_cache(y = y, X = X, wt = wt, logistic = logistic) |
| 66 | ||
| 67 |
# optimize -- only changes from defaults |
|
| 68 | 16x |
control.nlminb <- list( |
| 69 | 16x |
eval.max = 20000L, iter.max = 10000L, |
| 70 | 16x |
trace = 0L, abs.tol = (.Machine$double.eps * 10) |
| 71 |
) |
|
| 72 | 16x |
control.nlminb <- modifyList(control.nlminb, control) |
| 73 | ||
| 74 | 16x |
optim <- nlminb( |
| 75 | 16x |
start = cache$theta, objective = minObjective, |
| 76 | 16x |
gradient = minGradient, hessian = minHessian, |
| 77 | 16x |
control = control.nlminb, lower = lower, upper = upper, |
| 78 | 16x |
cache = cache |
| 79 |
) |
|
| 80 | ||
| 81 | 16x |
if (output == "cache") {
|
| 82 | 8x |
return(cache) |
| 83 |
} |
|
| 84 | ||
| 85 |
# return results as a list (to be compatible with lav_polychor.R) |
|
| 86 | 8x |
out <- list( |
| 87 | 8x |
theta = optim$par, |
| 88 | 8x |
nexo = cache$nexo, |
| 89 | 8x |
nth = cache$nth, |
| 90 | 8x |
th.idx = seq_len(cache$nth), |
| 91 | 8x |
slope.idx = seq_len(length(optim$par))[-seq_len(cache$nth)], |
| 92 | 8x |
missing.idx = cache$missing.idx, |
| 93 | 8x |
y = cache$y, |
| 94 | 8x |
wt = cache$wt, |
| 95 | 8x |
Y1 = cache$Y1, |
| 96 | 8x |
Y2 = cache$Y2, |
| 97 | 8x |
z1 = cache$z1, |
| 98 | 8x |
z2 = cache$z2, |
| 99 | 8x |
X = cache$X |
| 100 |
) |
|
| 101 |
} |
|
| 102 | ||
| 103 |
# shortcut to get (possibly weighted) thresholds only, if no eXo |
|
| 104 |
lav_uvord_th <- function(y = NULL, wt = NULL) {
|
|
| 105 | 8x |
y.freq <- tabulate(y) # unweighted |
| 106 | 8x |
y.ncat <- length(y.freq) # number of response categories |
| 107 | 8x |
if (is.null(wt)) {
|
| 108 | 8x |
y.prop <- y.freq / sum(y.freq) |
| 109 |
} else {
|
|
| 110 | ! |
y.freq <- numeric(y.ncat) # numeric! weights... |
| 111 | ! |
for (cat in seq_len(y.ncat)) {
|
| 112 | ! |
y.freq[cat] <- sum(wt[y == cat], na.rm = TRUE) |
| 113 |
} |
|
| 114 | ! |
y.prop <- y.freq / sum(y.freq) |
| 115 |
} |
|
| 116 | ||
| 117 | 8x |
qnorm(cumsum(y.prop[-length(y.prop)])) |
| 118 |
} |
|
| 119 | ||
| 120 | ||
| 121 |
# prepare cache environment |
|
| 122 |
lav_uvord_init_cache <- function(y = NULL, |
|
| 123 |
X = NULL, |
|
| 124 |
wt = rep(1, length(y)), |
|
| 125 |
logistic = FALSE, |
|
| 126 |
parent = parent.frame()) {
|
|
| 127 | 16x |
nobs <- length(y) |
| 128 | ||
| 129 |
# number of response categories |
|
| 130 | 16x |
y.ncat <- length(tabulate(y)) # unweighted |
| 131 |
# number of thresholds |
|
| 132 | 16x |
nth <- y.ncat - 1L |
| 133 | ||
| 134 |
# X |
|
| 135 | 16x |
if (is.null(X)) {
|
| 136 | ! |
nexo <- 0L |
| 137 |
} else {
|
|
| 138 | 16x |
X <- unname(X) |
| 139 | 16x |
nexo <- ncol(X) |
| 140 |
# new in 0.6-17: check if X is full rank |
|
| 141 | 16x |
if (!anyNA(X)) {
|
| 142 | 16x |
if (qr(X)$rank < ncol(X)) {
|
| 143 | ! |
lav_msg_stop(gettext( |
| 144 | ! |
"matrix of exogenous covariates is rank deficient!(i.e., some x |
| 145 | ! |
variables contain redundant information)")) |
| 146 |
} |
|
| 147 |
} |
|
| 148 |
} |
|
| 149 | ||
| 150 |
# nobs |
|
| 151 | 16x |
if (is.null(wt)) {
|
| 152 | ! |
N <- nobs |
| 153 |
} else {
|
|
| 154 | 16x |
N <- sum(wt) |
| 155 |
} |
|
| 156 | ||
| 157 |
# frequencies (possibly weighted by wt) |
|
| 158 | 16x |
y.freq <- numeric(y.ncat) # numeric! weights... |
| 159 | 16x |
for (cat in seq_len(y.ncat)) {
|
| 160 | 32x |
y.freq[cat] <- sum(wt[y == cat], na.rm = TRUE) |
| 161 |
} |
|
| 162 | 16x |
y.prop <- y.freq / sum(y.freq) |
| 163 | ||
| 164 |
# missing values |
|
| 165 | 16x |
missing.idx <- which(is.na(y)) |
| 166 | ||
| 167 |
# missing values |
|
| 168 | 16x |
if (any(is.na(y)) || (!is.null(X) && any(is.na(X)))) {
|
| 169 | 4x |
lav_crossprod <- lav_matrix_crossprod |
| 170 |
} else {
|
|
| 171 | 12x |
lav_crossprod <- base::crossprod |
| 172 |
} |
|
| 173 | ||
| 174 |
# distribution |
|
| 175 | 16x |
if (logistic) {
|
| 176 | ! |
pfun <- plogis |
| 177 | ! |
dfun <- dlogis |
| 178 | ! |
gfun <- function(x) {
|
| 179 |
# FIXMe: is it worth making this work for abs(x) > 200? |
|
| 180 | ! |
out <- numeric(length(x)) |
| 181 | ! |
out[is.na(x)] <- NA |
| 182 | ! |
x.ok <- which(abs(x) < 200) |
| 183 | ! |
e <- exp(-x[x.ok]) |
| 184 | ! |
e1 <- 1 + e |
| 185 | ! |
e2 <- e1 * e1 |
| 186 | ! |
e4 <- e2 * e2 |
| 187 | ! |
out[x.ok] <- -e / e2 + e * (2 * (e * e1)) / e4 |
| 188 | ! |
out |
| 189 |
} |
|
| 190 |
} else {
|
|
| 191 | 16x |
pfun <- pnorm |
| 192 | 16x |
dfun <- dnorm |
| 193 | 16x |
gfun <- function(x) {
|
| 194 | 152x |
-x * dnorm(x) |
| 195 |
} |
|
| 196 |
} |
|
| 197 | ||
| 198 |
# offsets -Inf/+Inf |
|
| 199 | 16x |
o1 <- ifelse(y == nth + 1, 100, 0) |
| 200 | 16x |
o2 <- ifelse(y == 1, -100, 0) |
| 201 | ||
| 202 |
# TH matrices (Matrix logical?) |
|
| 203 | 16x |
if (nth > 0L) {
|
| 204 | 16x |
Y1 <- matrix(1:nth, nobs, nth, byrow = TRUE) == y |
| 205 | 16x |
Y2 <- matrix(1:nth, nobs, nth, byrow = TRUE) == (y - 1L) |
| 206 |
} else {
|
|
| 207 | ! |
Y1 <- Y2 <- matrix(nrow = nobs, ncol = 0) |
| 208 |
} |
|
| 209 | ||
| 210 |
# starting values |
|
| 211 | 16x |
if (nexo == 0L && nth > 0L) {
|
| 212 | ! |
if (logistic) {
|
| 213 | ! |
th.start <- qlogis(cumsum(y.prop[-length(y.prop)])) |
| 214 |
} else {
|
|
| 215 | ! |
th.start <- qnorm(cumsum(y.prop[-length(y.prop)])) |
| 216 |
} |
|
| 217 | 16x |
} else if ((nth == 1L && nexo > 0L) || nth == 0L) {
|
| 218 | 16x |
th.start <- 0 |
| 219 |
} else {
|
|
| 220 | ! |
if (logistic) {
|
| 221 |
# th.start <- seq(-1, 1, length = nth) / 2 |
|
| 222 | ! |
th.start <- qlogis((1:nth) / (nth + 1)) |
| 223 |
} else {
|
|
| 224 |
# th.start <- seq(-1, 1, length = nth) / 2 |
|
| 225 | ! |
th.start <- qnorm((1:nth) / (nth + 1)) |
| 226 |
} |
|
| 227 |
} |
|
| 228 | 16x |
beta.start <- rep(0, nexo) |
| 229 | 16x |
theta <- c(th.start, beta.start) |
| 230 | ||
| 231 |
# parameter labels (for pretty output only) |
|
| 232 |
# th.lab <- paste("th", seq_len(nth), sep = "")
|
|
| 233 |
# sl.lab <- character(0L) |
|
| 234 |
# if(nexo > 0L) {
|
|
| 235 |
# sl.lab <- paste("beta", seq_len(nexo), sep = "")
|
|
| 236 |
# } |
|
| 237 |
# theta.labels <- c(th.lab, sl.lab) |
|
| 238 | ||
| 239 | 16x |
out <- list2env( |
| 240 | 16x |
list( |
| 241 | 16x |
y = y, X = X, wt = wt, o1 = o1, o2 = o2, |
| 242 | 16x |
missing.idx = missing.idx, N = N, |
| 243 | 16x |
pfun = pfun, dfun = dfun, gfun = gfun, |
| 244 | 16x |
lav_crossprod = lav_crossprod, |
| 245 | 16x |
nth = nth, nobs = nobs, y.ncat = y.ncat, nexo = nexo, |
| 246 | 16x |
Y1 = Y1, Y2 = Y2, |
| 247 | 16x |
theta = theta |
| 248 |
), |
|
| 249 | 16x |
parent = parent |
| 250 |
) |
|
| 251 | ||
| 252 | 16x |
out |
| 253 |
} |
|
| 254 | ||
| 255 |
# compute total (log)likelihood |
|
| 256 |
lav_uvord_loglik <- function(y = NULL, |
|
| 257 |
X = NULL, |
|
| 258 |
wt = rep(1, length(y)), |
|
| 259 |
logistic = FALSE, |
|
| 260 |
cache = NULL) {
|
|
| 261 | ! |
if (is.null(cache)) {
|
| 262 | ! |
cache <- lav_uvord_fit( |
| 263 | ! |
y = y, X = X, wt = wt, |
| 264 | ! |
logistic = logistic, output = "cache" |
| 265 |
) |
|
| 266 |
} |
|
| 267 | ! |
lav_uvord_loglik_cache(cache = cache) |
| 268 |
} |
|
| 269 | ||
| 270 |
lav_uvord_loglik_cache <- function(cache = NULL) {
|
|
| 271 | 92x |
with(cache, {
|
| 272 |
# Note: we could treat the binary case separately, |
|
| 273 |
# avoiding calling pfun() twice |
|
| 274 | ||
| 275 |
# free parameters |
|
| 276 | 92x |
th <- theta[1:nth] |
| 277 | 92x |
TH <- c(0, th, 0) |
| 278 | 92x |
beta <- theta[-c(1:nth)] |
| 279 | 92x |
if (nexo > 0L) {
|
| 280 | 92x |
eta <- drop(X %*% beta) |
| 281 | 92x |
z1 <- TH[y + 1L] - eta + o1 |
| 282 | 92x |
z2 <- TH[y] - eta + o2 |
| 283 |
} else {
|
|
| 284 | ! |
z1 <- TH[y + 1L] + o1 |
| 285 | ! |
z2 <- TH[y] + o2 |
| 286 |
} |
|
| 287 | 92x |
pi.i <- pfun(z1) - pfun(z2) |
| 288 | ||
| 289 |
# avoid numerical degradation if z2 (and therefore z1) are both 'large' |
|
| 290 |
# and the pfuns are close to 1.0 |
|
| 291 | 92x |
large.idx <- which(z2 > 1) |
| 292 | 92x |
if (length(large.idx) > 0L) {
|
| 293 | 48x |
pi.i[large.idx] <- (pfun(z2[large.idx], lower.tail = FALSE) - |
| 294 | 48x |
pfun(z1[large.idx], lower.tail = FALSE)) |
| 295 |
} |
|
| 296 | ||
| 297 | 92x |
loglik <- sum(wt * log(pi.i), na.rm = TRUE) |
| 298 | ||
| 299 | 92x |
return(loglik) |
| 300 |
}) |
|
| 301 |
} |
|
| 302 | ||
| 303 |
# casewise scores |
|
| 304 |
lav_uvord_scores <- function(y = NULL, |
|
| 305 |
X = NULL, |
|
| 306 |
wt = rep(1, length(y)), |
|
| 307 |
use.weights = TRUE, |
|
| 308 |
logistic = FALSE, |
|
| 309 |
cache = NULL) {
|
|
| 310 | 8x |
if (is.null(cache)) {
|
| 311 | 8x |
cache <- lav_uvord_fit( |
| 312 | 8x |
y = y, X = X, wt = wt, |
| 313 | 8x |
logistic = logistic, output = "cache" |
| 314 |
) |
|
| 315 |
} |
|
| 316 | 8x |
SC <- lav_uvord_scores_cache(cache = cache) |
| 317 | ||
| 318 | 8x |
if (!is.null(wt) && use.weights) {
|
| 319 | ! |
SC <- SC * wt |
| 320 |
} |
|
| 321 | ||
| 322 | 8x |
SC |
| 323 |
} |
|
| 324 | ||
| 325 |
lav_uvord_scores_cache <- function(cache = NULL) {
|
|
| 326 | 8x |
with(cache, {
|
| 327 |
# d logl / d pi |
|
| 328 | 8x |
dldpi <- 1 / pi.i # unweighted! |
| 329 | ||
| 330 |
# we assume z1/z2 are available |
|
| 331 | 8x |
p1 <- dfun(z1) |
| 332 | 8x |
p2 <- dfun(z2) |
| 333 | ||
| 334 |
# th |
|
| 335 | 8x |
scores.th <- dldpi * (Y1 * p1 - Y2 * p2) |
| 336 | ||
| 337 |
# beta |
|
| 338 | 8x |
if (nexo > 0L) {
|
| 339 | 8x |
scores.beta <- dldpi * (-X) * (p1 - p2) |
| 340 | 8x |
return(cbind(scores.th, scores.beta, deparse.level = 0)) |
| 341 |
} else {
|
|
| 342 | ! |
return(scores.th) |
| 343 |
} |
|
| 344 |
}) |
|
| 345 |
} |
|
| 346 | ||
| 347 |
lav_uvord_gradient_cache <- function(cache = NULL) {
|
|
| 348 | 76x |
with(cache, {
|
| 349 |
# d logl / d pi |
|
| 350 | 76x |
wtp <- wt / pi.i |
| 351 | 76x |
p1 <- dfun(z1) |
| 352 | 76x |
p2 <- dfun(z2) |
| 353 | ||
| 354 |
# th |
|
| 355 | 76x |
dxa <- Y1 * p1 - Y2 * p2 |
| 356 | 76x |
scores.th <- wtp * dxa |
| 357 | ||
| 358 |
# beta |
|
| 359 | 76x |
if (nexo > 0L) {
|
| 360 | 76x |
dxb <- X * (p1 - p2) # == X*p1 - X*p2 |
| 361 | 76x |
scores.beta <- wtp * (-dxb) |
| 362 | 76x |
return(colSums(cbind(scores.th, scores.beta, deparse.level = 0), |
| 363 | 76x |
na.rm = TRUE |
| 364 |
)) |
|
| 365 |
} else {
|
|
| 366 | ! |
return(colSums(scores.th, na.rm = TRUE)) |
| 367 |
} |
|
| 368 |
}) |
|
| 369 |
} |
|
| 370 | ||
| 371 | ||
| 372 |
# compute total Hessian |
|
| 373 |
lav_uvord_hessian <- function(y = NULL, |
|
| 374 |
X = NULL, |
|
| 375 |
wt = rep(1, length(y)), |
|
| 376 |
logistic = FALSE, |
|
| 377 |
cache = NULL) {
|
|
| 378 | ! |
if (is.null(cache)) {
|
| 379 | ! |
cache <- lav_uvord_fit( |
| 380 | ! |
y = y, X = X, wt = wt, |
| 381 | ! |
logistic = logistic, output = "cache" |
| 382 |
) |
|
| 383 |
} |
|
| 384 | ! |
tmp <- lav_uvord_loglik_cache(cache = cache) |
| 385 | ! |
tmp <- lav_uvord_gradient_cache(cache = cache) |
| 386 | ! |
lav_uvord_hessian_cache(cache = cache) |
| 387 |
} |
|
| 388 | ||
| 389 |
lav_uvord_hessian_cache <- function(cache = NULL) {
|
|
| 390 | 76x |
with(cache, {
|
| 391 | 76x |
wtp2 <- wt / (pi.i * pi.i) |
| 392 | ||
| 393 | 76x |
g1w <- gfun(z1) * wtp |
| 394 | 76x |
g2w <- gfun(z2) * wtp |
| 395 | ||
| 396 | 76x |
Y1gw <- Y1 * g1w |
| 397 | 76x |
Y2gw <- Y2 * g2w |
| 398 | ||
| 399 | 76x |
dx2.tau <- (lav_crossprod(Y1gw, Y1) - lav_crossprod(Y2gw, Y2) - |
| 400 | 76x |
lav_crossprod(dxa, dxa * wtp2)) |
| 401 | ||
| 402 | 76x |
if (nexo == 0L) {
|
| 403 | ! |
return(dx2.tau) |
| 404 |
} |
|
| 405 | ||
| 406 | 76x |
dxb2 <- dxb * wtp2 |
| 407 | 76x |
dx2.beta <- (lav_crossprod(X * g1w, X) - lav_crossprod(X * g2w, X) - |
| 408 | 76x |
lav_crossprod(dxb, dxb2)) |
| 409 | ||
| 410 | 76x |
dx.taubeta <- (-lav_crossprod(Y1gw, X) + lav_crossprod(Y2gw, X) + |
| 411 | 76x |
lav_crossprod(dxa, dxb2)) |
| 412 | ||
| 413 | 76x |
Hessian <- rbind(cbind(dx2.tau, dx.taubeta, deparse.level = 0), |
| 414 | 76x |
cbind(t(dx.taubeta), dx2.beta, deparse.level = 0), |
| 415 | 76x |
deparse.level = 0 |
| 416 |
) |
|
| 417 | ||
| 418 | 76x |
return(Hessian) |
| 419 |
}) |
|
| 420 |
} |
|
| 421 | ||
| 422 | ||
| 423 |
# compute total (log)likelihood, for specific 'x' (nlminb) |
|
| 424 |
lav_uvord_min_objective <- function(x, cache = NULL) {
|
|
| 425 |
# check order of first 2 thresholds; if x[1] > x[2], return Inf |
|
| 426 |
# new in 0.6-8 |
|
| 427 | 92x |
if (cache$nth > 1L && x[1] > x[2]) {
|
| 428 | ! |
return(+Inf) |
| 429 |
} |
|
| 430 | 92x |
if (cache$nth > 2L && x[2] > x[3]) {
|
| 431 | ! |
return(+Inf) |
| 432 |
} |
|
| 433 | 92x |
if (cache$nth > 3L && x[3] > x[4]) {
|
| 434 | ! |
return(+Inf) |
| 435 |
} |
|
| 436 | 92x |
cache$theta <- x |
| 437 | 92x |
-1 * lav_uvord_loglik_cache(cache = cache) / cache$N |
| 438 |
} |
|
| 439 | ||
| 440 |
# compute gradient, for specific 'x' (nlminb) |
|
| 441 |
lav_uvord_min_gradient <- function(x, cache = NULL) {
|
|
| 442 |
# check if x has changed |
|
| 443 | 76x |
if (!all(x == cache$theta)) {
|
| 444 | ! |
cache$theta <- x |
| 445 | ! |
tmp <- lav_uvord_loglik_cache(cache = cache) |
| 446 |
} |
|
| 447 | 76x |
-1 * lav_uvord_gradient_cache(cache = cache) / cache$N |
| 448 |
} |
|
| 449 | ||
| 450 |
# compute hessian, for specific 'x' (nlminb) |
|
| 451 |
lav_uvord_min_hessian <- function(x, cache = NULL) {
|
|
| 452 |
# check if x has changed |
|
| 453 | 76x |
if (!all(x == cache$theta)) {
|
| 454 | ! |
cache$theta <- x |
| 455 | ! |
tmp <- lav_uvord_loglik_cache(cache = cache) |
| 456 | ! |
tmp <- lav_uvord_gradient_cache(cache = cache) |
| 457 |
} |
|
| 458 | 76x |
-1 * lav_uvord_hessian_cache(cache = cache) / cache$N |
| 459 |
} |
|
| 460 | ||
| 461 |
# get 'z1' and 'z2' values, given (new) values for the parameters |
|
| 462 |
# only needed for lav_bvord_cor_scores(), which is called from |
|
| 463 |
# lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R |
|
| 464 |
lav_uvord_update_fit <- function(fit.y = NULL, th.new = NULL, sl.new = NULL) {
|
|
| 465 |
# return fit.y with 'update' z1/z2 values |
|
| 466 | 104x |
if (is.null(th.new) && is.null(sl.new)) {
|
| 467 | 104x |
return(fit.y) |
| 468 |
} |
|
| 469 | ||
| 470 | ! |
if (!is.null(th.new)) {
|
| 471 | ! |
fit.y$theta[fit.y$th.idx] <- th.new |
| 472 |
} |
|
| 473 | ! |
if (!is.null(sl.new)) {
|
| 474 | ! |
fit.y$theta[fit.y$slope.idx] <- sl.new |
| 475 |
} |
|
| 476 | ||
| 477 | ! |
nth <- length(fit.y$th.idx) |
| 478 | ! |
o1 <- ifelse(fit.y$y == nth + 1, 100, 0) |
| 479 | ! |
o2 <- ifelse(fit.y$y == 1, -100, 0) |
| 480 | ||
| 481 | ! |
theta <- fit.y$theta |
| 482 | ! |
th <- theta[1:nth] |
| 483 | ! |
TH <- c(0, th, 0) |
| 484 | ! |
beta <- theta[-c(1:nth)] |
| 485 | ! |
y <- fit.y$y |
| 486 | ! |
X <- fit.y$X |
| 487 | ! |
if (length(fit.y$slope.idx) > 0L) {
|
| 488 | ! |
eta <- drop(X %*% beta) |
| 489 | ! |
fit.y$z1 <- TH[y + 1L] - eta + o1 |
| 490 | ! |
fit.y$z2 <- TH[y] - eta + o2 |
| 491 |
} else {
|
|
| 492 | ! |
fit.y$z1 <- TH[y + 1L] + o1 |
| 493 | ! |
fit.y$z2 <- TH[y] + o2 |
| 494 |
} |
|
| 495 | ||
| 496 | ! |
fit.y |
| 497 |
} |
| 1 |
# factor score regression |
|
| 2 | ||
| 3 |
# four methods: |
|
| 4 |
# - naive (regression or Bartlett) |
|
| 5 |
# - Skrondal & Laake (2001) (regression models only) |
|
| 6 |
# - Croon (2002) (general + robust SE) |
|
| 7 |
# - simple: always use Bartlett, replace var(f) by psi estimate |
|
| 8 |
# |
|
| 9 |
# TODO: |
|
| 10 |
# - Hishino & Bentler: this is simple + WLS |
|
| 11 | ||
| 12 |
# changes 09 dec 2018: add analytic SE ('standard')
|
|
| 13 |
# make this the new default |
|
| 14 | ||
| 15 |
fsr <- function(model = NULL, |
|
| 16 |
data = NULL, |
|
| 17 |
cmd = "sem", |
|
| 18 |
fsr.method = "Croon", |
|
| 19 |
fs.method = "Bartlett", |
|
| 20 |
fs.scores = FALSE, |
|
| 21 |
mm.options = list(se = "standard", test = "standard"), |
|
| 22 |
Gamma.NT = TRUE, |
|
| 23 |
lvinfo = FALSE, |
|
| 24 |
mm.list = NULL, |
|
| 25 |
..., |
|
| 26 |
output = "lavaan") {
|
|
| 27 |
# we need full data |
|
| 28 | ! |
if (is.null(data)) {
|
| 29 | ! |
lav_msg_stop(gettext("full data is required for factor score regression"))
|
| 30 |
} |
|
| 31 |
# dot dot dot |
|
| 32 | ! |
dotdotdot <- list(...) |
| 33 |
# ------------- handling of warn/debug/verbose switches ---------- |
|
| 34 | ! |
if (!is.null(dotdotdot$debug)) {
|
| 35 | ! |
current.debug <- lav_debug() |
| 36 | ! |
if (lav_debug(dotdotdot$debug)) |
| 37 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 38 | ! |
dotdotdot$debug <- NULL |
| 39 | ! |
if (lav_debug()) {
|
| 40 | ! |
dotdotdot$warn <- TRUE # force warnings if debug |
| 41 | ! |
dotdotdot$verbose <- TRUE # force verbose if debug |
| 42 |
} |
|
| 43 |
} |
|
| 44 | ! |
if (!is.null(dotdotdot$warn)) {
|
| 45 | ! |
current.warn <- lav_warn() |
| 46 | ! |
if (lav_warn(dotdotdot$warn)) |
| 47 | ! |
on.exit(lav_warn(current.warn), TRUE) |
| 48 | ! |
dotdotdot$warn <- NULL |
| 49 |
} |
|
| 50 | ! |
if (!is.null(dotdotdot$verbose)) {
|
| 51 | ! |
current.verbose <- lav_verbose() |
| 52 | ! |
if (lav_verbose(dotdotdot$verbose)) |
| 53 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 54 | ! |
dotdotdot$verbose <- NULL |
| 55 |
} |
|
| 56 | ||
| 57 |
# check fsr.method argument |
|
| 58 | ! |
fsr.method <- tolower(fsr.method) |
| 59 | ! |
if (fsr.method == "naive") {
|
| 60 |
# nothing to do |
|
| 61 | ! |
} else if (fsr.method %in% c( |
| 62 | ! |
"skrondal", "laake", "skrondallaake", |
| 63 | ! |
"skrondal.laake", "skrondal-laake" |
| 64 |
)) {
|
|
| 65 | ! |
fsr.method <- "skrondal.laake" |
| 66 | ! |
} else if (fsr.method == "croon") {
|
| 67 |
# nothing to do |
|
| 68 | ! |
} else if (fsr.method == "simple") {
|
| 69 |
# force fs.method to Bartlett! |
|
| 70 | ! |
fs.method <- "Bartlett" |
| 71 |
} else {
|
|
| 72 | ! |
lav_msg_stop(gettext("invalid option for argument fsr.method:"),
|
| 73 | ! |
fsr.method) |
| 74 |
} |
|
| 75 | ||
| 76 |
# check fs.method argument |
|
| 77 | ! |
fs.method <- tolower(fs.method) |
| 78 | ! |
if (fs.method %in% c("bartlett", "barttlett", "bartlet")) {
|
| 79 | ! |
fs.method <- "Bartlett" |
| 80 | ! |
} else if (fs.method == "regression") {
|
| 81 |
# nothing to do |
|
| 82 |
} else {
|
|
| 83 | ! |
lav_msg_stop(gettext("invalid option for argument fs.method:"),
|
| 84 | ! |
fs.method |
| 85 |
) |
|
| 86 |
} |
|
| 87 | ||
| 88 | ! |
if (output %in% c("scores", "fs.scores", "fsr.scores")) {
|
| 89 | ! |
fs.scores <- TRUE |
| 90 |
} |
|
| 91 | ||
| 92 |
# change 'default' values for fsr |
|
| 93 | ! |
if (is.null(dotdotdot$se)) {
|
| 94 | ! |
dotdotdot$se <- "standard" |
| 95 |
} |
|
| 96 | ! |
if (is.null(dotdotdot$test)) {
|
| 97 | ! |
dotdotdot$test <- "standard" |
| 98 |
} |
|
| 99 | ! |
if (is.null(dotdotdot$missing)) {
|
| 100 | ! |
dotdotdot$missing <- "ml" |
| 101 |
} |
|
| 102 | ! |
if (is.null(dotdotdot$meanstructure)) {
|
| 103 | ! |
dotdotdot$meanstructure <- TRUE |
| 104 |
} |
|
| 105 | ||
| 106 | ||
| 107 |
# STEP 0: process full model, without fitting |
|
| 108 | ! |
dotdotdot0 <- dotdotdot |
| 109 | ! |
dotdotdot0$do.fit <- NULL |
| 110 | ! |
dotdotdot0$se <- "none" # to avoid warning about missing="listwise" |
| 111 | ! |
dotdotdot0$test <- "none" # to avoid warning about missing="listwise" |
| 112 | ||
| 113 |
# check for arguments that we do not want (eg sample.cov)? |
|
| 114 |
# TODO |
|
| 115 | ||
| 116 |
# initial processing of the model, no fitting |
|
| 117 | ! |
FIT <- suppressWarnings(do.call(cmd, |
| 118 | ! |
args = c(list( |
| 119 | ! |
model = model, |
| 120 | ! |
data = data, |
| 121 |
# meanstructure = TRUE, |
|
| 122 | ! |
do.fit = FALSE |
| 123 | ! |
), dotdotdot0) |
| 124 |
)) |
|
| 125 | ! |
lavoptions <- lavInspect(FIT, "options") |
| 126 |
# restore |
|
| 127 | ! |
lavoptions$se <- dotdotdot$se |
| 128 | ! |
lavoptions$test <- dotdotdot$test |
| 129 | ! |
ngroups <- lavInspect(FIT, "ngroups") |
| 130 | ! |
lavpta <- FIT@pta |
| 131 | ! |
lavpartable <- lav_partable_set_cache(FIT@ParTable, lavpta) |
| 132 | ||
| 133 |
# FIXME: not ready for multiple groups yet |
|
| 134 | ! |
if (ngroups > 1L) {
|
| 135 | ! |
lav_msg_stop(gettext("fsr code not ready for multiple groups (yet)"))
|
| 136 |
} |
|
| 137 | ||
| 138 |
# if missing = "listwise", make data complete |
|
| 139 | ! |
if (lavoptions$missing == "listwise") {
|
| 140 |
# FIXME: make this work for multiple groups!! |
|
| 141 | ! |
OV <- unique(unlist(lavpta$vnames$ov)) |
| 142 | ! |
data <- na.omit(data[, OV]) |
| 143 |
} |
|
| 144 | ||
| 145 |
# any `regular' latent variables? |
|
| 146 | ! |
lv.names <- unique(unlist(FIT@pta$vnames$lv.regular)) |
| 147 | ! |
ov.names <- unique(unlist(FIT@pta$vnames$ov)) |
| 148 | ||
| 149 |
# check for higher-order factors |
|
| 150 | ! |
good.idx <- logical(length(lv.names)) |
| 151 | ! |
for (f in seq_len(length(lv.names))) {
|
| 152 |
# check the indicators |
|
| 153 | ! |
FAC <- lv.names[f] |
| 154 | ! |
IND <- lavpartable$rhs[lavpartable$lhs == FAC & |
| 155 | ! |
lavpartable$op == "=~"] |
| 156 | ! |
if (all(IND %in% ov.names)) {
|
| 157 | ! |
good.idx[f] <- TRUE |
| 158 |
} |
|
| 159 |
# FIXME: check for mixed lv/ov indicators |
|
| 160 |
} |
|
| 161 | ! |
lv.names <- lv.names[good.idx] |
| 162 | ||
| 163 | ! |
if (length(lv.names) == 0L) {
|
| 164 | ! |
lav_msg_stop(gettext("model does not contain any (measured) latent variables"))
|
| 165 |
} |
|
| 166 | ! |
nfac <- length(lv.names) |
| 167 | ||
| 168 |
# check parameter table |
|
| 169 | ! |
PT <- lav_partable_set_cache(parTable(FIT)) |
| 170 | ! |
PT$est <- PT$se <- NULL |
| 171 | ||
| 172 |
# extract structural part |
|
| 173 | ! |
PT.PA <- lav_partable_subset_structural_model(PT) |
| 174 | ||
| 175 |
# check if we can use skrondal & laake (no mediational terms?) |
|
| 176 | ! |
if (fsr.method == "skrondal.laake") {
|
| 177 |
# determine eqs.y and eqs.x names |
|
| 178 | ! |
eqs.x.names <- unlist(FIT@pta$vnames$eqs.x) |
| 179 | ! |
eqs.y.names <- unlist(FIT@pta$vnames$eqs.y) |
| 180 | ! |
eqs.names <- unique(c(eqs.x.names, eqs.y.names)) |
| 181 | ! |
if (any(eqs.x.names %in% eqs.y.names)) {
|
| 182 | ! |
lav_msg_stop( |
| 183 | ! |
gettextf("mediational relationships are not allowed for the
|
| 184 | ! |
Skrondal.Laake method; use %s instead.", |
| 185 | ! |
dQuote("Croon")))
|
| 186 |
} |
|
| 187 |
} |
|
| 188 | ||
| 189 | ||
| 190 |
# STEP 1a: compute factor scores for each measurement model (block) |
|
| 191 | ||
| 192 |
# how many measurement models? |
|
| 193 | ! |
if (!is.null(mm.list)) {
|
| 194 | ! |
if (fsr.method != "simple") {
|
| 195 | ! |
lav_msg_stop(gettext("mm.list only available if fsr.method = \"simple\""))
|
| 196 |
} |
|
| 197 | ||
| 198 | ! |
nblocks <- length(mm.list) |
| 199 |
# check each measurement block |
|
| 200 | ! |
for (b in seq_len(nblocks)) {
|
| 201 | ! |
if (!all(mm.list[[b]] %in% lv.names)) {
|
| 202 | ! |
lav_msg_stop( |
| 203 | ! |
gettextf("mm.list contains unknown latent variable(s): %s",
|
| 204 | ! |
lav_msg_view(mm.list[[b]][mm.list[[b]] %in% lv.names], |
| 205 | ! |
log.sep = "none"))) |
| 206 |
} |
|
| 207 |
} |
|
| 208 |
} else {
|
|
| 209 |
# TODO: here comes the automatic 'detection' of linked |
|
| 210 |
# measurement models |
|
| 211 |
# |
|
| 212 |
# for now we take a single latent variable per measurement model block |
|
| 213 | ! |
mm.list <- as.list(lv.names) |
| 214 | ! |
nblocks <- length(mm.list) |
| 215 |
} |
|
| 216 | ||
| 217 |
# compute factor scores, per latent variable |
|
| 218 | ! |
FS.SCORES <- vector("list", length = ngroups)
|
| 219 | ! |
LVINFO <- vector("list", length = ngroups)
|
| 220 | ! |
if (ngroups > 1L) {
|
| 221 | ! |
names(FS.SCORES) <- names(LVINFO) <- lavInspect(FIT, "group.label") |
| 222 |
} |
|
| 223 | ! |
for (g in 1:ngroups) {
|
| 224 | ! |
FS.SCORES[[g]] <- vector("list", length = nblocks)
|
| 225 |
# names(FS.SCORES[[g]]) <- lv.names |
|
| 226 | ! |
LVINFO[[g]] <- vector("list", length = nblocks)
|
| 227 |
# names(LVINFO[[g]]) <- lv.names |
|
| 228 |
} |
|
| 229 | ||
| 230 |
# adjust options |
|
| 231 | ! |
dotdotdot2 <- dotdotdot |
| 232 | ! |
dotdotdot2$se <- "none" |
| 233 | ! |
dotdotdot2$test <- "none" |
| 234 | ! |
dotdotdot2$debug <- FALSE # only transmitted to lavaan call = ok |
| 235 | ! |
dotdotdot2$verbose <- FALSE # only transmitted to lavaan call = ok |
| 236 | ! |
dotdotdot2$auto.cov.lv.x <- TRUE # allow correlated exogenous factors |
| 237 | ||
| 238 |
# override with mm.options |
|
| 239 | ! |
dotdotdot2 <- modifyList(dotdotdot2, mm.options) |
| 240 | ||
| 241 |
# we assume the same number/names of lv's per group!!! |
|
| 242 | ! |
MM.FIT <- vector("list", nblocks)
|
| 243 | ! |
Sigma2.block <- vector("list", nblocks)
|
| 244 | ! |
for (b in 1:nblocks) {
|
| 245 |
# create parameter table for this measurement block only |
|
| 246 | ! |
PT.block <- |
| 247 | ! |
lav_partable_subset_measurement_model( |
| 248 | ! |
PT = PT, |
| 249 | ! |
add.lv.cov = TRUE, |
| 250 | ! |
lv.names = mm.list[[b]] |
| 251 |
) |
|
| 252 |
# fit 1-factor model |
|
| 253 | ! |
fit.block <- do.call("lavaan",
|
| 254 | ! |
args = c(list( |
| 255 | ! |
model = PT.block, |
| 256 | ! |
data = data |
| 257 | ! |
), dotdotdot2) |
| 258 |
) |
|
| 259 |
# check convergence |
|
| 260 | ! |
if (!lavInspect(fit.block, "converged")) {
|
| 261 | ! |
lav_msg_stop( |
| 262 | ! |
gettextf("measurement model for %s did not converge.",
|
| 263 | ! |
lav_msg_view(mm.list[[b]])) |
| 264 |
) |
|
| 265 |
} |
|
| 266 |
# store fitted measurement model |
|
| 267 | ! |
MM.FIT[[b]] <- fit.block |
| 268 | ||
| 269 |
# fs.method? |
|
| 270 | ! |
if (fsr.method == "skrondal.laake") {
|
| 271 |
# dependent -> Bartlett |
|
| 272 | ! |
if (lv.names[b] %in% eqs.y.names) {
|
| 273 | ! |
fs.method <- "Bartlett" |
| 274 |
} else {
|
|
| 275 | ! |
fs.method <- "regression" |
| 276 |
} |
|
| 277 |
} |
|
| 278 | ||
| 279 |
# compute factor scores |
|
| 280 | ! |
SC <- lavPredict(fit.block, method = fs.method, fsm = TRUE) |
| 281 | ! |
FSM <- attr(SC, "fsm") |
| 282 | ! |
attr(SC, "fsm") <- NULL |
| 283 | ||
| 284 |
# warning, FSM may be a list per pattern! |
|
| 285 |
# if(fit.block@Options$missing == "ml") {
|
|
| 286 |
# # do something... |
|
| 287 |
# ngroups <- fit.block@Data@ngroups |
|
| 288 |
# FSM.missing <- FSM |
|
| 289 |
# FSM <- vector("list", length = "ngroups")
|
|
| 290 |
# for(g in seq_len(ngroups)) {
|
|
| 291 |
# |
|
| 292 |
# } |
|
| 293 |
# } |
|
| 294 | ||
| 295 | ! |
LAMBDA <- lav_model_lambda(fit.block@Model) # FIXME: remove dummy lv's? |
| 296 | ! |
THETA <- lav_model_theta(fit.block@Model) # FIXME: remove not used ov? |
| 297 | ! |
PSI <- lav_model_veta(fit.block@Model) |
| 298 | ||
| 299 |
# if ngroups = 1, make list again |
|
| 300 | ! |
if (ngroups == 1L) {
|
| 301 |
# because lavPredict() drops the list |
|
| 302 | ! |
SC <- list(SC) |
| 303 |
} |
|
| 304 | ||
| 305 |
# store results |
|
| 306 | ! |
for (g in 1:ngroups) {
|
| 307 | ! |
FS.SCORES[[g]][[b]] <- SC[[g]] |
| 308 | ! |
if (fsr.method %in% c("croon", "simple")) {
|
| 309 | ! |
offset <- FSM[[g]] %*% THETA[[g]] %*% t(FSM[[g]]) |
| 310 | ! |
scale <- FSM[[g]] %*% LAMBDA[[g]] |
| 311 | ! |
scale.inv <- solve(scale) |
| 312 | ! |
scoffset <- scale.inv %*% offset %*% scale.inv |
| 313 | ||
| 314 | ! |
LVINFO[[g]][[b]] <- list( |
| 315 | ! |
lv.names = mm.list[[b]], |
| 316 | ! |
fsm = FSM[[g]], |
| 317 | ! |
lambda = LAMBDA[[g]], |
| 318 | ! |
psi = PSI[[g]], |
| 319 | ! |
theta = THETA[[g]], |
| 320 | ! |
offset = offset, |
| 321 | ! |
scale = scale, |
| 322 | ! |
scale.inv = scale.inv, |
| 323 | ! |
scoffset = scoffset |
| 324 |
) |
|
| 325 |
} |
|
| 326 |
} # g |
|
| 327 | ||
| 328 |
# Delta.21: list per group |
|
| 329 | ! |
Delta.21 <- lav_fsr_delta21(fit.block, FSM) |
| 330 | ||
| 331 |
# vcov |
|
| 332 | ! |
Sigma1.block <- vcov(fit.block) |
| 333 | ! |
tmp <- matrix(0, nrow(Delta.21[[1]]), nrow(Delta.21[[1]])) |
| 334 | ! |
lavsamplestats <- fit.block@SampleStats |
| 335 | ! |
for (g in 1:ngroups) {
|
| 336 | ! |
fg <- lavsamplestats@nobs[[g]] / lavsamplestats@ntotal |
| 337 | ! |
tmp <- |
| 338 | ! |
tmp + fg * (Delta.21[[g]] %*% Sigma1.block %*% t(Delta.21[[g]])) |
| 339 |
} |
|
| 340 | ! |
Sigma2.block[[b]] <- tmp |
| 341 |
} # measurement block |
|
| 342 | ||
| 343 |
# Sigma.2 = Delta.21 %*% Sigma.1 %*% t(Delta.21) |
|
| 344 | ! |
Sigma.2 <- lav_matrix_bdiag(Sigma2.block) |
| 345 | ||
| 346 | ||
| 347 |
# compute empirical covariance matrix factor scores + observed variables |
|
| 348 |
# in structural part |
|
| 349 | ! |
group.values <- lav_partable_group_values(PT.PA) |
| 350 | ! |
FS.COV <- vector("list", length = ngroups)
|
| 351 | ! |
FSR.COV <- vector("list", length = ngroups)
|
| 352 | ! |
FSR.COV2 <- vector("list", length = ngroups)
|
| 353 | ! |
Y <- vector("list", length = ngroups)
|
| 354 | ! |
if (lavoptions$meanstructure) {
|
| 355 | ! |
FS.MEAN <- vector("list", length = ngroups)
|
| 356 |
} else {
|
|
| 357 | ! |
FS.MEAN <- NULL |
| 358 |
} |
|
| 359 | ! |
for (g in seq_len(ngroups)) {
|
| 360 |
# full data for structural model |
|
| 361 | ! |
struc.names <- lav_object_vnames(PT.PA, "ov", group = group.values[g]) |
| 362 |
# reorder struc.names, so that order is the same as in MM (new in 0.6-9) |
|
| 363 | ! |
lv.idx <- which(struc.names %in% lv.names) |
| 364 | ! |
struc.names[lv.idx] <- lv.names |
| 365 | ||
| 366 | ! |
struc.ov.idx <- which(!struc.names %in% lv.names) |
| 367 | ! |
struc.lv.idx <- which(struc.names %in% lv.names) |
| 368 | ! |
lv.order <- match(lv.names, struc.names) |
| 369 | ! |
if (length(struc.ov.idx) > 0L) {
|
| 370 | ! |
ov.idx <- which(FIT@Data@ov.names[[g]] %in% |
| 371 | ! |
struc.names[struc.ov.idx]) |
| 372 | ! |
Y.g <- matrix(0, |
| 373 | ! |
nrow = nrow(FS.SCORES[[g]][[1]]), |
| 374 | ! |
ncol = length(struc.names) |
| 375 |
) |
|
| 376 | ! |
Y.g[, struc.lv.idx] <- do.call( |
| 377 | ! |
"cbind", |
| 378 | ! |
FS.SCORES[[g]] |
| 379 | ! |
)[, lv.order, drop = FALSE] |
| 380 | ! |
Y.g[, struc.ov.idx] <- FIT@Data@X[[g]][, ov.idx, drop = FALSE] |
| 381 |
} else {
|
|
| 382 | ! |
Y.g <- do.call("cbind", FS.SCORES[[g]])[, lv.order, drop = FALSE]
|
| 383 |
} |
|
| 384 | ! |
Y[[g]] <- Y.g |
| 385 | ||
| 386 |
# sample statistics for structural model |
|
| 387 | ! |
COV <- cov(Y.g) # divided by N-1 |
| 388 | ! |
if (lavoptions$likelihood == "normal") {
|
| 389 | ! |
Ng <- lavInspect(FIT, "nobs")[g] |
| 390 | ! |
COV <- COV * (Ng - 1) / Ng |
| 391 |
} |
|
| 392 | ! |
FS.COV[[g]] <- COV |
| 393 | ||
| 394 | ! |
if (lavoptions$meanstructure) {
|
| 395 | ! |
FS.MEAN[[g]] <- colMeans(Y.g) |
| 396 |
} |
|
| 397 | ||
| 398 |
# STEP 1b: if using `Croon' method: correct COV matrix: |
|
| 399 | ! |
if (fsr.method %in% c("croon")) {
|
| 400 | ! |
scoffset <- lav_matrix_bdiag(lapply(LVINFO[[g]], "[[", "scoffset")) |
| 401 | ! |
scale.inv <- lav_matrix_bdiag(lapply(LVINFO[[g]], "[[", "scale.inv")) |
| 402 | ||
| 403 | ! |
SCOFFSET <- matrix(0, |
| 404 | ! |
nrow = length(struc.names), |
| 405 | ! |
ncol = length(struc.names) |
| 406 |
) |
|
| 407 | ! |
SCOFFSET[struc.lv.idx, struc.lv.idx] <- scoffset |
| 408 | ||
| 409 | ! |
SCALE.INV <- diag(length(struc.names)) |
| 410 | ! |
SCALE.INV[struc.lv.idx, struc.lv.idx] <- scale.inv |
| 411 | ||
| 412 | ! |
FSR.COV[[g]] <- SCALE.INV %*% FS.COV[[g]] %*% SCALE.INV - SCOFFSET |
| 413 | ! |
} else if (fsr.method == "simple") {
|
| 414 | ! |
psi <- lav_matrix_bdiag(lapply(LVINFO[[g]], "[[", "psi")) |
| 415 | ||
| 416 | ! |
FSR.COV[[g]] <- FS.COV[[g]] |
| 417 |
# scalar version only (for now) |
|
| 418 | ! |
diag(FSR.COV[[g]])[struc.lv.idx] <- psi |
| 419 |
} else {
|
|
| 420 | ! |
FSR.COV[[g]] <- FS.COV[[g]] |
| 421 |
} |
|
| 422 | ||
| 423 |
# copy with different labels |
|
| 424 | ! |
FSR.COV2[[g]] <- FSR.COV[[g]] |
| 425 | ||
| 426 |
# add row/col names |
|
| 427 | ! |
rownames(FS.COV[[g]]) <- colnames(FS.COV[[g]]) <- struc.names |
| 428 | ! |
rownames(FSR.COV[[g]]) <- colnames(FSR.COV[[g]]) <- struc.names |
| 429 | ! |
rownames(FSR.COV2[[g]]) <- colnames(FSR.COV2[[g]]) <- struc.names |
| 430 | ! |
rownames(FSR.COV2[[g]])[struc.lv.idx] <- |
| 431 | ! |
colnames(FSR.COV2[[g]])[struc.lv.idx] <- |
| 432 | ! |
paste(lv.names, ".si", sep = "") |
| 433 | ||
| 434 |
# check if FSR.COV is positive definite for all groups |
|
| 435 | ! |
eigvals <- eigen(FSR.COV[[g]], symmetric = TRUE, only.values = TRUE)$values |
| 436 | ! |
if (any(eigvals < .Machine$double.eps^(3 / 4))) {
|
| 437 | ! |
if (ngroups > 1L) {
|
| 438 | ! |
lav_msg_stop(gettextf("corrected covariance matrix of factor scores
|
| 439 | ! |
is not positive definite in group %s", g)) |
| 440 | ||
| 441 |
} else {
|
|
| 442 | ! |
lav_msg_stop(gettext("corrected covariance matrix of factor scores
|
| 443 | ! |
is not positive definite")) |
| 444 |
} |
|
| 445 |
} |
|
| 446 |
} # g |
|
| 447 | ||
| 448 | ||
| 449 |
# STEP 1c: do we need full set of factor scores? |
|
| 450 | ! |
if (fs.scores) {
|
| 451 |
# transform? |
|
| 452 | ! |
if (fsr.method %in% c("croon", "simple")) {
|
| 453 | ! |
for (g in 1:ngroups) {
|
| 454 | ! |
OLD.inv <- solve(FS.COV[[g]]) |
| 455 | ! |
OLD.inv.sqrt <- lav_matrix_symmetric_sqrt(OLD.inv) |
| 456 | ! |
FSR.COV.sqrt <- lav_matrix_symmetric_sqrt(FSR.COV[[g]]) |
| 457 | ! |
SC <- as.matrix(Y[[g]]) |
| 458 | ! |
SC <- SC %*% OLD.inv.sqrt %*% FSR.COV.sqrt |
| 459 | ! |
SC <- as.data.frame(SC) |
| 460 | ! |
names(SC) <- lv.names |
| 461 | ! |
Y[[g]] <- SC |
| 462 |
} |
|
| 463 |
} |
|
| 464 | ||
| 465 |
# unlist if multiple groups, add group column |
|
| 466 | ! |
if (ngroups == 1L) {
|
| 467 | ! |
Y <- as.data.frame(Y[[1]]) |
| 468 |
} else {
|
|
| 469 | ! |
lav_msg_fixme("fix this!")
|
| 470 |
} |
|
| 471 |
} |
|
| 472 | ||
| 473 | ||
| 474 | ||
| 475 | ||
| 476 |
# STEP 2: fit structural model using (corrected?) factor scores |
|
| 477 | ||
| 478 |
# free all means/intercepts (of observed variables only) |
|
| 479 | ! |
lv.names.pa <- lav_object_vnames(PT.PA, "lv") |
| 480 | ! |
int.idx <- which(PT.PA$op == "~1" & !PT.PA$lhs %in% lv.names.pa) |
| 481 | ! |
PT.PA$free[int.idx] <- 1L |
| 482 | ! |
PT.PA$free[PT.PA$free > 0L] <- seq_len(sum(PT.PA$free > 0L)) |
| 483 | ! |
PT.PA$ustart[int.idx] <- NA |
| 484 | ||
| 485 | ||
| 486 | ||
| 487 |
# adjust lavoptions |
|
| 488 | ! |
if (is.null(dotdotdot$do.fit)) {
|
| 489 | ! |
lavoptions$do.fit <- TRUE |
| 490 |
} else {
|
|
| 491 | ! |
lavoptions$do.fit <- dotdotdot$do.fit |
| 492 |
} |
|
| 493 | ! |
if (is.null(dotdotdot$se)) {
|
| 494 | ! |
lavoptions$se <- "standard" |
| 495 |
} else {
|
|
| 496 | ! |
lavoptions$se <- dotdotdot$se |
| 497 |
} |
|
| 498 | ! |
if (is.null(dotdotdot$test)) {
|
| 499 | ! |
lavoptions$test <- "standard" |
| 500 |
} else {
|
|
| 501 | ! |
lavoptions$test <- dotdotdot$test |
| 502 |
} |
|
| 503 | ! |
if (is.null(dotdotdot$sample.cov.rescale)) {
|
| 504 | ! |
lavoptions$sample.cov.rescale <- FALSE |
| 505 |
} else {
|
|
| 506 | ! |
lavoptions$sample.cov.rescale <- dotdotdot$sample.cov.rescale |
| 507 |
} |
|
| 508 | ||
| 509 |
# fit structural model -- point estimation ONLY |
|
| 510 | ! |
lavoptions2 <- lavoptions |
| 511 |
# if(lavoptions$se == "standard") {
|
|
| 512 |
# lavoptions2$se <- "external" |
|
| 513 |
# } |
|
| 514 |
# lavoptions2$test <- "none" |
|
| 515 | ! |
lavoptions2$se <- "none" |
| 516 | ! |
lavoptions2$test <- "none" |
| 517 | ! |
lavoptions2$missing <- "listwise" # always complete data anyway... |
| 518 | ! |
fit <- lavaan(PT.PA, |
| 519 | ! |
sample.cov = FSR.COV, |
| 520 | ! |
sample.mean = FS.MEAN, |
| 521 | ! |
sample.nobs = FIT@SampleStats@nobs, |
| 522 | ! |
slotOptions = lavoptions2 |
| 523 |
) |
|
| 524 | ||
| 525 |
# only to correct the SE, we create another model, augmented with |
|
| 526 |
# the croon parameters |
|
| 527 | ! |
PT.PA2 <- parTable(fit) |
| 528 | ! |
PT.si <- lav_fsr_pa2si(PT.PA2, LVINFO = LVINFO) |
| 529 | ! |
idx1 <- PT.si$free[PT.si$user == 10L & PT.si$free > 0L] |
| 530 | ! |
idx2 <- PT.si$free[PT.si$user != 10L & PT.si$free > 0L] |
| 531 | ||
| 532 | ! |
lavoptions3 <- lavoptions2 |
| 533 | ! |
lavoptions3$optim.method <- "none" |
| 534 | ! |
lavoptions3$test <- "standard" |
| 535 | ! |
lavoptions3$se <- "none" |
| 536 | ! |
lavoptions3$check.gradient <- FALSE |
| 537 | ! |
lavoptions3$information <- "expected" ## FIXME: lav_model_gradient + delta |
| 538 | ! |
fit.si2 <- lavaan(PT.si, |
| 539 | ! |
sample.cov = FSR.COV2, |
| 540 | ! |
sample.mean = FS.MEAN, |
| 541 | ! |
sample.nobs = FIT@SampleStats@nobs, |
| 542 | ! |
slotOptions = lavoptions3 |
| 543 |
) |
|
| 544 | ! |
Info.all <- lavTech(fit.si2, "information") * nobs(fit) |
| 545 | ! |
I33 <- Info.all[idx2, idx2] |
| 546 | ! |
I32 <- Info.all[idx2, idx1] |
| 547 | ! |
I23 <- Info.all[idx1, idx2] |
| 548 | ! |
I22 <- Info.all[idx1, idx1] |
| 549 | ||
| 550 | ! |
I33.inv <- lav_matrix_symmetric_inverse(I33) |
| 551 | ||
| 552 | ! |
V1 <- I33.inv |
| 553 | ! |
V2 <- I33.inv %*% I32 %*% Sigma.2 %*% t(I32) %*% I33.inv |
| 554 | ! |
VCOV <- V1 + V2 |
| 555 | ||
| 556 |
# fill in standard errors step 2 |
|
| 557 | ! |
PT.PA2$se[PT.PA2$free > 0L] <- sqrt(diag(VCOV)) |
| 558 | ||
| 559 | ! |
if (output == "lavaan" || output == "fsr") {
|
| 560 | ! |
lavoptions3$se <- "twostep" |
| 561 | ! |
fit <- lavaan::lavaan(PT.PA2, |
| 562 | ! |
sample.cov = FSR.COV, |
| 563 | ! |
sample.mean = FS.MEAN, |
| 564 | ! |
sample.nobs = FIT@SampleStats@nobs, |
| 565 | ! |
slotOptions = lavoptions3 |
| 566 |
) |
|
| 567 | ! |
fit@vcov$vcov <- VCOV |
| 568 |
} |
|
| 569 | ||
| 570 |
# extra info |
|
| 571 | ! |
extra <- list( |
| 572 | ! |
FS.COV = FS.COV, FS.SCORES = Y, |
| 573 | ! |
FSR.COV = FSR.COV, |
| 574 | ! |
LVINFO = LVINFO, Sigma.2 = Sigma.2 |
| 575 |
) |
|
| 576 | ||
| 577 |
# standard errors |
|
| 578 |
# lavsamplestats <- fit@SampleStats |
|
| 579 |
# lavsamplestats@NACOV <- Omega.f |
|
| 580 |
# VCOV <- lav_model_vcov(fit@Model, lavsamplestats = lavsamplestats, |
|
| 581 |
# lavoptions = lavoptions) |
|
| 582 |
# SE <- lav_model_vcov_se(fit@Model, fit@ParTable, VCOV = VCOV) |
|
| 583 |
# PE$se <- SE |
|
| 584 |
# tmp.se <- ifelse(PE$se == 0.0, NA, PE$se) |
|
| 585 |
# zstat <- pvalue <- TRUE |
|
| 586 |
# if(zstat) {
|
|
| 587 |
# PE$z <- PE$est / tmp.se |
|
| 588 |
# if(pvalue) {
|
|
| 589 |
# PE$pvalue <- 2 * (1 - pnorm( abs(PE$z) )) |
|
| 590 |
# } |
|
| 591 |
# } |
|
| 592 | ||
| 593 | ! |
if (output == "fsr") {
|
| 594 | ! |
HEADER <- paste("This is fsr (0.2) -- factor score regression using ",
|
| 595 | ! |
"fsr.method = ", fsr.method, |
| 596 | ! |
sep = "" |
| 597 |
) |
|
| 598 | ! |
out <- list(header = HEADER, MM.FIT = MM.FIT, STRUC.FIT = fit) |
| 599 | ! |
if (lvinfo) {
|
| 600 | ! |
out$lvinfo <- extra |
| 601 |
} |
|
| 602 | ||
| 603 | ! |
class(out) <- c("lavaan.fsr", "list")
|
| 604 | ! |
} else if (output %in% c("lavaan", "fit")) {
|
| 605 | ! |
out <- fit |
| 606 | ! |
} else if (output == "extra") {
|
| 607 | ! |
out <- extra |
| 608 | ! |
} else if (output == "lvinfo") {
|
| 609 | ! |
out <- LVINFO |
| 610 | ! |
} else if (output %in% c("scores", "f.scores", "fs.scores")) {
|
| 611 | ! |
out <- Y |
| 612 | ! |
} else if (output %in% c( |
| 613 | ! |
"FSR.COV", "fsr.cov", "croon", "cov.croon", |
| 614 | ! |
"croon.cov", "COV", "cov" |
| 615 |
)) {
|
|
| 616 | ! |
out <- FSR.COV |
| 617 | ! |
} else if (output %in% c("FS.COV", "fs.cov")) {
|
| 618 | ! |
out <- FS.COV |
| 619 |
} else {
|
|
| 620 | ! |
lav_msg_stop(gettext("unknown output= argument:"), output)
|
| 621 |
} |
|
| 622 | ||
| 623 | ! |
out |
| 624 |
} |
| 1 |
#' lav_export_estimation |
|
| 2 |
#' |
|
| 3 |
#' lavaan provides a range of optimization methods with the optim.method argument |
|
| 4 |
#' (nlminb, BFGS, L-BFGS-B, GN, and nlminb.constr). `lav_export_estimation` |
|
| 5 |
#' allows exporting objects and functions necessary to pass a lavaan model into |
|
| 6 |
#' any optimizer that takes a combination of (1) starting values, (2) fit-function, |
|
| 7 |
#' (3) gradient-function, and (4) upper and lower bounds. This allows testing new |
|
| 8 |
#' optimization frameworks. |
|
| 9 |
#' |
|
| 10 |
#' @param lavaan_model a fitted lavaan model |
|
| 11 |
#' @returns List with: |
|
| 12 |
#' \itemize{
|
|
| 13 |
#' \item get_coef - When working with equality constraints, lavaan internally |
|
| 14 |
#' uses some transformations. get_coef is a functions that recreates the coef |
|
| 15 |
#' function for the parameters. |
|
| 16 |
#' \item starting_values - starting_values to be used in the optimization |
|
| 17 |
#' \item objective_function - objective function, expecting the current parameter |
|
| 18 |
#' values and the lavaan model |
|
| 19 |
#' \item gradient_function - gradient function, expecting the current parameter |
|
| 20 |
#' values and the lavaan model |
|
| 21 |
#' \item lower - lower bounds for parameters |
|
| 22 |
#' \item upper - upper bound for parameters |
|
| 23 |
#' } |
|
| 24 |
#' @export |
|
| 25 |
#' @examples |
|
| 26 |
#' library(lavaan) |
|
| 27 |
#' model <- " |
|
| 28 |
#' # latent variable definitions |
|
| 29 |
#' ind60 =~ x1 + x2 + x3 |
|
| 30 |
#' dem60 =~ y1 + y2 + y3 + y4 |
|
| 31 |
#' dem65 =~ y5 + a*y6 + y7 + y8 |
|
| 32 |
#' |
|
| 33 |
#' # regressions |
|
| 34 |
#' dem60 ~ ind60 |
|
| 35 |
#' dem65 ~ ind60 + dem60 |
|
| 36 |
#' " |
|
| 37 |
#' |
|
| 38 |
#' fit <- sem(model, |
|
| 39 |
#' data = PoliticalDemocracy, |
|
| 40 |
#' do.fit = FALSE |
|
| 41 |
#' ) |
|
| 42 |
#' |
|
| 43 |
#' est <- lav_export_estimation(lavaan_model = fit) |
|
| 44 |
#' |
|
| 45 |
#' # The starting values are: |
|
| 46 |
#' est$starting_values |
|
| 47 |
#' # Note that these do not have labels (and may also differ from coef(fit) |
|
| 48 |
#' # in case of equality constraints): |
|
| 49 |
#' coef(fit) |
|
| 50 |
#' # To get the same parameters, use: |
|
| 51 |
#' est$get_coef( |
|
| 52 |
#' parameter_values = est$starting_values, |
|
| 53 |
#' lavaan_model = fit |
|
| 54 |
#' ) |
|
| 55 |
#' |
|
| 56 |
#' # The objective function can be used to compute the fit at the current estimates: |
|
| 57 |
#' est$objective_function( |
|
| 58 |
#' parameter_values = est$starting_values, |
|
| 59 |
#' lavaan_model = fit |
|
| 60 |
#' ) |
|
| 61 |
#' |
|
| 62 |
#' # The gradient function can be used to compute the gradients at the current estimates: |
|
| 63 |
#' est$gradient_function( |
|
| 64 |
#' parameter_values = est$starting_values, |
|
| 65 |
#' lavaan_model = fit |
|
| 66 |
#' ) |
|
| 67 |
#' |
|
| 68 |
#' # Together, these elements provide the means to estimate the parameters with a large |
|
| 69 |
#' # range of optimizers. For simplicity, here is an example using optim: |
|
| 70 |
#' est_fit <- optim( |
|
| 71 |
#' par = est$starting_values, |
|
| 72 |
#' fn = est$objective_function, |
|
| 73 |
#' gr = est$gradient_function, |
|
| 74 |
#' lavaan_model = fit, |
|
| 75 |
#' method = "BFGS" |
|
| 76 |
#' ) |
|
| 77 |
#' est$get_coef( |
|
| 78 |
#' parameter_values = est_fit$par, |
|
| 79 |
#' lavaan_model = fit |
|
| 80 |
#' ) |
|
| 81 |
#' |
|
| 82 |
#' # This is identical to |
|
| 83 |
#' coef(sem(model, |
|
| 84 |
#' data = PoliticalDemocracy |
|
| 85 |
#' )) |
|
| 86 |
#' |
|
| 87 |
#' # Example using ridge regularization for parameter a |
|
| 88 |
#' fn_ridge <- function(parameter_values, lavaan_model, est, lambda) {
|
|
| 89 |
#' return(est$objective_function( |
|
| 90 |
#' parameter_values = parameter_values, |
|
| 91 |
#' lavaan_model = lavaan_model |
|
| 92 |
#' ) + lambda * parameter_values[6]^2) |
|
| 93 |
#' } |
|
| 94 |
#' ridge_fit <- optim( |
|
| 95 |
#' par = est$get_coef(est$starting_values, |
|
| 96 |
#' lavaan_model = fit |
|
| 97 |
#' ), |
|
| 98 |
#' fn = fn_ridge, |
|
| 99 |
#' lavaan_model = fit, |
|
| 100 |
#' est = est, |
|
| 101 |
#' lambda = 10 |
|
| 102 |
#' ) |
|
| 103 |
#' est$get_coef( |
|
| 104 |
#' parameter_values = ridge_fit$par, |
|
| 105 |
#' lavaan_model = fit |
|
| 106 |
#' ) |
|
| 107 |
lav_export_estimation <- function(lavaan_model) {
|
|
| 108 |
# define objective function |
|
| 109 | ! |
objective_function <- function(parameter_values, |
| 110 | ! |
lavaan_model) {
|
| 111 | ! |
if (lavaan_model@Model@eq.constraints) {
|
| 112 | ! |
parameter_values <- as.numeric(lavaan_model@Model@eq.constraints.K %*% parameter_values) + |
| 113 | ! |
lavaan_model@Model@eq.constraints.k0 |
| 114 |
} |
|
| 115 | ||
| 116 |
# create group list |
|
| 117 | ! |
GLIST <- lav_model_x2glist(lavaan_model@Model, x = parameter_values) |
| 118 |
# get objective function **value** |
|
| 119 | ! |
fx <- lav_model_objective( |
| 120 | ! |
lavmodel = lavaan_model@Model, |
| 121 | ! |
GLIST = GLIST, |
| 122 | ! |
lavsamplestats = lavaan_model@SampleStats, |
| 123 | ! |
lavdata = lavaan_model@Data, |
| 124 | ! |
lavcache = list() |
| 125 |
) |
|
| 126 | ! |
if (lavaan_model@Options$estimator == "PML") {
|
| 127 |
# rescale objective function value |
|
| 128 | ! |
fx <- fx / lavaan_model@SampleStats@ntotal |
| 129 |
} |
|
| 130 | ||
| 131 | ! |
if (!is.finite(fx)) {
|
| 132 | ! |
fx.group <- attr(fx, "fx.group") |
| 133 | ! |
fx <- 1e+20 |
| 134 | ! |
attr(fx, "fx.group") <- fx.group |
| 135 |
} |
|
| 136 | ! |
return(fx) |
| 137 |
} |
|
| 138 | ||
| 139 |
# define gradient function |
|
| 140 | ! |
gradient_function <- function(parameter_values, |
| 141 | ! |
lavaan_model) {
|
| 142 | ! |
if (lavaan_model@Model@eq.constraints) {
|
| 143 | ! |
parameter_values <- as.numeric(lavaan_model@Model@eq.constraints.K %*% parameter_values) + |
| 144 | ! |
lavaan_model@Model@eq.constraints.k0 |
| 145 |
} |
|
| 146 | ||
| 147 | ! |
GLIST <- lav_model_x2glist(lavaan_model@Model, |
| 148 | ! |
x = parameter_values |
| 149 |
) |
|
| 150 | ! |
current.verbose <- lav_verbose() |
| 151 | ! |
if (lav_verbose(FALSE)) |
| 152 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 153 | ! |
dx <- lav_model_gradient( |
| 154 | ! |
lavmodel = lavaan_model@Model, |
| 155 | ! |
GLIST = GLIST, |
| 156 | ! |
lavsamplestats = lavaan_model@SampleStats, |
| 157 | ! |
lavdata = lavaan_model@Data, |
| 158 | ! |
lavcache = list(), |
| 159 | ! |
type = "free", |
| 160 | ! |
group.weight = !(lavaan_model@SampleStats@missing.flag || lavaan_model@Options$estimator == "PML"), |
| 161 | ! |
ceq.simple = lavaan_model@Model@ceq.simple.only |
| 162 |
) |
|
| 163 | ! |
lav_verbose(current.verbose) |
| 164 | ||
| 165 | ! |
if (lavaan_model@Model@eq.constraints) {
|
| 166 | ! |
dx <- as.numeric(dx %*% lavaan_model@Model@eq.constraints.K) |
| 167 |
} |
|
| 168 | ! |
if (lavaan_model@Options$estimator == "PML") {
|
| 169 | ! |
dx <- dx / lavaan_model@SampleStats@ntotal |
| 170 |
} |
|
| 171 | ! |
return(dx) |
| 172 |
} |
|
| 173 | ||
| 174 |
# extract bounds |
|
| 175 | ! |
lower <- lavaan_model@ParTable$lower[lavaan_model@ParTable$free > 0L] |
| 176 | ! |
upper <- lavaan_model@ParTable$upper[lavaan_model@ParTable$free > 0L] |
| 177 | ||
| 178 |
# get starting values |
|
| 179 | ! |
starting_values <- lav_model_get_parameters(lavaan_model@Model) |
| 180 | ! |
if (lavaan_model@Model@eq.constraints) {
|
| 181 | ! |
starting_values <- as.numeric((starting_values - lavaan_model@Model@eq.constraints.k0) %*% |
| 182 | ! |
lavaan_model@Model@eq.constraints.K) |
| 183 |
} |
|
| 184 | ||
| 185 |
# lavaan internally uses transformations when there are equality constraints. |
|
| 186 |
# As a result, the parameters are not necessarily those one would expect when |
|
| 187 |
# fitting the model. The parameters can be translated with the following function: |
|
| 188 | ! |
get_coef <- function(parameter_values, |
| 189 | ! |
lavaan_model) {
|
| 190 | ! |
if (lavaan_model@Model@eq.constraints) {
|
| 191 | ! |
parameter_values <- as.numeric(lavaan_model@Model@eq.constraints.K %*% parameter_values) + |
| 192 | ! |
lavaan_model@Model@eq.constraints.k0 |
| 193 |
} |
|
| 194 | ! |
names(parameter_values) <- lav_partable_labels(lavaan_model@ParTable, |
| 195 | ! |
type = "free" |
| 196 |
) |
|
| 197 | ! |
return(parameter_values) |
| 198 |
} |
|
| 199 | ||
| 200 |
# Now we just return everything so that the user can use their own optimizer |
|
| 201 | ! |
return( |
| 202 | ! |
list( |
| 203 | ! |
get_coef = get_coef, |
| 204 | ! |
starting_values = starting_values, |
| 205 | ! |
objective_function = objective_function, |
| 206 | ! |
gradient_function = gradient_function, |
| 207 | ! |
lower = lower, |
| 208 | ! |
upper = upper |
| 209 |
) |
|
| 210 |
) |
|
| 211 |
} |
| 1 |
lav_lavaan_step03_data <- function(slotData = NULL, # nolint |
|
| 2 |
lavoptions = NULL, |
|
| 3 |
ov.names = NULL, |
|
| 4 |
ov.names.y = NULL, |
|
| 5 |
group = NULL, |
|
| 6 |
data = NULL, |
|
| 7 |
cluster = NULL, |
|
| 8 |
ov.names.x = NULL, |
|
| 9 |
ov.names.l = NULL, |
|
| 10 |
ordered = NULL, |
|
| 11 |
sampling.weights = NULL, |
|
| 12 |
sample.cov = NULL, |
|
| 13 |
sample.mean = NULL, |
|
| 14 |
sample.th = NULL, |
|
| 15 |
sample.nobs = NULL, |
|
| 16 |
slotParTable = NULL, # nolint |
|
| 17 |
ngroups = NULL, |
|
| 18 |
dotdotdot = NULL, |
|
| 19 |
flat.model = NULL, |
|
| 20 |
model = NULL, |
|
| 21 |
NACOV = NULL, # nolint |
|
| 22 |
WLS.V = NULL) { # nolint
|
|
| 23 |
# # # # # # # # # # # |
|
| 24 |
# # 3. lavdata # # |
|
| 25 |
# # # # # # # # # # # |
|
| 26 | ||
| 27 |
# if slotData not null |
|
| 28 |
# copy slotData to lavdata |
|
| 29 |
# else |
|
| 30 |
# create lavdata via function lav_lavdata, setting ov.names to ov.names.y |
|
| 31 |
# if lavoptions$conditional.x |
|
| 32 |
# if lavdata$data.type is "none" |
|
| 33 |
# set lavoptions$do.fit to FALSE |
|
| 34 |
# if flat.model$est not null set lavoptions$start to "est", else set |
|
| 35 |
# it to "simple" |
|
| 36 |
# set lavoptions$se and lavoptions$test to "none" |
|
| 37 |
# else |
|
| 38 |
# if lavdata$data.type is "moment" |
|
| 39 |
# if estimator one of MLM, MLMV, MLR, ULSM, ULSMV, ULSMVS and NACOV |
|
| 40 |
# is NULL: *** error *** |
|
| 41 |
# if estimator one of WLS, WLSM, WLSMV, WLSMVS, DWLS and WLS.V is |
|
| 42 |
# NULL: *** error *** |
|
| 43 |
# if lavoptions$se = bootstrap: *** error *** |
|
| 44 |
# if slotPartable not NULL and model is lavaan-object, check equality |
|
| 45 |
# ngroups and lavdata$ngroups |
|
| 46 |
# --> *** error *** if not |
|
| 47 | ||
| 48 | 140x |
if (!is.null(slotData)) {
|
| 49 | 61x |
lavdata <- slotData |
| 50 |
} else {
|
|
| 51 | 79x |
if (lav_verbose()) {
|
| 52 | ! |
cat("lavdata ...")
|
| 53 |
} |
|
| 54 |
# FIXME: ov.names should always contain both y and x! |
|
| 55 | 79x |
tmp.ov.names <- if (lavoptions$conditional.x) {
|
| 56 | 2x |
ov.names.y |
| 57 |
} else {
|
|
| 58 | 77x |
ov.names |
| 59 |
} |
|
| 60 | 79x |
lavdata <- lav_lavdata( |
| 61 | 79x |
data = data, |
| 62 | 79x |
group = group, |
| 63 | 79x |
cluster = cluster, |
| 64 | 79x |
ov.names = tmp.ov.names, |
| 65 | 79x |
ov.names.x = ov.names.x, |
| 66 | 79x |
ov.names.l = ov.names.l, |
| 67 | 79x |
ordered = ordered, |
| 68 | 79x |
sampling.weights = sampling.weights, |
| 69 | 79x |
sample.cov = sample.cov, |
| 70 | 79x |
sample.mean = sample.mean, |
| 71 | 79x |
sample.th = sample.th, |
| 72 | 79x |
sample.nobs = sample.nobs, |
| 73 | 79x |
lavoptions = lavoptions |
| 74 |
) |
|
| 75 | ||
| 76 | 79x |
if (lav_verbose()) {
|
| 77 | ! |
cat(" done.\n")
|
| 78 |
} |
|
| 79 |
} |
|
| 80 |
# what have we learned from the data? |
|
| 81 | 140x |
if (lavdata@data.type == "none") {
|
| 82 | 2x |
lavoptions$do.fit <- FALSE |
| 83 |
# check if 'model' was a fitted parameter table |
|
| 84 | 2x |
lavoptions$start <- ifelse(is.null(flat.model$est), "simple", "est") |
| 85 | 2x |
lavoptions$se <- "none" |
| 86 | 2x |
lavoptions$test <- "none" |
| 87 | 138x |
} else if (lavdata@data.type == "moment") {
|
| 88 |
# check user-specified options first |
|
| 89 | 52x |
if (!is.null(dotdotdot$estimator)) {
|
| 90 | ! |
if (any(dotdotdot$estimator == c( |
| 91 | ! |
"MLM", "MLMV", "MLR", "MLR", |
| 92 | ! |
"ULSM", "ULSMV", "ULSMVS" |
| 93 |
)) && |
|
| 94 | ! |
is.null(NACOV)) {
|
| 95 | ! |
lav_msg_stop(gettextf( |
| 96 | ! |
"estimator %s requires full data or user-provided NACOV", |
| 97 | ! |
dotdotdot$estimator)) |
| 98 | ! |
} else if (any(dotdotdot$estimator == c( |
| 99 | ! |
"WLS", "WLSM", "WLSMV", |
| 100 | ! |
"WLSMVS", "DWLS" |
| 101 |
)) && |
|
| 102 | ! |
is.null(WLS.V)) {
|
| 103 | ! |
lav_msg_stop(gettextf( |
| 104 | ! |
"estimator %s requires full data or user-provided WLS.V and NACOV", |
| 105 | ! |
dotdotdot$estimator)) |
| 106 |
} |
|
| 107 |
} |
|
| 108 |
# catch here some options that will not work with moments |
|
| 109 | 52x |
if (lavoptions$se == "bootstrap") {
|
| 110 | ! |
lav_msg_stop(gettext("bootstrapping requires full data"))
|
| 111 |
} |
|
| 112 |
# more needed? |
|
| 113 |
} |
|
| 114 |
# sanity check |
|
| 115 | 140x |
if (!is.null(slotParTable) || inherits(model, "lavaan")) {
|
| 116 | ! |
if (ngroups != lavdata@ngroups) {
|
| 117 | ! |
lav_msg_stop(gettext( |
| 118 | ! |
"mismatch between number of groups in data |
| 119 | ! |
and number of groups in model.")) |
| 120 |
} |
|
| 121 |
} |
|
| 122 | 140x |
if (lav_verbose()) {
|
| 123 | ! |
print(lavdata) |
| 124 |
} |
|
| 125 | 140x |
if (lav_debug()) {
|
| 126 | ! |
print(str(lavdata)) |
| 127 |
} |
|
| 128 |
# if lavdata@nlevels > 1L, adapt start option (for now) |
|
| 129 |
# until we figure out how to handle groups+blocks |
|
| 130 |
# if(lavdata@nlevels > 1L) {
|
|
| 131 |
# lavoptions$start <- "simple" |
|
| 132 |
# } |
|
| 133 | ||
| 134 | 140x |
list( |
| 135 | 140x |
lavdata = lavdata, |
| 136 | 140x |
lavoptions = lavoptions |
| 137 |
) |
|
| 138 |
} |
| 1 |
# compute sample statistics for the unrestricted (h1) model |
|
| 2 |
# and also the logl (if available) |
|
| 3 |
lav_h1_implied_logl <- function(lavdata = NULL, |
|
| 4 |
lavsamplestats = NULL, |
|
| 5 |
lavpartable = NULL, # multilevel + missing |
|
| 6 |
lavoptions = NULL) {
|
|
| 7 | 77x |
lavpta <- NULL |
| 8 | 77x |
if (!is.null(lavpartable)) {
|
| 9 | 77x |
lavpta <- lav_partable_attributes(lavpartable) |
| 10 | 77x |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 11 |
} |
|
| 12 | ||
| 13 |
# single-level case |
|
| 14 | 77x |
if (lavdata@nlevels == 1L) {
|
| 15 | ||
| 16 |
# missing data |
|
| 17 | 75x |
if (lavsamplestats@missing.flag) {
|
| 18 | 8x |
if (lavoptions$conditional.x) {
|
| 19 | ! |
implied <- list() # not available yet |
| 20 |
} else {
|
|
| 21 | 8x |
implied <- list( |
| 22 | 8x |
cov = lavsamplestats@cov, |
| 23 | 8x |
mean = lavsamplestats@mean, |
| 24 | 8x |
th = lavsamplestats@th, |
| 25 | 8x |
group.w = lavsamplestats@group.w |
| 26 |
) |
|
| 27 |
# insert ML estimates |
|
| 28 | 8x |
for (g in 1:lavdata@ngroups) {
|
| 29 |
# zero coverage? |
|
| 30 | 8x |
if (any(lav_matrix_vech(lavdata@Mp[[g]]$coverage, |
| 31 | 8x |
diagonal = FALSE) == 0L)) {
|
| 32 | ! |
out <- lav_mvnorm_missing_h1_estimate_moments_chol( |
| 33 | ! |
lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 34 | ! |
lavoptions = lavoptions, group = g) |
| 35 | ! |
implied$cov[[g]] <- out$Sigma |
| 36 | ! |
implied$mean[[g]] <- out$Mu |
| 37 |
} else {
|
|
| 38 |
# regular EM estimates |
|
| 39 | 8x |
implied$cov[[g]] <- lavsamplestats@missing.h1[[g]]$sigma |
| 40 | 8x |
implied$mean[[g]] <- lavsamplestats@missing.h1[[g]]$mu |
| 41 |
} |
|
| 42 |
} |
|
| 43 |
} |
|
| 44 | ||
| 45 |
# complete data |
|
| 46 |
} else {
|
|
| 47 | 67x |
if (lavoptions$conditional.x) {
|
| 48 | 2x |
implied <- list( |
| 49 | 2x |
res.cov = lavsamplestats@res.cov, |
| 50 | 2x |
res.int = lavsamplestats@res.int, |
| 51 | 2x |
res.slopes = lavsamplestats@res.slopes, |
| 52 | 2x |
cov.x = lavsamplestats@cov.x, |
| 53 | 2x |
mean.x = lavsamplestats@mean.x, |
| 54 | 2x |
res.th = lavsamplestats@res.th, |
| 55 | 2x |
group.w = lavsamplestats@group.w |
| 56 |
) |
|
| 57 |
} else {
|
|
| 58 | 65x |
implied <- list( |
| 59 | 65x |
cov = lavsamplestats@cov, |
| 60 | 65x |
mean = lavsamplestats@mean, |
| 61 | 65x |
th = lavsamplestats@th, |
| 62 | 65x |
group.w = lavsamplestats@group.w |
| 63 |
) |
|
| 64 |
} |
|
| 65 |
} # complete data |
|
| 66 | ||
| 67 | 75x |
logl <- lav_h1_logl( |
| 68 | 75x |
lavdata = lavdata, |
| 69 | 75x |
lavsamplestats = lavsamplestats, |
| 70 | 75x |
h1.implied = implied, |
| 71 | 75x |
lavoptions = lavoptions |
| 72 |
) |
|
| 73 |
} else {
|
|
| 74 |
# estimate Mu.B, Mu.W, Sigma.B and Sigma.W for unrestricted model |
|
| 75 | 2x |
ngroups <- lavdata@ngroups |
| 76 | 2x |
nlevels <- lavdata@nlevels |
| 77 | 2x |
implied <- list( |
| 78 | 2x |
cov = vector("list", length = ngroups * nlevels),
|
| 79 | 2x |
mean = vector("list", length = ngroups * nlevels)
|
| 80 |
) |
|
| 81 | 2x |
loglik.group <- numeric(lavdata@ngroups) |
| 82 | ||
| 83 | 2x |
for (g in 1:lavdata@ngroups) {
|
| 84 | 4x |
if (lav_verbose()) {
|
| 85 | ! |
cat("\n\nfitting unrestricted (H1) model in group ", g, "\n")
|
| 86 |
} |
|
| 87 | 4x |
if (lavsamplestats@missing.flag) {
|
| 88 |
# missing data |
|
| 89 | ||
| 90 |
# 1. first a few EM iteration faking complete data |
|
| 91 |
# Y1 <- lavdata@X[[g]] |
|
| 92 |
# cluster.idx <- lavdata@Lp[[g]]$cluster.idx[[2]] |
|
| 93 |
# Y2.complete <- unname(as.matrix(aggregate(Y1, |
|
| 94 |
# by = list(cluster.idx), |
|
| 95 |
# FUN = function(x) {
|
|
| 96 |
# if( all(is.na(x)) ) { # all elements are NA
|
|
| 97 |
# as.numeric(0) # in this cluster |
|
| 98 |
# } else {
|
|
| 99 |
# mean(x, na.rm = TRUE) |
|
| 100 |
# } |
|
| 101 |
# })[,-1])) |
|
| 102 |
# YLp = lavsamplestats@YLp[[g]] |
|
| 103 |
# YLp[[2]]$Y2 <- Y2.complete |
|
| 104 |
# OUT <- lav_mvnorm_cluster_em_sat( |
|
| 105 |
# YLp = YLp, |
|
| 106 |
# Lp = lavdata@Lp[[g]], |
|
| 107 |
# verbose = TRUE, # for now |
|
| 108 |
# tol = 1e-04, |
|
| 109 |
# min.variance = 1e-05, |
|
| 110 |
# max.iter = 5L) |
|
| 111 |
## create tmp lav1, only for this group |
|
| 112 |
# implied$cov[[ (g-1)*nlevels + 1L]] <- OUT$Sigma.W |
|
| 113 |
# implied$cov[[ (g-1)*nlevels + 2L]] <- OUT$Sigma.B |
|
| 114 |
# implied$mean[[(g-1)*nlevels + 1L]] <- OUT$Mu.W |
|
| 115 |
# implied$mean[[(g-1)*nlevels + 2L]] <- OUT$Mu.B |
|
| 116 |
# loglik.group[g] <- OUT$logl |
|
| 117 |
# lavh1 <- list(implied = implied, logl = sum(loglik.group)) |
|
| 118 |
# lavpartable <- lav_partable_unrestricted(lavdata = lavdata, |
|
| 119 |
# lavsamplestats = lavsamplestats, lavoptions = lavoptions, |
|
| 120 |
# lavpta = lavpta, lavh1 = lavh1) |
|
| 121 |
# lavpartable$lower <- rep(-Inf, length(lavpartable$lhs)) |
|
| 122 |
# var.idx <- which(lavpartable$free > 0L & |
|
| 123 |
# lavpartable$op == "~~" & |
|
| 124 |
# lavpartable$lhs == lavpartable$rhs) |
|
| 125 |
# lavpartable$lower[var.idx] <- 1e-05 |
|
| 126 | ||
| 127 | ! |
lavpartable <- lav_partable_unrestricted_chol( |
| 128 | ! |
lavdata = lavdata, |
| 129 | ! |
lavoptions = lavoptions, lavpta = lavpta |
| 130 |
) |
|
| 131 | ||
| 132 | ! |
lavoptions2 <- lavoptions |
| 133 | ! |
lavoptions2$estimator <- "ML" |
| 134 | ! |
lavoptions2$se <- "none" |
| 135 | ! |
lavoptions2$test <- "none" |
| 136 | ! |
lavoptions2$do.fit <- TRUE |
| 137 | ! |
lavoptions2$optim.method <- "nlminb" |
| 138 | ! |
lavoptions2$h1 <- FALSE |
| 139 | ! |
lavoptions2$implied <- TRUE |
| 140 | ! |
lavoptions2$loglik <- TRUE |
| 141 | ! |
lavoptions2$baseline <- FALSE |
| 142 | ! |
lavoptions2$fixed.x <- FALSE # even if model uses fixed.x=TRUE |
| 143 | ! |
lavoptions2$model.type <- "unrestricted" |
| 144 | ! |
lavoptions2$optim.attempts <- 4L |
| 145 | ! |
lavoptions2$check.gradient <- FALSE |
| 146 | ! |
lavoptions2$optim.force.convergence <- TRUE # for now... |
| 147 | ! |
lavoptions2$control <- list(rel.tol = 1e-7) |
| 148 |
# FIT <- lavaan(lavpartable, slotOptions = lavoptions2, |
|
| 149 |
# slotSampleStats = lavsamplestats, |
|
| 150 |
# slotData = lavdata, sloth1 = lavh1) |
|
| 151 | ! |
FIT <- lavaan(lavpartable, |
| 152 | ! |
slotOptions = lavoptions2, |
| 153 | ! |
slotSampleStats = lavsamplestats, |
| 154 | ! |
slotData = lavdata, |
| 155 | ! |
warn = FALSE |
| 156 |
) |
|
| 157 | ! |
OUT <- list( |
| 158 | ! |
Sigma.W = FIT@implied$cov[[1]], |
| 159 | ! |
Sigma.B = FIT@implied$cov[[2]], |
| 160 | ! |
Mu.W = FIT@implied$mean[[1]], |
| 161 | ! |
Mu.B = FIT@implied$mean[[2]], |
| 162 | ! |
logl = FIT@loglik$loglik |
| 163 |
) |
|
| 164 |
# if(lavoptions$fixed.x) {
|
|
| 165 |
# OUT$logl <- OUT$logl - lavsamplestats@YLp[[g]][[2]]$loglik.x |
|
| 166 |
# } |
|
| 167 |
} else {
|
|
| 168 |
# complete data |
|
| 169 | 4x |
OUT <- lav_mvnorm_cluster_em_sat( |
| 170 | 4x |
YLp = lavsamplestats@YLp[[g]], |
| 171 | 4x |
Lp = lavdata@Lp[[g]], |
| 172 | 4x |
tol = 1e-04, # option? |
| 173 | 4x |
min.variance = 1e-05, # option? |
| 174 | 4x |
max.iter = 5000L |
| 175 | 4x |
) # option? |
| 176 |
} |
|
| 177 | 4x |
if (lav_verbose()) {
|
| 178 | ! |
cat("\n")
|
| 179 |
} |
|
| 180 | ||
| 181 |
# if any near-zero within variance(s), produce warning here |
|
| 182 | 4x |
zero.var <- which(diag(OUT$Sigma.W) <= 1e-05) |
| 183 | 4x |
if (length(zero.var)) {
|
| 184 | ! |
gtxt <- if (ngroups > 1L) {
|
| 185 | ! |
gettextf(" in group %s.", g)
|
| 186 |
} else {
|
|
| 187 |
" " |
|
| 188 |
} |
|
| 189 | ! |
lav_msg_warn(gettextf( |
| 190 | ! |
"H1 estimation resulted in a within covariance matrix %1$s with |
| 191 | ! |
(near) zero variances for some of the level-1 variables: %2$s", |
| 192 | ! |
gtxt, lav_msg_view(lavdata@ov.names.l[[g]][[1]][zero.var])) |
| 193 |
) |
|
| 194 |
} |
|
| 195 | ||
| 196 |
# new in 0.6-18: ensure Mu.W[both.idx] is zero (post-estimation!) |
|
| 197 |
# (not correctly; fixed in 0.6-19...) |
|
| 198 | 4x |
both.idx <- lavdata@Lp[[g]]$both.idx[[2]] |
| 199 | 4x |
within.idx <- lavdata@Lp[[g]]$within.idx[[2]] |
| 200 | 4x |
ov.idx <- lavdata@Lp[[g]]$ov.idx |
| 201 | 4x |
p.tilde <- length(unique(c(ov.idx[[1]], ov.idx[[2]]))) |
| 202 | 4x |
Mu.W.tilde <- Mu.B.tilde <- Mu.WB.tilde <- numeric(p.tilde) |
| 203 | 4x |
Mu.W.tilde[ov.idx[[1]]] <- OUT$Mu.W |
| 204 | 4x |
Mu.B.tilde[ov.idx[[2]]] <- OUT$Mu.B |
| 205 | 4x |
Mu.WB.tilde[both.idx ] <- (Mu.B.tilde[both.idx] + Mu.W.tilde[both.idx]) |
| 206 | 4x |
Mu.W.tilde[both.idx] <- 0 |
| 207 | 4x |
Mu.B.tilde[both.idx] <- Mu.WB.tilde[both.idx] |
| 208 | 4x |
OUT$Mu.W <- Mu.W.tilde[ ov.idx[[1]] ] |
| 209 | 4x |
OUT$Mu.B <- Mu.B.tilde[ ov.idx[[2]] ] |
| 210 | ||
| 211 |
# store in implied |
|
| 212 | 4x |
implied$cov[[ (g - 1) * nlevels + 1L]] <- OUT$Sigma.W |
| 213 | 4x |
implied$cov[[ (g - 1) * nlevels + 2L]] <- OUT$Sigma.B |
| 214 | 4x |
implied$mean[[(g - 1) * nlevels + 1L]] <- OUT$Mu.W |
| 215 | 4x |
implied$mean[[(g - 1) * nlevels + 2L]] <- OUT$Mu.B |
| 216 | ||
| 217 |
# store logl per group |
|
| 218 | 4x |
loglik.group[g] <- OUT$logl |
| 219 |
} |
|
| 220 | ||
| 221 | 2x |
logl <- list(loglik = sum(loglik.group), loglik.group = loglik.group) |
| 222 |
} |
|
| 223 | ||
| 224 | 77x |
list(implied = implied, logl = logl) |
| 225 |
} |
| 1 |
# lavaanList: fit the *same* model, on different datasets |
|
| 2 |
# YR - 29 Jun 2016 |
|
| 3 |
# YR - 27 Jan 2017: change lavoptions; add dotdotdot to each call |
|
| 4 |
# TDJ - 23 Aug 2018: change wrappers to preserve arguments from match.call() |
|
| 5 |
# YR - 15 Oct 2024: add iseed (as in lavBootstrap) |
|
| 6 | ||
| 7 |
lavaanList <- function(model = NULL, # model |
|
| 8 |
dataList = NULL, # list of datasets |
|
| 9 |
dataFunction = NULL, # generating function |
|
| 10 |
dataFunction.args = list(), # optional arguments |
|
| 11 |
ndat = length(dataList), # how many datasets? |
|
| 12 |
cmd = "lavaan", |
|
| 13 |
..., |
|
| 14 |
store.slots = c("partable"), # default is partable
|
|
| 15 |
FUN = NULL, # arbitrary FUN |
|
| 16 |
show.progress = FALSE, |
|
| 17 |
store.failed = FALSE, |
|
| 18 |
parallel = c("no", "multicore", "snow"),
|
|
| 19 |
ncpus = max(1L, parallel::detectCores() - 1L), |
|
| 20 |
cl = NULL, |
|
| 21 |
iseed = NULL) {
|
|
| 22 |
# store.slots call |
|
| 23 | ! |
mc <- match.call() |
| 24 | ||
| 25 |
# store current random seed (if any) and method |
|
| 26 | ! |
RNGkind_old <- RNGkind() |
| 27 |
#cat("RNGkind = ", paste(RNGkind_old, collapse = " "), "\n")
|
|
| 28 | ! |
if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 29 | ! |
init.seed <- get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
|
| 30 |
} else {
|
|
| 31 | ! |
init.seed <- NULL |
| 32 |
} |
|
| 33 | ||
| 34 |
# initial seed (for the precomputations) |
|
| 35 | ! |
if (!is.null(iseed)) {
|
| 36 | ! |
set.seed(min(1, iseed - 1L)) |
| 37 |
} |
|
| 38 | ||
| 39 |
# check store.slots |
|
| 40 | ! |
store.slots <- tolower(store.slots) |
| 41 | ! |
if (length(store.slots) == 1L && store.slots == "all") {
|
| 42 | ! |
store.slots <- c( |
| 43 | ! |
"timing", "partable", "data", "samplestats", |
| 44 | ! |
"cache", "loglik", "h1", "baseline", "external", |
| 45 | ! |
"vcov", "test", "optim", "implied" |
| 46 |
) |
|
| 47 |
} |
|
| 48 | ||
| 49 |
# dataList or function? |
|
| 50 | ! |
if (is.function(dataFunction)) {
|
| 51 | ! |
if (ndat == 0L) {
|
| 52 | ! |
lav_msg_stop(gettext("please specify number of requested datasets (ndat)"))
|
| 53 |
} |
|
| 54 |
# here we already use the random generator |
|
| 55 | ! |
firstData <- do.call(dataFunction, args = dataFunction.args) |
| 56 |
# dataList <- vector("list", length = ndat)
|
|
| 57 |
} else {
|
|
| 58 | ! |
firstData <- dataList[[1]] |
| 59 |
} |
|
| 60 | ||
| 61 |
# check data |
|
| 62 | ! |
if (is.matrix(firstData)) {
|
| 63 |
# check if we have column names? |
|
| 64 | ! |
NAMES <- colnames(firstData) |
| 65 | ! |
if (is.null(NAMES)) {
|
| 66 | ! |
lav_msg_stop(gettext("data is a matrix without column names"))
|
| 67 |
} |
|
| 68 | ! |
} else if (inherits(firstData, "data.frame")) {
|
| 69 |
# check? |
|
| 70 |
} else {
|
|
| 71 | ! |
lav_msg_stop(gettext("(generated) data is not a data.frame (or a matrix)"))
|
| 72 |
} |
|
| 73 | ||
| 74 |
# dot dot dot |
|
| 75 | ! |
dotdotdot <- list(...) |
| 76 | ||
| 77 |
# if 'model' is a lavaan object (perhaps from lavSimulate), no need to |
|
| 78 |
# call `cmd' |
|
| 79 | ! |
if (inherits(model, "lavaan")) {
|
| 80 | ! |
FIT <- model |
| 81 |
} else {
|
|
| 82 |
# adapt for FIT |
|
| 83 |
# dotdotdotFIT <- dotdotdot |
|
| 84 |
# dotdotdotFIT$do.fit <- TRUE # to get starting values |
|
| 85 |
# dotdotdotFIT$se <- "none" |
|
| 86 |
# dotdotdotFIT$test <- "none" |
|
| 87 | ||
| 88 |
# initial model fit, using first dataset |
|
| 89 | ! |
FIT <- do.call(cmd, |
| 90 | ! |
args = c(list( |
| 91 | ! |
model = model, |
| 92 | ! |
data = firstData |
| 93 | ! |
), dotdotdot) |
| 94 |
) |
|
| 95 |
} |
|
| 96 | ||
| 97 | ! |
lavoptions <- FIT@Options |
| 98 | ! |
lavmodel <- FIT@Model |
| 99 | ! |
lavpartable <- FIT@ParTable |
| 100 | ! |
lavpta <- FIT@pta |
| 101 | ||
| 102 |
# remove any options in lavoptions from dotdotdot (sem/lavaan only) |
|
| 103 |
# because we can use the lavoptions slot |
|
| 104 | ! |
if (length(dotdotdot) > 0L && cmd %in% c("lavaan", "sem", "cfa", "growth")) {
|
| 105 | ! |
rm.idx <- which(names(dotdotdot) %in% names(lavoptions)) |
| 106 | ! |
if (length(rm.idx) > 0L) {
|
| 107 | ! |
dotdotdot <- dotdotdot[-rm.idx] |
| 108 |
} |
|
| 109 |
} |
|
| 110 | ||
| 111 |
# remove start/est/se columns from lavpartable |
|
| 112 | ! |
lavpartable$start <- lavpartable$est <- lavpartable$se <- NULL |
| 113 | ||
| 114 |
# empty slots |
|
| 115 | ! |
timingList <- ParTableList <- DataList <- SampleStatsList <- |
| 116 | ! |
CacheList <- vcovList <- testList <- optimList <- |
| 117 | ! |
h1List <- loglikList <- baselineList <- |
| 118 | ! |
impliedList <- funList <- list() |
| 119 | ||
| 120 |
# prepare store.slotsd slots |
|
| 121 | ! |
if ("timing" %in% store.slots) {
|
| 122 | ! |
timingList <- vector("list", length = ndat)
|
| 123 |
} |
|
| 124 | ! |
if ("partable" %in% store.slots) {
|
| 125 | ! |
ParTableList <- vector("list", length = ndat)
|
| 126 |
} |
|
| 127 | ! |
if ("data" %in% store.slots) {
|
| 128 | ! |
DataList <- vector("list", length = ndat)
|
| 129 |
} |
|
| 130 | ! |
if ("samplestats" %in% store.slots) {
|
| 131 | ! |
SampleStatsList <- vector("list", length = ndat)
|
| 132 |
} |
|
| 133 | ! |
if ("cache" %in% store.slots) {
|
| 134 | ! |
CacheList <- vector("list", length = ndat)
|
| 135 |
} |
|
| 136 | ! |
if ("vcov" %in% store.slots) {
|
| 137 | ! |
vcovList <- vector("list", length = ndat)
|
| 138 |
} |
|
| 139 | ! |
if ("test" %in% store.slots) {
|
| 140 | ! |
testList <- vector("list", length = ndat)
|
| 141 |
} |
|
| 142 | ! |
if ("optim" %in% store.slots) {
|
| 143 | ! |
optimList <- vector("list", length = ndat)
|
| 144 |
} |
|
| 145 | ! |
if ("implied" %in% store.slots) {
|
| 146 | ! |
impliedList <- vector("list", length = ndat)
|
| 147 |
} |
|
| 148 | ! |
if ("loglik" %in% store.slots) {
|
| 149 | ! |
loglikList <- vector("list", length = ndat)
|
| 150 |
} |
|
| 151 | ! |
if ("h1" %in% store.slots) {
|
| 152 | ! |
h1List <- vector("list", length = ndat)
|
| 153 |
} |
|
| 154 | ! |
if ("baseline" %in% store.slots) {
|
| 155 | ! |
baselineList <- vector("list", length = ndat)
|
| 156 |
} |
|
| 157 | ||
| 158 | ! |
if (!is.null(FUN)) {
|
| 159 | ! |
funList <- vector("list", length = ndat)
|
| 160 |
} |
|
| 161 | ||
| 162 |
# single run |
|
| 163 | ! |
fn <- function(i) {
|
| 164 | ! |
if (show.progress) {
|
| 165 | ! |
cat(" ... data set number:", sprintf("%4d", i))
|
| 166 |
} |
|
| 167 | ||
| 168 |
# get new dataset |
|
| 169 | ! |
if (i == 1L) {
|
| 170 | ! |
DATA <- firstData |
| 171 | ! |
} else if (is.function(dataFunction)) {
|
| 172 | ! |
DATA <- do.call(dataFunction, args = dataFunction.args) |
| 173 | ! |
} else if (is.list(dataList)) {
|
| 174 | ! |
DATA <- dataList[[i]] |
| 175 |
} |
|
| 176 | ||
| 177 |
# if categorical, check if we have enough response categories |
|
| 178 |
# for each ordered variables in DATA |
|
| 179 | ! |
data.ok.flag <- TRUE |
| 180 | ! |
if (FIT@Model@categorical) {
|
| 181 |
# expected nlev |
|
| 182 | ! |
ord.idx <- unique(unlist(FIT@pta$vidx$ov.ord)) |
| 183 | ! |
NLEV.exp <- FIT@Data@ov$nlev[ord.idx] |
| 184 |
# observed nlev |
|
| 185 | ! |
NLEV.obs <- sapply( |
| 186 | ! |
DATA[, unique(unlist(FIT@pta$vnames$ov.ord)), |
| 187 | ! |
drop = FALSE |
| 188 |
], |
|
| 189 | ! |
function(x) length(unique(na.omit(x))) |
| 190 |
) |
|
| 191 | ! |
wrong.idx <- which(NLEV.exp - NLEV.obs != 0) |
| 192 | ! |
if (length(wrong.idx) > 0L) {
|
| 193 | ! |
data.ok.flag <- FALSE |
| 194 |
} |
|
| 195 |
} |
|
| 196 | ||
| 197 |
# adapt lavmodel for this new dataset |
|
| 198 |
# - starting values will be different |
|
| 199 |
# - ov.x variances/covariances |
|
| 200 |
# FIXME: can we not make the changes internally? |
|
| 201 |
# if(lavmodel@fixed.x && length(lav_partable_vnames(lavpartable, "ov.x")) > 0L) {
|
|
| 202 |
# for(g in 1:FIT@Data@ngroups) {
|
|
| 203 |
# |
|
| 204 |
# } |
|
| 205 | ! |
lavmodel <- NULL |
| 206 |
# } |
|
| 207 | ||
| 208 |
# fit model with this (new) dataset |
|
| 209 | ! |
if (data.ok.flag) {
|
| 210 | ! |
if (cmd %in% c("lavaan", "sem", "cfa", "growth")) {
|
| 211 |
# lavoptions$start <- FIT # FIXME: needed? |
|
| 212 | ! |
lavobject <- try( |
| 213 | ! |
do.call("lavaan",
|
| 214 | ! |
args = c( |
| 215 | ! |
list( |
| 216 | ! |
slotOptions = lavoptions, |
| 217 | ! |
slotParTable = lavpartable, |
| 218 | ! |
slotModel = lavmodel, |
| 219 |
# start = FIT, |
|
| 220 | ! |
data = DATA |
| 221 |
), |
|
| 222 | ! |
dotdotdot |
| 223 |
) |
|
| 224 |
), |
|
| 225 | ! |
silent = TRUE |
| 226 |
) |
|
| 227 | ! |
} else if (cmd == "fsr") {
|
| 228 |
# extract fs.method and fsr.method from dotdotdot |
|
| 229 | ! |
if (!is.null(dotdotdot$fs.method)) {
|
| 230 | ! |
fs.method <- dotdotdot$fs.method |
| 231 |
} else {
|
|
| 232 | ! |
fs.method <- formals(fsr)$fs.method # default |
| 233 |
} |
|
| 234 | ||
| 235 | ! |
if (!is.null(dotdotdot$fsr.method)) {
|
| 236 | ! |
fsr.method <- dotdotdot$fsr.method |
| 237 |
} else {
|
|
| 238 | ! |
fsr.method <- formals(fsr)$fsr.method # default |
| 239 |
} |
|
| 240 | ||
| 241 | ! |
lavoptions$start <- FIT # FIXME: needed? |
| 242 | ! |
lavobject <- try( |
| 243 | ! |
do.call("fsr",
|
| 244 | ! |
args = c( |
| 245 | ! |
list( |
| 246 | ! |
slotOptions = lavoptions, |
| 247 | ! |
slotParTable = lavpartable, |
| 248 | ! |
slotModel = lavmodel, |
| 249 |
# start = FIT, |
|
| 250 | ! |
data = DATA, |
| 251 | ! |
cmd = "lavaan", |
| 252 | ! |
fs.method = fs.method, |
| 253 | ! |
fsr.method = fsr.method |
| 254 |
), |
|
| 255 | ! |
dotdotdot |
| 256 |
) |
|
| 257 |
), |
|
| 258 | ! |
silent = TRUE |
| 259 |
) |
|
| 260 | ! |
} else if (cmd == "sam") {
|
| 261 | ! |
lavobject <- try( |
| 262 | ! |
do.call("sam",
|
| 263 | ! |
args = c( |
| 264 | ! |
list( |
| 265 | ! |
model = model, |
| 266 | ! |
data = DATA |
| 267 |
), |
|
| 268 | ! |
dotdotdot |
| 269 |
) |
|
| 270 |
), |
|
| 271 | ! |
silent = TRUE |
| 272 |
) |
|
| 273 |
} else {
|
|
| 274 | ! |
lavobject <- try(do.call(cmd, |
| 275 | ! |
args = c( |
| 276 | ! |
list( |
| 277 | ! |
model = model, |
| 278 | ! |
data = DATA |
| 279 |
), |
|
| 280 | ! |
dotdotdot |
| 281 |
) |
|
| 282 |
), |
|
| 283 | ! |
silent = TRUE |
| 284 |
) |
|
| 285 |
#lav_msg_stop(gettext("unknown cmd:"), cmd)
|
|
| 286 |
} |
|
| 287 | ! |
} # data.ok.flag |
| 288 | ||
| 289 | ! |
RES <- list( |
| 290 | ! |
ok = FALSE, timing = NULL, ParTable = NULL, |
| 291 | ! |
Data = NULL, SampleStats = NULL, vcov = NULL, |
| 292 | ! |
test = NULL, optim = NULL, implied = NULL, |
| 293 | ! |
baseline = NULL, baseline.ok = FALSE, fun = NULL |
| 294 |
) |
|
| 295 | ||
| 296 | ! |
if (data.ok.flag && inherits(lavobject, "lavaan") && |
| 297 | ! |
lavInspect(lavobject, "converged")) {
|
| 298 | ! |
RES$ok <- TRUE |
| 299 | ||
| 300 | ! |
if (show.progress) {
|
| 301 | ! |
cat( |
| 302 | ! |
" OK -- niter = ", |
| 303 | ! |
sprintf("%3d", lavInspect(lavobject, "iterations")),
|
| 304 | ! |
"\n" |
| 305 |
) |
|
| 306 |
} |
|
| 307 | ||
| 308 |
# extract slots from fit |
|
| 309 | ! |
if ("timing" %in% store.slots) {
|
| 310 | ! |
RES$timing <- lavobject@timing |
| 311 |
} |
|
| 312 | ! |
if ("partable" %in% store.slots) {
|
| 313 | ! |
RES$ParTable <- lavobject@ParTable |
| 314 |
} |
|
| 315 | ! |
if ("data" %in% store.slots) {
|
| 316 | ! |
RES$Data <- lavobject@Data |
| 317 |
} |
|
| 318 | ! |
if ("samplestats" %in% store.slots) {
|
| 319 | ! |
RES$SampleStats <- lavobject@SampleStats |
| 320 |
} |
|
| 321 | ! |
if ("cache" %in% store.slots) {
|
| 322 | ! |
RES$Cache <- lavobject@Cache |
| 323 |
} |
|
| 324 | ! |
if ("vcov" %in% store.slots) {
|
| 325 | ! |
RES$vcov <- lavobject@vcov |
| 326 |
} |
|
| 327 | ! |
if ("test" %in% store.slots) {
|
| 328 | ! |
RES$test <- lavobject@test |
| 329 |
} |
|
| 330 | ! |
if ("optim" %in% store.slots) {
|
| 331 | ! |
RES$optim <- lavobject@optim |
| 332 |
} |
|
| 333 | ! |
if ("implied" %in% store.slots) {
|
| 334 | ! |
RES$implied <- lavobject@implied |
| 335 |
} |
|
| 336 | ! |
if ("loglik" %in% store.slots) {
|
| 337 | ! |
RES$loglik <- lavobject@loglik |
| 338 |
} |
|
| 339 | ! |
if ("h1" %in% store.slots) {
|
| 340 | ! |
RES$h1 <- lavobject@h1 |
| 341 |
} |
|
| 342 | ! |
if ("baseline" %in% store.slots) {
|
| 343 | ! |
RES$baseline <- lavobject@baseline |
| 344 | ! |
if (length(lavobject@baseline) > 0L) {
|
| 345 | ! |
RES$baseline.ok <- TRUE |
| 346 |
} |
|
| 347 |
} |
|
| 348 | ||
| 349 |
# custom FUN |
|
| 350 | ! |
if (!is.null(FUN)) {
|
| 351 | ! |
RES$fun <- FUN(lavobject) |
| 352 |
} |
|
| 353 | ! |
} else { # failed!
|
| 354 | ! |
if (show.progress) {
|
| 355 | ! |
if (data.ok.flag) {
|
| 356 | ! |
if (inherits(lavobject, "lavaan")) {
|
| 357 | ! |
cat(" FAILED: no convergence\n")
|
| 358 |
} else {
|
|
| 359 | ! |
cat(" FAILED: could not construct lavobject\n")
|
| 360 | ! |
print(lavobject) |
| 361 |
} |
|
| 362 |
} else {
|
|
| 363 | ! |
cat(" FAILED: nlev too low for some vars\n")
|
| 364 |
} |
|
| 365 |
} |
|
| 366 | ! |
if ("partable" %in% store.slots) {
|
| 367 | ! |
RES$ParTable <- lavpartable |
| 368 | ! |
RES$ParTable$est <- RES$ParTable$start |
| 369 | ! |
RES$ParTable$est[RES$ParTable$free > 0] <- as.numeric(NA) |
| 370 | ! |
RES$ParTable$se <- numeric(length(lavpartable$lhs)) |
| 371 | ! |
RES$ParTable$se[RES$ParTable$free > 0] <- as.numeric(NA) |
| 372 |
} |
|
| 373 | ! |
if (store.failed) {
|
| 374 | ! |
tmpfile <- tempfile(pattern = "lavaanListData") |
| 375 | ! |
datfile <- paste0(tmpfile, ".csv") |
| 376 | ! |
write.csv(DATA, file = datfile, row.names = FALSE) |
| 377 | ! |
if (data.ok.flag) {
|
| 378 |
# or only if lavobject is of class lavaan? |
|
| 379 | ! |
objfile <- paste0(tmpfile, ".RData") |
| 380 | ! |
save(lavobject, file = objfile) |
| 381 |
} |
|
| 382 |
} |
|
| 383 |
} |
|
| 384 | ||
| 385 | ! |
RES |
| 386 |
} |
|
| 387 | ||
| 388 | ||
| 389 |
# the next 8 lines are borrowed from the boot package |
|
| 390 | ! |
have_mc <- have_snow <- FALSE |
| 391 | ! |
if (missing(parallel)) {
|
| 392 | ! |
parallel <- "no" |
| 393 |
} |
|
| 394 | ! |
parallel <- match.arg(parallel) |
| 395 | ! |
if (parallel != "no" && ncpus > 1L) {
|
| 396 | ! |
if (parallel == "multicore") {
|
| 397 | ! |
have_mc <- .Platform$OS.type != "windows" |
| 398 | ! |
} else if (parallel == "snow") have_snow <- TRUE |
| 399 | ! |
if (!have_mc && !have_snow) ncpus <- 1L |
| 400 | ! |
loadNamespace("parallel") # before recording seed!
|
| 401 |
} |
|
| 402 | ||
| 403 |
# iseed: |
|
| 404 |
# this follows a proposal of Shu Fai Cheung (see github issue #240) |
|
| 405 |
# - iseed is used for both serial and parallel |
|
| 406 |
# - if iseed is not set, iseed is generated + .Random.seed created/updated |
|
| 407 |
# -> tmp.seed <- NA |
|
| 408 |
# - if iseed is set: don't touch .Random.seed (if it exists) |
|
| 409 |
# -> tmp.seed <- .Random.seed (if it exists) |
|
| 410 |
# -> tmp.seed <- NULL (if it does not exist) |
|
| 411 | ! |
if (is.null(iseed)) {
|
| 412 | ! |
if (!exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 413 | ! |
runif(1) |
| 414 |
} |
|
| 415 |
# identical(temp.seed, NA): Will not change .Random.seed in GlobalEnv |
|
| 416 | ! |
temp.seed <- NA |
| 417 | ! |
iseed <- runif(1, 0, 999999999) |
| 418 |
} else {
|
|
| 419 | ! |
if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 420 | ! |
temp.seed <- |
| 421 | ! |
get(".Random.seed", envir = .GlobalEnv, inherits = FALSE)
|
| 422 |
} else {
|
|
| 423 |
# is.null(temp.seed): Will remove .Random.seed in GlobalEnv |
|
| 424 |
# if serial. |
|
| 425 |
# If parallel, .Random.seed will not be touched. |
|
| 426 | ! |
temp.seed <- NULL |
| 427 |
} |
|
| 428 |
} |
|
| 429 | ! |
if (!(ncpus > 1L && (have_mc || have_snow))) { # Only for serial
|
| 430 | ! |
set.seed(iseed) |
| 431 |
} |
|
| 432 | ||
| 433 |
# this is adapted from the boot function in package boot |
|
| 434 | ! |
RES <- if (ncpus > 1L && (have_mc || have_snow)) {
|
| 435 | ! |
if (have_mc) {
|
| 436 |
#RNGkind_old <- RNGkind() # store current kind |
|
| 437 | ! |
RNGkind("L'Ecuyer-CMRG") # to allow for reproducible results
|
| 438 | ! |
set.seed(iseed) |
| 439 | ! |
parallel::mclapply(seq_len(ndat), fn, mc.cores = ncpus) |
| 440 | ! |
} else if (have_snow) {
|
| 441 | ! |
list(...) # evaluate any promises |
| 442 | ! |
if (is.null(cl)) {
|
| 443 | ! |
cl <- parallel::makePSOCKcluster(rep("localhost", ncpus))
|
| 444 |
# # No need for |
|
| 445 |
# if(RNGkind()[1L] == "L'Ecuyer-CMRG") |
|
| 446 |
# clusterSetRNGStream() always calls `RNGkind("L'Ecuyer-CMRG")`
|
|
| 447 | ! |
parallel::clusterSetRNGStream(cl, iseed = iseed) |
| 448 | ! |
RES <- parallel::parLapply(cl, seq_len(ndat), fn) |
| 449 | ! |
parallel::stopCluster(cl) |
| 450 | ! |
RES |
| 451 |
} else {
|
|
| 452 | ! |
parallel::parLapply(cl, seq_len(ndat), fn) |
| 453 |
} |
|
| 454 |
} |
|
| 455 |
} else {
|
|
| 456 | ! |
lapply(seq_len(ndat), fn) |
| 457 |
} |
|
| 458 | ||
| 459 | ||
| 460 |
# restructure |
|
| 461 | ! |
if ("baseline" %in% store.slots) {
|
| 462 | ! |
meta <- list( |
| 463 | ! |
ndat = ndat, ok = sapply(RES, "[[", "ok"), |
| 464 | ! |
baseline.ok = sapply(RES, "[[", "baseline.ok"), |
| 465 | ! |
store.slots = store.slots |
| 466 |
) |
|
| 467 |
} else {
|
|
| 468 | ! |
meta <- list( |
| 469 | ! |
ndat = ndat, ok = sapply(RES, "[[", "ok"), |
| 470 | ! |
store.slots = store.slots |
| 471 |
) |
|
| 472 |
} |
|
| 473 | ||
| 474 |
# extract store.slots slots |
|
| 475 | ! |
if ("timing" %in% store.slots) {
|
| 476 | ! |
timingList <- lapply(RES, "[[", "timing") |
| 477 |
} |
|
| 478 | ! |
if ("partable" %in% store.slots) {
|
| 479 | ! |
ParTableList <- lapply(RES, "[[", "ParTable") |
| 480 |
} |
|
| 481 | ! |
if ("data" %in% store.slots) {
|
| 482 | ! |
DataList <- lapply(RES, "[[", "Data") |
| 483 |
} |
|
| 484 | ! |
if ("samplestats" %in% store.slots) {
|
| 485 | ! |
SampleStatsList <- lapply(RES, "[[", "SampleStats") |
| 486 |
} |
|
| 487 | ! |
if ("cache" %in% store.slots) {
|
| 488 | ! |
CacheList <- lapply(RES, "[[", "Cache") |
| 489 |
} |
|
| 490 | ! |
if ("vcov" %in% store.slots) {
|
| 491 | ! |
vcovList <- lapply(RES, "[[", "vcov") |
| 492 |
} |
|
| 493 | ! |
if ("test" %in% store.slots) {
|
| 494 | ! |
testList <- lapply(RES, "[[", "test") |
| 495 |
} |
|
| 496 | ! |
if ("optim" %in% store.slots) {
|
| 497 | ! |
optimList <- lapply(RES, "[[", "optim") |
| 498 |
} |
|
| 499 | ! |
if ("implied" %in% store.slots) {
|
| 500 | ! |
impliedList <- lapply(RES, "[[", "implied") |
| 501 |
} |
|
| 502 | ! |
if ("h1" %in% store.slots) {
|
| 503 | ! |
h1List <- lapply(RES, "[[", "h1") |
| 504 |
} |
|
| 505 | ! |
if ("loglik" %in% store.slots) {
|
| 506 | ! |
loglikList <- lapply(RES, "[[", "loglik") |
| 507 |
} |
|
| 508 | ! |
if ("baseline" %in% store.slots) {
|
| 509 | ! |
baselineList <- lapply(RES, "[[", "baseline") |
| 510 |
} |
|
| 511 | ! |
if (!is.null(FUN)) {
|
| 512 | ! |
funList <- lapply(RES, "[[", "fun") |
| 513 |
} |
|
| 514 | ||
| 515 |
# create lavaanList object |
|
| 516 | ! |
lavaanList <- new("lavaanList",
|
| 517 | ! |
version = packageDescription("lavaan", fields = "Version"),
|
| 518 | ! |
call = mc, |
| 519 | ! |
Options = lavoptions, |
| 520 | ! |
ParTable = lavpartable, |
| 521 | ! |
pta = lavpta, |
| 522 | ! |
Model = lavmodel, |
| 523 | ! |
Data = FIT@Data, |
| 524 | ||
| 525 |
# meta |
|
| 526 | ! |
meta = meta, |
| 527 | ||
| 528 |
# per dataset |
|
| 529 | ! |
timingList = timingList, |
| 530 | ! |
ParTableList = ParTableList, |
| 531 | ! |
DataList = DataList, |
| 532 | ! |
SampleStatsList = SampleStatsList, |
| 533 | ! |
CacheList = CacheList, |
| 534 | ! |
vcovList = vcovList, |
| 535 | ! |
testList = testList, |
| 536 | ! |
optimList = optimList, |
| 537 | ! |
impliedList = impliedList, |
| 538 | ! |
h1List = h1List, |
| 539 | ! |
loglikList = loglikList, |
| 540 | ! |
baselineList = baselineList, |
| 541 | ! |
funList = funList, |
| 542 | ! |
external = list() |
| 543 |
) |
|
| 544 | ||
| 545 |
# restore random seed |
|
| 546 | ! |
if (!is.null(init.seed)) {
|
| 547 | ! |
assign(".Random.seed", init.seed, envir = .GlobalEnv)
|
| 548 | ! |
} else if (exists(".Random.seed", envir = .GlobalEnv, inherits = FALSE)) {
|
| 549 |
# initially there was no .Random.seed, but we created one along the way |
|
| 550 |
# clean up |
|
| 551 | ! |
remove(".Random.seed", envir = .GlobalEnv)
|
| 552 |
} |
|
| 553 |
# restore random generator method (if changed) |
|
| 554 | ! |
RNGkind(RNGkind_old[1], RNGkind_old[2], RNGkind_old[3]) |
| 555 | ||
| 556 | ! |
lavaanList |
| 557 |
} |
|
| 558 | ||
| 559 |
semList <- function(model = NULL, |
|
| 560 |
dataList = NULL, |
|
| 561 |
dataFunction = NULL, |
|
| 562 |
dataFunction.args = list(), |
|
| 563 |
ndat = length(dataList), |
|
| 564 |
..., |
|
| 565 |
store.slots = c("partable"),
|
|
| 566 |
FUN = NULL, |
|
| 567 |
show.progress = FALSE, |
|
| 568 |
store.failed = FALSE, |
|
| 569 |
parallel = c("no", "multicore", "snow"),
|
|
| 570 |
ncpus = max(1L, parallel::detectCores() - 1L), |
|
| 571 |
cl = NULL, |
|
| 572 |
iseed = NULL) {
|
|
| 573 | ! |
mc <- match.call(expand.dots = TRUE) |
| 574 | ! |
mc$cmd <- "sem" |
| 575 | ! |
mc[[1L]] <- quote(lavaan::lavaanList) |
| 576 | ! |
eval(mc, parent.frame()) |
| 577 |
} |
|
| 578 | ||
| 579 |
cfaList <- function(model = NULL, |
|
| 580 |
dataList = NULL, |
|
| 581 |
dataFunction = NULL, |
|
| 582 |
dataFunction.args = list(), |
|
| 583 |
ndat = length(dataList), |
|
| 584 |
..., |
|
| 585 |
store.slots = c("partable"),
|
|
| 586 |
FUN = NULL, |
|
| 587 |
show.progress = FALSE, |
|
| 588 |
store.failed = FALSE, |
|
| 589 |
parallel = c("no", "multicore", "snow"),
|
|
| 590 |
ncpus = max(1L, parallel::detectCores() - 1L), |
|
| 591 |
cl = NULL, |
|
| 592 |
iseed = NULL) {
|
|
| 593 | ! |
mc <- match.call(expand.dots = TRUE) |
| 594 | ! |
mc$cmd <- "cfa" |
| 595 | ! |
mc[[1L]] <- quote(lavaan::lavaanList) |
| 596 | ! |
eval(mc, parent.frame()) |
| 597 |
} |
| 1 |
lav_lavaan_step08_start <- function(slotModel = NULL, # nolint |
|
| 2 |
lavoptions = NULL, |
|
| 3 |
lavpartable = NULL, |
|
| 4 |
lavsamplestats = NULL, |
|
| 5 |
lavh1 = NULL) {
|
|
| 6 |
# # # # # # # # # # # |
|
| 7 |
# # 8. lavstart # # |
|
| 8 |
# # # # # # # # # # # |
|
| 9 | ||
| 10 |
# if slotModel is NULL |
|
| 11 |
# if lavpartable$est not NULL and lavoptions$start == "default" |
|
| 12 |
# if there are free variances with est==0 or there are NA's in est |
|
| 13 |
# compute start column in lavpartable via lav_start |
|
| 14 |
# else |
|
| 15 |
# set start column in lavpartable equal to est column |
|
| 16 |
# else |
|
| 17 |
# compute start column via lav_start and |
|
| 18 |
# check via lav_start_check_cov if demanded (lavoptions$check.start) |
|
| 19 | ||
| 20 | 140x |
samplestats.flag <- TRUE |
| 21 | 140x |
if (!is.null(lavoptions$samplestats) && |
| 22 | 140x |
!lavoptions$samplestats) {
|
| 23 | ! |
samplestats.flag <- FALSE |
| 24 |
} |
|
| 25 | ||
| 26 | 140x |
if (is.null(slotModel)) {
|
| 27 |
# check if we have provided a full parameter table as model = input |
|
| 28 | 140x |
if (!is.null(lavpartable$est) && is.character(lavoptions$start) && |
| 29 | 140x |
lavoptions$start == "default") {
|
| 30 | 32x |
if (lav_verbose()) {
|
| 31 | ! |
cat("lavstart ...")
|
| 32 |
} |
|
| 33 |
# check if all 'est' values look ok |
|
| 34 |
# this is not the case, eg, if partables have been merged eg, as |
|
| 35 |
# in semTools' auxiliary() function |
|
| 36 | ||
| 37 |
# check for zero free variances and NA values |
|
| 38 | 32x |
if (is.null(lavpartable$lower)) {
|
| 39 | 16x |
zero.idx <- which(lavpartable$free > 0L & |
| 40 | 16x |
lavpartable$op == "~~" & |
| 41 | 16x |
lavpartable$lhs == lavpartable$rhs & |
| 42 | 16x |
lavpartable$est == 0) |
| 43 |
} else {
|
|
| 44 |
# ignore zero variances on the boundary; new in 0.6-21 |
|
| 45 | 16x |
zero.idx <- which(lavpartable$free > 0L & |
| 46 | 16x |
lavpartable$op == "~~" & |
| 47 | 16x |
lavpartable$lhs == lavpartable$rhs & |
| 48 | 16x |
lavpartable$est == 0 & |
| 49 | 16x |
lavpartable$lower != 0) |
| 50 |
} |
|
| 51 | ||
| 52 | 32x |
if (length(zero.idx) > 0L || any(is.na(lavpartable$est))) {
|
| 53 | ! |
lavpartable$start <- lav_start( |
| 54 | ! |
start.method = lavoptions$start, |
| 55 | ! |
lavpartable = lavpartable, |
| 56 | ! |
lavsamplestats = lavsamplestats, |
| 57 | ! |
model.type = lavoptions$model.type, |
| 58 | ! |
reflect = FALSE, |
| 59 | ! |
samplestats.flag = samplestats.flag, |
| 60 |
# order.lv.by = lavoptions$rotation.args$order.lv.by, |
|
| 61 | ! |
order.lv.by = "none" |
| 62 |
) |
|
| 63 |
} else {
|
|
| 64 | 32x |
lavpartable$start <- lavpartable$est |
| 65 |
} |
|
| 66 | ||
| 67 |
# check for exogenous parameters: if the dataset changed, we must |
|
| 68 |
# update them! (new in 0.6-16) |
|
| 69 |
# ... or not? (not compatible with how we bootstrap under fixed.x = T) |
|
| 70 |
# we really need to think about this more carefully... |
|
| 71 |
# |
|
| 72 |
# if (any(lavpartable$exo == 1L)) {
|
|
| 73 |
# # FIXME: there should be an easier way just to |
|
| 74 |
# # (re)initialize the the exogenous part of the model |
|
| 75 |
# tmp <- lav_start(start.method = "lavaan", # not "simple" |
|
| 76 |
# # if fixed.x = TRUE |
|
| 77 |
# lavpartable = lavpartable, |
|
| 78 |
# lavsamplestats = lavsamplestats, |
|
| 79 |
# lavh1 = lavh1, |
|
| 80 |
# model.type = lavoptions$model.type, |
|
| 81 |
# reflect = FALSE, |
|
| 82 |
# #order.lv.by = lavoptions$rotation.args$order.lv.by, |
|
| 83 |
# order.lv.by = "none", |
|
| 84 |
# debug = lav_debug()) |
|
| 85 |
# exo.idx <- which(lavpartable$exo == 1L) |
|
| 86 |
# lavpartable$start[exo.idx] <- tmp[exo.idx] |
|
| 87 |
# } |
|
| 88 | ||
| 89 | 32x |
if (lav_verbose()) {
|
| 90 | ! |
cat(" done.\n")
|
| 91 |
} |
|
| 92 |
} else {
|
|
| 93 | 108x |
if (lav_verbose()) {
|
| 94 | ! |
cat("lavstart ...")
|
| 95 |
} |
|
| 96 | 108x |
start.values <- lav_start( |
| 97 | 108x |
start.method = lavoptions$start, |
| 98 | 108x |
lavpartable = lavpartable, |
| 99 | 108x |
lavsamplestats = lavsamplestats, |
| 100 | 108x |
lavh1 = lavh1, |
| 101 | 108x |
model.type = lavoptions$model.type, |
| 102 | 108x |
reflect = FALSE, |
| 103 | 108x |
samplestats.flag = samplestats.flag, |
| 104 |
# order.lv.by = lavoptions$rotation.args$order.lv.by, |
|
| 105 | 108x |
order.lv.by = "none" |
| 106 |
) |
|
| 107 | ||
| 108 |
# sanity check |
|
| 109 | 108x |
if (!is.null(lavoptions$check.start) && lavoptions$check.start) {
|
| 110 | 47x |
start.values <- lav_start_check_cov( |
| 111 | 47x |
lavpartable = lavpartable, |
| 112 | 47x |
start = start.values |
| 113 |
) |
|
| 114 |
} |
|
| 115 | ||
| 116 | 108x |
lavpartable$start <- start.values |
| 117 | 108x |
if (lav_verbose()) {
|
| 118 | ! |
cat(" done.\n")
|
| 119 |
} |
|
| 120 |
} |
|
| 121 |
} |
|
| 122 | ||
| 123 | 140x |
lavpartable |
| 124 |
} |
| 1 |
# methods |
|
| 2 |
setMethod( |
|
| 3 |
"show", "lavaanList", |
|
| 4 |
function(object) {
|
|
| 5 |
# check object |
|
| 6 | ! |
object <- lav_object_check_version(object) |
| 7 |
# show only basic information |
|
| 8 | ! |
lav_lavaanlist_short_summary(object, print = TRUE) |
| 9 |
} |
|
| 10 |
) |
|
| 11 | ||
| 12 |
lav_lavaanlist_short_summary <- function(object, print = TRUE) {
|
|
| 13 | ! |
txt <- sprintf( |
| 14 | ! |
"lavaanList (%s) -- based on %d datasets (%d converged)\n", |
| 15 | ! |
object@version, |
| 16 | ! |
object@meta$ndat, |
| 17 | ! |
sum(object@meta$ok) |
| 18 |
) |
|
| 19 | ||
| 20 | ! |
if (print) {
|
| 21 | ! |
cat(txt) |
| 22 |
} |
|
| 23 | ||
| 24 | ! |
invisible(txt) |
| 25 |
} |
|
| 26 | ||
| 27 |
setMethod( |
|
| 28 |
"summary", "lavaanList", |
|
| 29 |
function(object, header = TRUE, |
|
| 30 |
estimates = TRUE, |
|
| 31 |
print = TRUE, |
|
| 32 |
nd = 3L, |
|
| 33 |
simulate.args = list(est.bias = TRUE, |
|
| 34 |
se.bias = TRUE, |
|
| 35 |
prop.sig = TRUE, |
|
| 36 |
coverage = TRUE, |
|
| 37 |
level = 0.95, |
|
| 38 |
trim = 0), |
|
| 39 |
...) {
|
|
| 40 | ! |
dotdotdot <- list(...) |
| 41 | ! |
if (length(dotdotdot) > 0L) {
|
| 42 | ! |
for (j in seq_along(dotdotdot)) {
|
| 43 | ! |
lav_msg_warn(gettextf( |
| 44 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 45 | ! |
sQuote("summary"))
|
| 46 |
) |
|
| 47 |
} |
|
| 48 |
} |
|
| 49 | ! |
lav_lavaanlist_summary(object, |
| 50 | ! |
header = header, estimates = estimates, |
| 51 | ! |
print = print, nd = nd, simulate.args = simulate.args |
| 52 |
) |
|
| 53 |
} |
|
| 54 |
) |
|
| 55 | ||
| 56 |
lav_lavaanlist_summary <- function(object, |
|
| 57 |
header = TRUE, |
|
| 58 |
estimates = TRUE, |
|
| 59 |
simulate.args = list(est.bias = TRUE, |
|
| 60 |
se.bias = TRUE, |
|
| 61 |
prop.sig = TRUE, |
|
| 62 |
coverage = TRUE, |
|
| 63 |
level = 0.95, |
|
| 64 |
trim = 0), |
|
| 65 |
zstat = TRUE, |
|
| 66 |
pvalue = TRUE, |
|
| 67 |
print = TRUE, |
|
| 68 |
nd = 3L) {
|
|
| 69 |
# check object |
|
| 70 | ! |
object <- lav_object_check_version(object) |
| 71 | ||
| 72 | ! |
out <- list() |
| 73 | ||
| 74 | ! |
if (header) {
|
| 75 | ! |
out$header <- lav_lavaanlist_short_summary(object, print = print) |
| 76 | ||
| 77 |
# if(print) {
|
|
| 78 |
# # show only basic information |
|
| 79 |
# lav_lavaanlist_short_summary(object) |
|
| 80 |
# } |
|
| 81 |
} |
|
| 82 | ! |
if (print) {
|
| 83 | ! |
output <- "text" |
| 84 |
} else {
|
|
| 85 | ! |
output <- "data.frame" |
| 86 |
} |
|
| 87 | ||
| 88 | ! |
if (estimates && "partable" %in% object@meta$store.slots) {
|
| 89 | ! |
pe <- lavParameterEstimates(object, |
| 90 | ! |
se = FALSE, |
| 91 | ! |
remove.system.eq = FALSE, remove.eq = FALSE, |
| 92 | ! |
remove.ineq = FALSE, remove.def = FALSE, |
| 93 | ! |
remove.nonfree = FALSE, remove.unused = FALSE, |
| 94 | ! |
remove.step1 = FALSE, # in case we used sam() |
| 95 |
# zstat = FALSE, pvalue = FALSE, ci = FALSE, |
|
| 96 | ! |
standardized = FALSE, |
| 97 | ! |
output = output |
| 98 |
) |
|
| 99 | ||
| 100 |
# scenario 1: simulation |
|
| 101 | ! |
if (!is.null(object@meta$lavSimulate)) {
|
| 102 | ||
| 103 |
# default behavior |
|
| 104 | ! |
sim.args <- list(est.bias = TRUE, |
| 105 | ! |
se.bias = TRUE, |
| 106 | ! |
prop.sig = TRUE, |
| 107 | ! |
coverage = TRUE, |
| 108 | ! |
level = 0.95, |
| 109 | ! |
trim = 0) |
| 110 | ! |
sim.args <- modifyList(sim.args, simulate.args) |
| 111 |
#if (!sim.args$est.bias) {
|
|
| 112 |
# sim.args$se.bias <- FALSE |
|
| 113 |
#} |
|
| 114 | ! |
if (!sim.args$se.bias) {
|
| 115 | ! |
sim.args$prop.sig <- FALSE |
| 116 |
} |
|
| 117 | ||
| 118 | ! |
pe$est.true <- object@meta$est.true |
| 119 | ! |
nel <- length(pe$est.true) |
| 120 | ||
| 121 |
# always compute EST |
|
| 122 | ! |
EST <- lav_lavaanlist_partable(object, what = "est", type = "all") |
| 123 | ||
| 124 |
# sometimes compute SE |
|
| 125 | ! |
if (sim.args$se.bias || sim.args$prop.sig || sim.args$coverage) {
|
| 126 | ! |
SE <- lav_lavaanlist_partable(object, what = "se", type = "all") |
| 127 |
} |
|
| 128 | ||
| 129 |
# est.bias? |
|
| 130 | ! |
if (sim.args$est.bias) {
|
| 131 | ! |
AVE <- apply(EST, 1L, mean, na.rm = TRUE, trim = sim.args$trim) |
| 132 | ||
| 133 |
# remove things like equality constraints |
|
| 134 | ! |
if (length(AVE) > nel) {
|
| 135 | ! |
AVE <- AVE[seq_len(nel)] |
| 136 |
} |
|
| 137 | ! |
AVE[!is.finite(AVE)] <- as.numeric(NA) |
| 138 | ! |
pe$est.ave <- AVE |
| 139 | ! |
pe$est.bias <- pe$est.ave - pe$est.true |
| 140 | ||
| 141 |
# FIXME: should we also add bias^2 and MSE? |
|
| 142 |
# and what about relative bias? |
|
| 143 |
} |
|
| 144 | ||
| 145 | ||
| 146 |
# SE? |
|
| 147 | ! |
if (sim.args$se.bias) {
|
| 148 | ! |
SE.OBS <- apply(EST, 1L, lav_sample_trimmed_sd, na.rm = TRUE, |
| 149 | ! |
trim = sim.args$trim) |
| 150 | ! |
if (length(SE.OBS) > nel) {
|
| 151 | ! |
SE.OBS <- SE.OBS[seq_len(nel)] |
| 152 |
} |
|
| 153 | ! |
SE.OBS[!is.finite(SE.OBS)] <- as.numeric(NA) |
| 154 | ! |
pe$se.obs <- SE.OBS |
| 155 | ! |
SE.AVE <- apply(SE, 1L, mean, na.rm = TRUE, trim = sim.args$trim) |
| 156 | ! |
if (length(SE.AVE) > nel) {
|
| 157 | ! |
SE.AVE <- SE.AVE[seq_len(nel)] |
| 158 |
} |
|
| 159 | ! |
SE.AVE[!is.finite(SE.AVE)] <- as.numeric(NA) |
| 160 | ! |
pe$se.ave <- SE.AVE |
| 161 | ! |
se.obs <- SE.OBS |
| 162 | ! |
se.obs[se.obs < .Machine$double.eps^(1/3)] <- as.numeric(NA) |
| 163 | ! |
pe$se.bias <- pe$se.ave / se.obs # use ratio! |
| 164 | ! |
pe$se.bias[!is.finite(pe$se.bias)] <- as.numeric(NA) |
| 165 |
} |
|
| 166 | ||
| 167 | ! |
if (sim.args$prop.sig) {
|
| 168 | ! |
SE[SE < sqrt(.Machine$double.eps)] <- as.numeric(NA) |
| 169 | ! |
WALD <- EST/SE |
| 170 | ! |
wald <- apply(WALD, 1L, mean, na.rm = TRUE, |
| 171 | ! |
trim = sim.args$trim) |
| 172 | ! |
wald[!is.finite(wald)] <- as.numeric(NA) |
| 173 | ! |
pe$wald <- wald |
| 174 | ! |
PVAL <- 2 * (1 - pnorm(abs(WALD))) |
| 175 | ! |
propsig <- apply(PVAL, 1L, function(x) {
|
| 176 | ! |
x.ok <- x[is.finite(x)] |
| 177 | ! |
nx <- length(x.ok) |
| 178 | ! |
sum(x.ok < (1 - sim.args$level))/nx |
| 179 |
}) |
|
| 180 | ! |
propsig[!is.finite(propsig)] <- as.numeric(NA) |
| 181 | ! |
pe$prop.sig <- propsig |
| 182 |
} |
|
| 183 | ||
| 184 | ! |
if (sim.args$coverage) {
|
| 185 |
# next three lines based on confint.lm |
|
| 186 | ! |
a <- (1 - sim.args$level) / 2 |
| 187 | ! |
a <- c(a, 1 - a) |
| 188 | ! |
fac <- qnorm(a) |
| 189 | ! |
CI.LOWER <- EST + fac[1]*SE |
| 190 | ! |
CI.UPPER <- EST + fac[2]*SE |
| 191 | ! |
ci.lower <- apply(CI.LOWER, 1L, mean, na.rm = TRUE, |
| 192 | ! |
trim = sim.args$trim) |
| 193 | ! |
ci.upper <- apply(CI.UPPER, 1L, mean, na.rm = TRUE, |
| 194 | ! |
trim = sim.args$trim) |
| 195 | ! |
ci.lower[!is.finite(ci.lower)] <- as.numeric(NA) |
| 196 | ! |
ci.upper[!is.finite(ci.upper)] <- as.numeric(NA) |
| 197 | ! |
pe$ci.lower <- ci.lower |
| 198 | ! |
pe$ci.upper <- ci.upper |
| 199 |
# columnwise comparison |
|
| 200 | ! |
inside.flag <- (CI.LOWER <= pe$est.true) & (CI.UPPER >= pe$est.true) |
| 201 | ! |
coverage <- apply(inside.flag, 1L, mean, na.rm = TRUE) |
| 202 | ! |
coverage[!is.finite(coverage)] <- as.numeric(NA) |
| 203 | ! |
pe$coverage <- coverage |
| 204 |
} |
|
| 205 | ||
| 206 |
# if sam(), should we keep or remove the step1 values? |
|
| 207 |
# keep them for now |
|
| 208 | ||
| 209 |
# scenario 2: bootstrap |
|
| 210 | ! |
} else if (!is.null(object@meta$lavBootstrap)) {
|
| 211 |
# print the average value for est |
|
| 212 | ! |
EST <- lav_lavaanlist_partable(object, what = "est", type = "all") |
| 213 | ! |
pe$est.ave <- rowMeans(EST, na.rm = TRUE) |
| 214 | ||
| 215 |
# scenario 3: multiple imputation |
|
| 216 | ! |
} else if (!is.null(object@meta$lavMultipleImputation)) {
|
| 217 |
# pool est: take the mean |
|
| 218 | ! |
EST <- lav_lavaanlist_partable(object, what = "est", type = "all") |
| 219 | ! |
m <- NCOL(EST) |
| 220 | ! |
pe$est <- rowMeans(EST, na.rm = TRUE) |
| 221 | ||
| 222 |
# pool se |
|
| 223 | ||
| 224 |
# between-imputation variance |
|
| 225 |
# B.var <- apply(EST, 1L, var) |
|
| 226 | ! |
est1 <- rowMeans(EST, na.rm = TRUE) |
| 227 | ! |
est2 <- rowMeans(EST^2, na.rm = TRUE) |
| 228 | ! |
B.var <- (est2 - est1 * est1) * m / (m - 1) |
| 229 | ||
| 230 |
# within-imputation variance |
|
| 231 | ! |
SE <- lav_lavaanlist_partable(object, what = "se", type = "all") |
| 232 | ! |
W.var <- rowMeans(SE^2, na.rm = TRUE) |
| 233 | ||
| 234 |
# total variance: T.var = W.var + B.var + B.var/m |
|
| 235 | ! |
pe$se <- sqrt(W.var + B.var + (B.var / m)) |
| 236 | ||
| 237 | ! |
tmp.se <- ifelse(pe$se == 0.0, NA, pe$se) |
| 238 | ! |
if (zstat) {
|
| 239 | ! |
pe$z <- pe$est / tmp.se |
| 240 | ! |
if (pvalue) {
|
| 241 | ! |
pe$pvalue <- 2 * (1 - pnorm(abs(pe$z))) |
| 242 |
} |
|
| 243 |
} |
|
| 244 | ||
| 245 |
# scenario 4: multiple groups/sets |
|
| 246 | ! |
} else if (!is.null(object@meta$lavMultipleGroups)) {
|
| 247 |
# show individual estimates, for each group |
|
| 248 | ! |
EST <- lav_lavaanlist_partable(object, what = "est", type = "all") |
| 249 | ! |
EST <- as.list(as.data.frame(EST)) |
| 250 | ! |
ngroups <- length(EST) |
| 251 | ! |
names(EST) <- object@meta$group.label |
| 252 | ! |
ATTR <- attributes(pe) |
| 253 | ! |
NAMES <- c(names(pe), names(EST)) |
| 254 | ! |
pe <- c(pe, EST) |
| 255 | ! |
attributes(pe) <- ATTR |
| 256 | ! |
names(pe) <- NAMES |
| 257 |
} |
|
| 258 | ||
| 259 |
# scenario 5: just a bunch of fits, using different datasets |
|
| 260 |
else {
|
|
| 261 |
# print the average value for est |
|
| 262 | ! |
EST <- lav_lavaanlist_partable(object, what = "est", type = "all") |
| 263 | ! |
pe$est.ave <- rowMeans(EST, na.rm = TRUE) |
| 264 | ||
| 265 |
# more? |
|
| 266 |
} |
|
| 267 | ||
| 268 |
# remove ==,<,> |
|
| 269 | ! |
rm.idx <- which(pe$op %in% c("==", "<", ">"))
|
| 270 | ! |
if (length(rm.idx) > 0L) {
|
| 271 | ! |
pe <- pe[-rm.idx, ] |
| 272 |
} |
|
| 273 | ||
| 274 | ! |
out$pe <- pe |
| 275 | ||
| 276 | ! |
if (print) {
|
| 277 |
# print pe? |
|
| 278 | ! |
print(pe, nd = nd) |
| 279 |
} |
|
| 280 |
} else {
|
|
| 281 | ! |
cat("available slots (per dataset) are:\n")
|
| 282 | ! |
print(object@meta$store.slots) |
| 283 |
} |
|
| 284 | ||
| 285 | ! |
invisible(out) |
| 286 |
} |
|
| 287 | ||
| 288 |
setMethod( |
|
| 289 |
"coef", "lavaanList", |
|
| 290 |
function(object, type = "free", labels = TRUE, ...) {
|
|
| 291 |
# check object |
|
| 292 | ! |
object <- lav_object_check_version(object) |
| 293 | ! |
dotdotdot <- list(...) |
| 294 | ! |
if (length(dotdotdot) > 0L) {
|
| 295 | ! |
for (j in seq_along(dotdotdot)) {
|
| 296 | ! |
lav_msg_warn(gettextf( |
| 297 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 298 | ! |
sQuote("coef"))
|
| 299 |
) |
|
| 300 |
} |
|
| 301 |
} |
|
| 302 | ! |
lav_lavaanlist_partable( |
| 303 | ! |
object = object, what = "est", type = type, |
| 304 | ! |
labels = labels |
| 305 |
) |
|
| 306 |
} |
|
| 307 |
) |
|
| 308 | ||
| 309 |
lav_lavaanlist_partable <- function(object, what = "est", |
|
| 310 |
type = "free", labels = TRUE) {
|
|
| 311 |
# check object |
|
| 312 | ! |
object <- lav_object_check_version(object) |
| 313 | ! |
if ("partable" %in% object@meta$store.slots) {
|
| 314 | ! |
if (what %in% names(object@ParTableList[[1]])) {
|
| 315 | ! |
OUT <- sapply(object@ParTableList, "[[", what) |
| 316 |
} else {
|
|
| 317 | ! |
lav_msg_stop(gettextf( |
| 318 | ! |
"column `%s' not found in the first element of the ParTableList slot.", |
| 319 | ! |
what)) |
| 320 |
} |
|
| 321 |
} else {
|
|
| 322 | ! |
lav_msg_stop(gettext("no ParTable slot stored in lavaanList object"))
|
| 323 |
} |
|
| 324 | ||
| 325 | ! |
if (type == "user" || type == "all") {
|
| 326 | ! |
type <- "user" |
| 327 | ! |
idx <- 1:length(object@ParTable$lhs) |
| 328 | ! |
} else if (type == "free") {
|
| 329 | ! |
idx <- which(object@ParTable$free > 0L & !duplicated(object@ParTable$free)) |
| 330 |
} else {
|
|
| 331 | ! |
lav_msg_stop(gettext("argument `type' must be one of free or user"))
|
| 332 |
} |
|
| 333 | ||
| 334 | ! |
OUT <- OUT[idx, , drop = FALSE] |
| 335 | ||
| 336 | ! |
if (labels) {
|
| 337 | ! |
rownames(OUT) <- lav_partable_labels(object@ParTable, type = type) |
| 338 |
} |
|
| 339 | ||
| 340 | ! |
OUT |
| 341 |
} |
| 1 |
# compute 'Omega' == A1^{-1} B1 A1^{-1}
|
|
| 2 |
# where A1 is the expected/observed information matrix of the unrestricted (h1) |
|
| 3 |
# model, and B1 is the first-order information matrix of the unrestricted (h1) |
|
| 4 |
# model |
|
| 5 |
# |
|
| 6 |
# but the exact result will depend on the options: |
|
| 7 |
# for 'A': |
|
| 8 |
# - omega.information ("expected" or "observed")
|
|
| 9 |
# - omega.h1.information ("structured" or "unstructured")
|
|
| 10 |
# for 'B': |
|
| 11 |
# - omega.information.meat ("first-order")
|
|
| 12 |
# - omega.h1.information.meat ("structured" or "unstructured")
|
|
| 13 |
# |
|
| 14 |
# special case: if data is complete, A is expected/unstructured, and B is |
|
| 15 |
# unstructured, we get (sample-based) 'Gamma' |
|
| 16 |
# |
|
| 17 |
# YR 28 Oct 2020 |
|
| 18 | ||
| 19 |
lav_model_h1_omega <- function(lavobject = NULL, |
|
| 20 |
lavmodel = NULL, |
|
| 21 |
lavsamplestats = NULL, |
|
| 22 |
lavdata = NULL, |
|
| 23 |
lavimplied = NULL, |
|
| 24 |
lavh1 = NULL, |
|
| 25 |
lavcache = NULL, |
|
| 26 |
lavoptions = NULL) {
|
|
| 27 | ! |
if (!is.null(lavobject) && inherits(lavobject, "lavaan")) {
|
| 28 | ! |
lavmodel <- lavobject@Model |
| 29 | ! |
lavsamplestats <- lavobject@SampleStats |
| 30 | ! |
lavdata <- lavobject@Data |
| 31 | ! |
lavimplied <- lavobject@implied |
| 32 | ! |
lavh1 <- lavobject@h1 |
| 33 | ! |
lavcache <- lavobject@Cache |
| 34 | ! |
lavoptions <- lavobject@Options |
| 35 |
} |
|
| 36 | ||
| 37 |
# sanity check |
|
| 38 | ! |
if (length(lavh1) == 0L) {
|
| 39 | ! |
lavh1 <- lav_h1_implied_logl( |
| 40 | ! |
lavdata = lavdata, |
| 41 | ! |
lavsamplestats = lavsamplestats, |
| 42 | ! |
lavoptions = lavoptions |
| 43 |
) |
|
| 44 |
} |
|
| 45 | ! |
if (length(lavimplied) == 0L) {
|
| 46 | ! |
lavimplied <- lav_model_implied(lavmodel = lavmodel) |
| 47 |
} |
|
| 48 | ||
| 49 |
# set options for A |
|
| 50 | ! |
A1.options <- lavoptions |
| 51 | ! |
A1.options$information <- lavoptions$omega.information |
| 52 | ! |
A1.options$h1.information <- lavoptions$omega.h1.information |
| 53 | ||
| 54 | ! |
B1.options <- lavoptions |
| 55 | ! |
B1.options$information <- lavoptions$omega.information.meat # unused |
| 56 | ! |
B1.options$h1.information <- lavoptions$omega.h1.information.meat |
| 57 | ||
| 58 |
# information |
|
| 59 | ! |
information <- lavoptions$omega.information |
| 60 | ||
| 61 |
# compute A1 (per group) |
|
| 62 | ! |
if (information == "observed") {
|
| 63 | ! |
A1 <- lav_model_h1_information_observed( |
| 64 | ! |
lavmodel = lavmodel, |
| 65 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 66 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 67 | ! |
lavcache = lavcache, lavoptions = A1.options |
| 68 |
) |
|
| 69 | ! |
} else if (information == "expected") {
|
| 70 | ! |
A1 <- lav_model_h1_information_expected( |
| 71 | ! |
lavmodel = lavmodel, |
| 72 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 73 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 74 | ! |
lavcache = lavcache, lavoptions = A1.options |
| 75 |
) |
|
| 76 | ! |
} else if (information == "first.order") { # not needed?
|
| 77 | ! |
A1 <- lav_model_h1_information_firstorder( |
| 78 | ! |
lavmodel = lavmodel, |
| 79 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 80 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 81 | ! |
lavcache = lavcache, lavoptions = A1.options |
| 82 |
) |
|
| 83 |
} |
|
| 84 | ||
| 85 |
# compute B1 (per group) |
|
| 86 | ! |
B1 <- lav_model_h1_information_firstorder( |
| 87 | ! |
lavmodel = lavmodel, |
| 88 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 89 | ! |
lavimplied = lavimplied, lavh1 = lavh1, |
| 90 | ! |
lavcache = lavcache, lavoptions = B1.options |
| 91 |
) |
|
| 92 | ||
| 93 |
# return Omega per group |
|
| 94 | ! |
Omega <- vector("list", length = lavdata@ngroups)
|
| 95 | ! |
trace.h1 <- numeric(lavdata@ngroups) |
| 96 | ! |
h1.ndat <- numeric(lavdata@ngroups) |
| 97 | ! |
for (g in seq_len(lavdata@ngroups)) {
|
| 98 | ! |
A1.g <- A1[[g]] |
| 99 | ! |
B1.g <- B1[[g]] |
| 100 | ||
| 101 |
# mask independent 'fixed-x' variables |
|
| 102 | ! |
zero.idx <- which(diag(A1.g) == 0) |
| 103 | ! |
if (length(zero.idx) > 0L) {
|
| 104 | ! |
A1.inv <- matrix(0, nrow(A1.g), ncol(A1.g)) |
| 105 | ! |
a1 <- A1.g[-zero.idx, -zero.idx, drop = FALSE] |
| 106 | ! |
a1.inv <- solve(a1) |
| 107 | ! |
A1.inv[-zero.idx, -zero.idx] <- a1.inv |
| 108 |
} else {
|
|
| 109 | ! |
A1.inv <- solve(A1.g) |
| 110 |
} |
|
| 111 | ! |
trace.h1[g] <- sum(B1.g * t(A1.inv)) |
| 112 | ! |
h1.ndat[g] <- ncol(A1.g) - length(zero.idx) |
| 113 | ||
| 114 | ! |
Omega[[g]] <- A1.inv %*% B1.g %*% A1.inv |
| 115 |
} |
|
| 116 | ||
| 117 |
# store trace.h1 as an attribute (to be used in yuan-bentler) |
|
| 118 | ! |
attr(Omega, "trace.h1") <- trace.h1 |
| 119 | ! |
attr(Omega, "h1.ndat") <- h1.ndat |
| 120 | ! |
attr(Omega, "A.information") <- paste(A1.options$information, |
| 121 | ! |
A1.options$h1.information, |
| 122 | ! |
sep = "." |
| 123 |
) |
|
| 124 | ! |
attr(Omega, "B.information") <- paste(B1.options$information, |
| 125 | ! |
B1.options$h1.information, |
| 126 | ! |
sep = "." |
| 127 |
) |
|
| 128 | ||
| 129 | ! |
Omega |
| 130 |
} |
| 1 |
# export to Mplus syntax |
|
| 2 | ||
| 3 |
lav_export_mplus <- function(lav, group.label = NULL) {
|
|
| 4 | ! |
lav <- lav_export_check(lav) |
| 5 | ! |
header <- " ! this model syntax is autogenerated by lav_export\n" |
| 6 | ! |
footer <- "\n" |
| 7 | ||
| 8 | ! |
lav <- as.data.frame(lav, stringsAsFactors = FALSE) |
| 9 | ! |
ngroups <- lav_partable_ngroups(lav) |
| 10 | ||
| 11 | ! |
lav_one_group <- function(lav) {
|
| 12 |
# mplus does not like variable names with a 'dot' |
|
| 13 |
# replace them by an underscore '_' |
|
| 14 | ! |
lav$lhs <- gsub("\\.", "_", lav$lhs)
|
| 15 | ! |
lav$rhs <- gsub("\\.", "_", lav$rhs)
|
| 16 | ||
| 17 |
# remove contraints (:=, <, >, ==) here |
|
| 18 | ! |
con.idx <- which(lav$op %in% c(":=", "<", ">", "=="))
|
| 19 | ! |
if (length(con.idx) > 0L) {
|
| 20 | ! |
lav <- lav[-con.idx, ] |
| 21 |
} |
|
| 22 | ||
| 23 |
# remove exogenous variances/covariances/intercepts... |
|
| 24 | ! |
exo.idx <- which(lav$exo == 1L & lav$op %in% c("~~", "~1"))
|
| 25 | ! |
if (length(exo.idx)) {
|
| 26 | ! |
lav <- lav[-exo.idx, ] |
| 27 |
} |
|
| 28 | ||
| 29 |
# remove intercepts for categorical variables |
|
| 30 | ! |
ord.names <- unique(lav$lhs[lav$op == "|"]) |
| 31 | ! |
ord.int.idx <- which(lav$op == "~1" & lav$lhs %in% ord.names) |
| 32 | ! |
if (length(ord.int.idx)) {
|
| 33 | ! |
lav <- lav[-ord.int.idx, ] |
| 34 |
} |
|
| 35 | ||
| 36 |
# end of line |
|
| 37 | ! |
lav$eol <- rep(";", length(lav$lhs))
|
| 38 | ! |
lav$ustart <- ifelse(is.na(lav$ustart), "", lav$ustart) |
| 39 | ! |
lav$rhs2 <- ifelse(lav$free == 0L, |
| 40 | ! |
paste("@", lav$ustart, sep = ""),
|
| 41 | ! |
paste("*", lav$ustart, sep = "")
|
| 42 |
) |
|
| 43 | ! |
lav$plabel <- gsub("\\.", "", lav$plabel)
|
| 44 | ! |
LABEL <- ifelse(lav$label == "", lav$plabel, lav$label) |
| 45 | ! |
lav$plabel <- ifelse(LABEL == "", LABEL, |
| 46 | ! |
paste(" (", LABEL, ")", sep = "")
|
| 47 |
) |
|
| 48 | ||
| 49 |
# remove variances for ordered variables |
|
| 50 | ! |
ov.names.ord <- lav_partable_vnames(lav, type = "ov.ord") |
| 51 | ! |
ord.idx <- which(lav$lhs %in% ov.names.ord & |
| 52 | ! |
lav$op == "~~" & |
| 53 | ! |
lav$free == 0L & |
| 54 | ! |
lav$lhs == lav$rhs) |
| 55 | ! |
lav$lhs[ord.idx] <- paste("! ", lav$lhs[ord.idx], sep = "")
|
| 56 | ! |
lav$op[ord.idx] <- "" |
| 57 | ! |
lav$rhs[ord.idx] <- "" |
| 58 | ||
| 59 |
# variances |
|
| 60 | ! |
var.idx <- which(lav$op == "~~" & lav$rhs == lav$lhs) |
| 61 | ! |
lav$op[var.idx] <- "" |
| 62 | ! |
lav$rhs[var.idx] <- "" |
| 63 | ||
| 64 |
# scaling factors |
|
| 65 | ! |
scal.idx <- which(lav$op == "~*~") |
| 66 | ! |
lav$op[scal.idx] <- "" |
| 67 | ! |
lav$rhs2[scal.idx] <- paste(lav$rhs2[scal.idx], "}", sep = "") |
| 68 | ! |
lav$lhs[scal.idx] <- "{"
|
| 69 | ||
| 70 |
# intercepts - excluding categorical observed |
|
| 71 | ! |
int.idx <- which(lav$op == "~1") |
| 72 | ! |
lav$op[int.idx] <- "" |
| 73 | ! |
lav$rhs2[int.idx] <- paste(lav$rhs2[int.idx], "]", sep = "") |
| 74 | ! |
lav$lhs[int.idx] <- paste("[", lav$lhs[int.idx], sep = "")
|
| 75 | ||
| 76 |
# thresholds |
|
| 77 | ! |
th.idx <- which(lav$op == "|") |
| 78 | ! |
lav$op[th.idx] <- "$" |
| 79 | ! |
lav$rhs[th.idx] <- gsub("t", "", x = lav$rhs[th.idx])
|
| 80 | ! |
lav$rhs2[th.idx] <- paste(lav$rhs2[th.idx], "]", sep = "") |
| 81 | ! |
lav$lhs[th.idx] <- paste("[", lav$lhs[th.idx], sep = "")
|
| 82 | ||
| 83 |
# replace binary operators |
|
| 84 | ! |
lav$op <- ifelse(lav$op == "=~", " BY ", lav$op) |
| 85 | ! |
lav$op <- ifelse(lav$op == "~", " ON ", lav$op) |
| 86 | ! |
lav$op <- ifelse(lav$op == "~~", " WITH ", lav$op) |
| 87 | ||
| 88 | ||
| 89 | ! |
lav2 <- paste(lav$lhs, lav$op, lav$rhs, lav$rhs2, |
| 90 | ! |
lav$plabel, lav$eol, |
| 91 | ! |
sep = "" |
| 92 |
) |
|
| 93 | ||
| 94 | ! |
body <- paste(" ", lav2, collapse = "\n")
|
| 95 | ||
| 96 | ! |
body |
| 97 |
} |
|
| 98 | ||
| 99 | ! |
if (ngroups == 1L) {
|
| 100 | ! |
body <- lav_one_group(lav) |
| 101 |
} else {
|
|
| 102 | ! |
group.values <- lav_partable_group_values(lav) |
| 103 |
# group 1 |
|
| 104 | ! |
body <- lav_one_group(lav[lav$group == group.values[1], ]) |
| 105 | ||
| 106 | ! |
if (is.null(group.label) || length(group.label) == 0L) {
|
| 107 | ! |
group.label <- paste(1:ngroups) |
| 108 |
} |
|
| 109 | ||
| 110 | ! |
for (g in 2:ngroups) {
|
| 111 | ! |
body <- paste(body, |
| 112 | ! |
paste("\nMODEL ", group.label[g], ":\n", sep = ""),
|
| 113 | ! |
lav_one_group(lav[lav$group == group.values[g], ]), |
| 114 | ! |
sep = "" |
| 115 |
) |
|
| 116 |
} |
|
| 117 |
} |
|
| 118 | ||
| 119 |
# constraints go to a 'MODEL CONSTRAINTS' block |
|
| 120 | ! |
con.idx <- which(lav$op %in% c(":=", "<", ">", "=="))
|
| 121 | ! |
if (length(con.idx) > 0L) {
|
| 122 |
### FIXME: we need to convert the operator |
|
| 123 |
### eg b^2 --> b**2, others?? |
|
| 124 | ! |
lav$lhs[con.idx] <- gsub("\\^", "**", lav$lhs[con.idx])
|
| 125 | ! |
lav$rhs[con.idx] <- gsub("\\^", "**", lav$rhs[con.idx])
|
| 126 | ||
| 127 | ! |
constraints <- "\nMODEL CONSTRAINT:\n" |
| 128 |
# define 'new' variables |
|
| 129 | ! |
def.idx <- which(lav$op == ":=") |
| 130 | ! |
if (length(def.idx) > 0L) {
|
| 131 | ! |
def <- paste(lav$lhs[def.idx], collapse = " ") |
| 132 | ! |
constraints <- paste(constraints, "NEW (", def, ");")
|
| 133 | ! |
lav$op[def.idx] <- "=" |
| 134 |
} |
|
| 135 |
# replace '==' by '=' |
|
| 136 | ! |
eq.idx <- which(lav$op == "==") |
| 137 | ! |
if (length(eq.idx) > 0L) {
|
| 138 | ! |
lav$op[eq.idx] <- "=" |
| 139 |
} |
|
| 140 | ! |
con <- paste(gsub("\\.", "", lav$lhs[con.idx]), " ",
|
| 141 | ! |
lav$op[con.idx], " ", |
| 142 | ! |
gsub("\\.", "", lav$rhs[con.idx]), ";",
|
| 143 | ! |
sep = "" |
| 144 |
) |
|
| 145 | ! |
con2 <- paste(" ", con, collapse = "\n")
|
| 146 | ! |
constraints <- paste(constraints, con2, sep = "\n") |
| 147 |
} else {
|
|
| 148 | ! |
constraints <- "" |
| 149 |
} |
|
| 150 | ||
| 151 | ! |
out <- paste(header, body, constraints, footer, sep = "") |
| 152 | ! |
class(out) <- c("lavaan.character", "character")
|
| 153 | ! |
out |
| 154 |
} |
|
| 155 | ||
| 156 | ||
| 157 |
# helper functions |
|
| 158 |
lav_mplus_estimator <- function(object) {
|
|
| 159 | ! |
estimator <- object@Options$estimator |
| 160 | ! |
if (estimator == "DWLS") {
|
| 161 | ! |
estimator <- "WLS" |
| 162 |
} |
|
| 163 | ||
| 164 |
# only 1 argument for 'test' is allowed |
|
| 165 | ! |
if (length(object@Options$test) > 1L) {
|
| 166 | ! |
standard.idx <- which(object@Options$test == "standard") |
| 167 | ! |
if (length(standard.idx) > 1L) {
|
| 168 | ! |
object@Options$test <- object@Options$test[-standard.idx] |
| 169 |
} |
|
| 170 | ! |
if (length(object@Options$test) > 1L) {
|
| 171 | ! |
lav_msg_warn(gettext("only first (non-standard) test will be used"))
|
| 172 | ! |
object@Options$test <- object@Options$test[1] |
| 173 |
} |
|
| 174 |
} |
|
| 175 | ||
| 176 | ! |
if (estimator == "ML") {
|
| 177 | ! |
if (object@Options$test %in% c("yuan.bentler", "yuan.bentler.mplus")) {
|
| 178 | ! |
estimator <- "MLR" |
| 179 | ! |
} else if (object@Options$test == "satorra.bentler") {
|
| 180 | ! |
estimator <- "MLM" |
| 181 | ! |
} else if (object@Options$test == "scaled.shifted") {
|
| 182 | ! |
estimator <- "MLMV" |
| 183 | ! |
} else if (object@Options$se == "first.order") {
|
| 184 | ! |
estimator <- "MLF" |
| 185 |
} |
|
| 186 | ! |
} else if (estimator %in% c("ULS", "WLS")) {
|
| 187 | ! |
if (object@Options$test == "satorra.bentler") {
|
| 188 | ! |
estimator <- paste(estimator, "M", sep = "") |
| 189 | ! |
} else if (object@Options$test == "scaled.shifted") {
|
| 190 | ! |
estimator <- paste(estimator, "MV", sep = "") |
| 191 |
} |
|
| 192 | ! |
} else if (estimator == "MML") {
|
| 193 | ! |
estimator <- "ML" |
| 194 |
} |
|
| 195 | ||
| 196 | ! |
estimator |
| 197 |
} |
|
| 198 | ||
| 199 |
lav_mplus_header <- function(data.file = NULL, group.label = "", ov.names = "", |
|
| 200 |
listwise = FALSE, |
|
| 201 |
ov.ord.names = "", estimator = "ML", |
|
| 202 |
meanstructure = FALSE, |
|
| 203 |
weight.name = character(0L), |
|
| 204 |
information = "observed", |
|
| 205 |
data.type = "full", nobs = NULL) {
|
|
| 206 |
# replace '.' by '_' in all variable names |
|
| 207 | ! |
ov.names <- gsub("\\.", "_", ov.names)
|
| 208 | ! |
ov.ord.names <- gsub("\\.", "_", ov.ord.names)
|
| 209 | ||
| 210 |
### FIXME!! |
|
| 211 |
### this is old code from lavaan 0.3-1 |
|
| 212 |
### surely, this can be done better... |
|
| 213 | ||
| 214 |
# TITLE command |
|
| 215 | ! |
c.TITLE <- "TITLE:\n" |
| 216 | ! |
c.TITLE <- paste( |
| 217 | ! |
c.TITLE, |
| 218 | ! |
" [This syntax is autogenerated by lav_export]\n" |
| 219 |
) |
|
| 220 | ||
| 221 |
# DATA command |
|
| 222 | ! |
c.DATA <- "DATA:\n" |
| 223 | ! |
ngroups <- length(data.file) |
| 224 | ! |
if (ngroups == 1L) {
|
| 225 | ! |
c.DATA <- paste(c.DATA, |
| 226 | ! |
" file is ", data.file, ";\n", |
| 227 | ! |
sep = "" |
| 228 |
) |
|
| 229 |
} else {
|
|
| 230 | ! |
for (g in 1:ngroups) {
|
| 231 | ! |
c.DATA <- paste(c.DATA, |
| 232 | ! |
" file (", group.label[g], ") is ",
|
| 233 | ! |
data.file[g], ";\n", |
| 234 | ! |
sep = "" |
| 235 |
) |
|
| 236 |
} |
|
| 237 |
} |
|
| 238 | ! |
if (data.type == "full") {
|
| 239 | ! |
c.DATA <- paste(c.DATA, " type is individual;\n", sep = "") |
| 240 | ! |
if (listwise) {
|
| 241 | ! |
c.DATA <- paste(c.DATA, " listwise = on;\n", sep = "") |
| 242 |
} |
|
| 243 | ! |
} else if (data.type == "moment") {
|
| 244 | ! |
c.DATA <- paste(c.DATA, " type is fullcov;\n", sep = "") |
| 245 | ! |
c.DATA <- paste(c.DATA, " nobservations are ", nobs, ";\n", sep = "") |
| 246 |
} else {
|
|
| 247 | ! |
lav_msg_stop(gettext("data.type must be full or moment"))
|
| 248 |
} |
|
| 249 | ||
| 250 |
# VARIABLE command |
|
| 251 | ! |
c.VARIABLE <- "VARIABLE:\n" |
| 252 | ! |
c.VARIABLE <- paste(c.VARIABLE, " names are", sep = "") |
| 253 | ! |
nvar <- length(ov.names) |
| 254 | ! |
tmp <- 0 |
| 255 | ! |
for (i in 1:nvar) {
|
| 256 | ! |
if (tmp %% 6 == 0) {
|
| 257 | ! |
c.VARIABLE <- paste(c.VARIABLE, "\n ", sep = "") |
| 258 |
} |
|
| 259 | ! |
c.VARIABLE <- paste(c.VARIABLE, ov.names[i], sep = " ") |
| 260 | ! |
tmp <- tmp + 1 |
| 261 |
} |
|
| 262 | ! |
c.VARIABLE <- paste(c.VARIABLE, ";\n", sep = "") |
| 263 |
# missing |
|
| 264 | ! |
if (data.type == "full") {
|
| 265 | ! |
c.VARIABLE <- paste(c.VARIABLE, |
| 266 | ! |
" missing are all (-999999);\n", |
| 267 | ! |
sep = "" |
| 268 |
) |
|
| 269 |
} |
|
| 270 |
# categorical? |
|
| 271 | ! |
if (length(ov.ord.names)) {
|
| 272 | ! |
c.VARIABLE <- paste(c.VARIABLE, " categorical are", sep = "") |
| 273 | ! |
nvar <- length(ov.ord.names) |
| 274 | ! |
tmp <- 0 |
| 275 | ! |
for (i in 1:nvar) {
|
| 276 | ! |
if (tmp %% 6 == 0) {
|
| 277 | ! |
c.VARIABLE <- paste(c.VARIABLE, "\n ", sep = "") |
| 278 |
} |
|
| 279 | ! |
c.VARIABLE <- paste(c.VARIABLE, ov.ord.names[i]) |
| 280 | ! |
tmp <- tmp + 1 |
| 281 |
} |
|
| 282 | ! |
c.VARIABLE <- paste(c.VARIABLE, ";\n", sep = "") |
| 283 |
} |
|
| 284 |
# weight variable? |
|
| 285 | ! |
if (length(weight.name) > 0L) {
|
| 286 | ! |
c.VARIABLE <- paste(c.VARIABLE, |
| 287 | ! |
" weight = ", weight.name, ";\n", |
| 288 | ! |
sep = "" |
| 289 |
) |
|
| 290 |
} |
|
| 291 | ||
| 292 |
# ANALYSIS command |
|
| 293 | ! |
c.ANALYSIS <- paste("ANALYSIS:\n type = general;\n", sep = "")
|
| 294 | ! |
c.ANALYSIS <- paste(c.ANALYSIS, " estimator = ", toupper(estimator), |
| 295 | ! |
";\n", |
| 296 | ! |
sep = "" |
| 297 |
) |
|
| 298 | ! |
if (toupper(estimator) %in% c("ML", "MLR")) {
|
| 299 | ! |
c.ANALYSIS <- paste(c.ANALYSIS, " information = ", information[1], |
| 300 | ! |
";\n", |
| 301 | ! |
sep = "" |
| 302 |
) |
|
| 303 |
} |
|
| 304 | ! |
if (!meanstructure) {
|
| 305 | ! |
c.ANALYSIS <- paste(c.ANALYSIS, " model = nomeanstructure;\n", |
| 306 | ! |
sep = "" |
| 307 |
) |
|
| 308 |
} |
|
| 309 | ||
| 310 |
# MODEL command |
|
| 311 | ! |
c.MODEL <- paste("MODEL:\n")
|
| 312 | ||
| 313 |
# assemble pre-model header |
|
| 314 | ! |
out <- paste(c.TITLE, c.DATA, c.VARIABLE, c.ANALYSIS, c.MODEL, sep = "") |
| 315 | ||
| 316 | ! |
out |
| 317 |
} |
| 1 |
lav_lavaan_step06_h1 <- function(sloth1 = NULL, |
|
| 2 |
lavoptions = NULL, |
|
| 3 |
lavsamplestats = NULL, |
|
| 4 |
lavdata = NULL, |
|
| 5 |
lavpartable = NULL) {
|
|
| 6 |
# # # # # # # # # |
|
| 7 |
# # 6. lavh1 # # |
|
| 8 |
# # # # # # # # # |
|
| 9 | ||
| 10 |
# if sloth1 not NULL |
|
| 11 |
# copy to lavh1 |
|
| 12 |
# else |
|
| 13 |
# if lavoptions$h1 TRUE |
|
| 14 |
# if length(lavsamplestats$ntotal) > 0 |
|
| 15 |
# compute lavh1 via lav_h1_implied_logl |
|
| 16 |
# else |
|
| 17 |
# check lavoptions$h1 is logical, if not *** error *** |
|
| 18 | ||
| 19 | 140x |
if (!is.null(sloth1)) {
|
| 20 | 61x |
lavh1 <- sloth1 |
| 21 |
} else {
|
|
| 22 | 79x |
lavh1 <- list() |
| 23 | 79x |
if (is.logical(lavoptions$h1) && lavoptions$h1) {
|
| 24 | 79x |
if (length(lavsamplestats@ntotal) > 0L || |
| 25 | 79x |
(!is.null(lavoptions$samplestats) && !lavoptions$samplestats)) {
|
| 26 |
# lavsamplestats filled in |
|
| 27 | 77x |
if (lav_verbose()) {
|
| 28 | ! |
cat("lavh1 ... start:\n")
|
| 29 |
} |
|
| 30 | ||
| 31 |
# implied h1 statistics and logl (if available) |
|
| 32 | 77x |
lavh1 <- lav_h1_implied_logl( |
| 33 | 77x |
lavdata = lavdata, |
| 34 | 77x |
lavsamplestats = lavsamplestats, |
| 35 | 77x |
lavpartable = lavpartable, |
| 36 | 77x |
lavoptions = lavoptions |
| 37 |
) |
|
| 38 | 77x |
if (lav_debug()) {
|
| 39 | ! |
print(lavh1) |
| 40 |
} |
|
| 41 | 77x |
if (lav_verbose()) {
|
| 42 | ! |
cat("lavh1 ... done.\n")
|
| 43 |
} |
|
| 44 |
} else {
|
|
| 45 |
# do nothing for now |
|
| 46 |
} |
|
| 47 |
} else {
|
|
| 48 | ! |
if (!is.logical(lavoptions$h1)) {
|
| 49 | ! |
lav_msg_stop(gettext("argument `h1' must be logical (for now)"))
|
| 50 |
} |
|
| 51 |
# TODO: allow h1 to be either a model syntax, a parameter table, |
|
| 52 |
# or a fitted lavaan object |
|
| 53 |
} |
|
| 54 |
} |
|
| 55 | ||
| 56 | 140x |
lavh1 |
| 57 |
} |
| 1 |
# STEP 0: process full model, without fitting |
|
| 2 |
lav_sam_step0 <- function(cmd = "sem", model = NULL, data = NULL, |
|
| 3 |
se = "twostep", sam.method = "local", |
|
| 4 |
dotdotdot = NULL) {
|
|
| 5 | ||
| 6 |
# create dotdotdot0 for dummy fit |
|
| 7 | ! |
dotdotdot0 <- dotdotdot |
| 8 | ||
| 9 |
# parse model, so we can inspect a few features |
|
| 10 | ! |
flat.model <- lavParseModelString(model) |
| 11 | ||
| 12 |
# remove do.fit option if present |
|
| 13 | ! |
dotdotdot0$do.fit <- NULL |
| 14 | ||
| 15 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 16 | ! |
dotdotdot0$sample.icov <- FALSE # if N < nvar |
| 17 |
} |
|
| 18 | ! |
dotdotdot0$se <- "none" |
| 19 | ! |
dotdotdot0$test <- "none" |
| 20 | ! |
dotdotdot0$verbose <- FALSE # no output for this 'dummy' FIT |
| 21 |
# if (sam.method != "global") {
|
|
| 22 |
# dotdotdot0$conditional.x <- FALSE |
|
| 23 |
# } |
|
| 24 |
#dotdotdot0$fixed.x <- TRUE |
|
| 25 | ! |
dotdotdot0$ceq.simple <- TRUE # if not the default yet |
| 26 | ! |
dotdotdot0$check.lv.interaction <- FALSE # we allow for it |
| 27 |
# dotdotdot0$cat.wls.w <- FALSE # no weight matrix if categorical |
|
| 28 |
# note: this breaks the computation of twostep standard errors... |
|
| 29 | ! |
if (se %in% c("local", "ij", "twostep.robust")) {
|
| 30 | ! |
dotdotdot0$sample.icov <- TRUE |
| 31 | ! |
dotdotdot0$NACOV <- TRUE |
| 32 |
#dotdotdot0$gamma.unbiased <- TRUE |
|
| 33 | ! |
dotdotdot0$fixed.x <- FALSE |
| 34 | ! |
dotdotdot0$ov.order <- "force.model" # avoid data ordering... |
| 35 |
} |
|
| 36 | ||
| 37 |
# any lv interaction terms? |
|
| 38 | ! |
if (length(lav_object_vnames(flat.model, "lv.interaction")) > 0L) {
|
| 39 | ! |
dotdotdot0$meanstructure <- TRUE |
| 40 |
#dotdotdot0$marker.int.zero <- FALSE # or not? |
|
| 41 |
} |
|
| 42 | ||
| 43 |
# initial processing of the model, no fitting |
|
| 44 | ! |
FIT <- do.call(cmd, |
| 45 | ! |
args = c(list( |
| 46 | ! |
model = flat.model, |
| 47 | ! |
data = data, |
| 48 | ! |
do.fit = FALSE |
| 49 | ! |
), dotdotdot0) |
| 50 |
) |
|
| 51 | ||
| 52 |
# restore options |
|
| 53 | ||
| 54 |
# do.fit |
|
| 55 | ! |
FIT@Options$do.fit <- TRUE |
| 56 |
# FIT@Options$cat.wls.w <- TRUE |
|
| 57 | ||
| 58 |
# sample.icov |
|
| 59 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 60 | ! |
FIT@Options$sample.icov <- TRUE |
| 61 |
} |
|
| 62 | ||
| 63 |
# se |
|
| 64 | ! |
if (FIT@Model@categorical && se == "twostep") {
|
| 65 |
# FIXME! |
|
| 66 |
# should do this for global too, but we need the 'P' matrix, which |
|
| 67 |
# we only have for local (for now) |
|
| 68 | ! |
if (sam.method == "local") {
|
| 69 | ! |
se <- "twostep.robust" |
| 70 |
} |
|
| 71 |
} |
|
| 72 | ! |
FIT@Options$se <- se |
| 73 | ||
| 74 |
# test |
|
| 75 | ! |
if (!is.null(dotdotdot$test)) {
|
| 76 | ! |
FIT@Options$test <- dotdotdot$test |
| 77 |
} else {
|
|
| 78 | ! |
FIT@Options$test <- "standard" |
| 79 |
} |
|
| 80 | ||
| 81 |
# adjust parameter table: |
|
| 82 | ! |
PT <- FIT@ParTable |
| 83 | ||
| 84 |
# check parameter table |
|
| 85 | ! |
PT$est <- PT$se <- NULL |
| 86 |
# est equals ustart by default (except exo values) |
|
| 87 | ! |
PT$est <- PT$ustart |
| 88 | ! |
if (any(PT$exo > 0L)) {
|
| 89 | ! |
PT$est[PT$exo > 0L] <- PT$start[PT$exo > 0L] |
| 90 |
} |
|
| 91 | ||
| 92 |
# clear se values (needed here?) only for global approach to compute SE |
|
| 93 | ! |
PT$se <- rep(as.numeric(NA), length(PT$lhs)) |
| 94 | ! |
PT$se[PT$free == 0L & !is.na(PT$ustart)] <- 0.0 |
| 95 | ||
| 96 | ! |
FIT@ParTable <- PT |
| 97 | ||
| 98 | ||
| 99 | ! |
FIT |
| 100 |
} |
| 1 |
# handle bare-minimum partables |
|
| 2 |
# add some additional columns |
|
| 3 |
lav_partable_complete <- function(partable = NULL, start = TRUE) { # nolint
|
|
| 4 |
# check if we hava a data.frame |
|
| 5 |
# if so, check for columns that are 'factor' and convert them to 'character' |
|
| 6 | 237x |
ovda <- attr(partable, "ovda") |
| 7 | 237x |
if (is.data.frame(partable)) {
|
| 8 | ! |
fac.idx <- sapply(partable, is.factor) |
| 9 | ! |
partable[fac.idx] <- lapply(partable[fac.idx], as.character) |
| 10 |
} |
|
| 11 | ||
| 12 |
# check if we have lhs, op, rhs |
|
| 13 | 237x |
stopifnot(!is.null(partable$lhs), |
| 14 | 237x |
!is.null(partable$op), |
| 15 | 237x |
!is.null(partable$rhs)) |
| 16 | ||
| 17 |
# number of elements |
|
| 18 | 237x |
tmp.n <- length(partable$lhs) |
| 19 | 237x |
if (!is.data.frame(partable)) {
|
| 20 |
# check for equal column length |
|
| 21 | 237x |
nel <- sapply(partable, length) |
| 22 | 237x |
short.idx <- which(nel < tmp.n) |
| 23 | 237x |
long.idx <- which(nel > tmp.n) |
| 24 | 237x |
if (length(long.idx) > 0L) {
|
| 25 | ! |
lav_msg_warn(gettext("partable columns have unequal length"))
|
| 26 |
} |
|
| 27 | 237x |
if (length(short.idx) > 0L) {
|
| 28 |
# try to extend them in a 'natural' way |
|
| 29 | ! |
for (i in short.idx) {
|
| 30 | ! |
too.short <- tmp.n - nel[i] |
| 31 | ! |
if (is.integer(partable[[i]])) {
|
| 32 | ! |
partable[[i]] <- c(partable[[i]], |
| 33 | ! |
integer(too.short)) |
| 34 | ! |
} else if (is.numeric(partable[[i]])) {
|
| 35 | ! |
partable[[i]] <- c(partable[[i]], |
| 36 | ! |
numeric(too.short)) |
| 37 |
} else {
|
|
| 38 | ! |
partable[[i]] <- c(partable[[i]], |
| 39 | ! |
character(too.short)) |
| 40 |
} |
|
| 41 |
} |
|
| 42 |
} |
|
| 43 |
} |
|
| 44 | ||
| 45 |
# create new id column |
|
| 46 |
# if(is.null(partable$id)) {
|
|
| 47 | 237x |
partable$id <- seq_len(tmp.n) |
| 48 |
# } |
|
| 49 | ||
| 50 |
# add user column |
|
| 51 | 237x |
if (is.null(partable$user)) {
|
| 52 | ! |
partable$user <- rep(1L, tmp.n) |
| 53 |
} else {
|
|
| 54 | 237x |
partable$user <- as.integer(partable$user) |
| 55 |
} |
|
| 56 | ||
| 57 |
# add block column |
|
| 58 | 237x |
if (is.null(partable$block)) {
|
| 59 | ! |
partable$block <- rep(1L, tmp.n) |
| 60 |
} else {
|
|
| 61 | 237x |
partable$block <- as.integer(partable$block) |
| 62 |
} |
|
| 63 | ||
| 64 |
# add group column |
|
| 65 | 237x |
if (is.null(partable$group)) {
|
| 66 | ! |
partable$group <- rep(1L, tmp.n) |
| 67 |
} else {
|
|
| 68 |
# partable$group <- as.integer(partable$group) # maybe labels? |
|
| 69 |
} |
|
| 70 | ||
| 71 |
# add free column |
|
| 72 | 237x |
if (is.null(partable$free)) {
|
| 73 | ! |
partable$free <- seq_len(tmp.n) |
| 74 |
# 0.6-11: check for simple equality constraints |
|
| 75 |
# note: this is perhaps only a subset (eg SAM!) of a larger |
|
| 76 |
# table, and we have to renumber the 'free' column |
|
| 77 | 237x |
} else if (is.integer(partable$free) && |
| 78 | 237x |
any(partable$free > 0L) && |
| 79 | 237x |
!any(partable$op == "==") && |
| 80 | 237x |
!is.null(partable$label) && |
| 81 | 237x |
!is.null(partable$plabel) && |
| 82 | 237x |
any(duplicated(partable$free[partable$free > 0L]))) {
|
| 83 | ! |
dup.idx <- which(partable$free > 0L & duplicated(partable$free)) |
| 84 | ! |
all.idx <- which(partable$free %in% unique(partable$free[dup.idx])) |
| 85 | ! |
eq.labels <- unique(partable$free[all.idx]) |
| 86 | ! |
eq.id <- integer(length(partable$lhs)) |
| 87 | ! |
eq.id[all.idx] <- partable$free[all.idx] |
| 88 | ! |
partable$free[dup.idx] <- 0L |
| 89 | ! |
idx.free <- which(partable$free > 0L) |
| 90 | ! |
partable$free <- rep(0L, tmp.n) |
| 91 | ! |
partable$free[idx.free] <- seq_along(idx.free) |
| 92 | ! |
for (eq.label in eq.labels) {
|
| 93 | ! |
all.idx <- which(eq.id == eq.label) |
| 94 | ! |
ref.idx <- all.idx[1L] |
| 95 | ! |
other.idx <- all.idx[-1L] |
| 96 | ! |
partable$free[other.idx] <- partable$free[ref.idx] |
| 97 |
} |
|
| 98 |
} else {
|
|
| 99 |
# treat non-zero as 'free' |
|
| 100 | 237x |
free.idx <- which(as.logical(partable$free)) |
| 101 | 237x |
partable$free <- rep(0L, tmp.n) |
| 102 | 237x |
if (length(free.idx) > 0L) {
|
| 103 | 237x |
partable$free[free.idx] <- seq_len(length(free.idx)) |
| 104 |
} |
|
| 105 |
} |
|
| 106 | ||
| 107 |
# add ustart column |
|
| 108 | 237x |
if (is.null(partable$ustart)) {
|
| 109 |
# do we have something else? start? est? |
|
| 110 | ! |
if (!is.null(partable$start)) {
|
| 111 | ! |
partable$ustart <- as.numeric(partable$start) |
| 112 | ! |
} else if (!is.null(partable$est)) {
|
| 113 | ! |
partable$ustart <- as.numeric(partable$est) |
| 114 |
} else {
|
|
| 115 | ! |
partable$ustart <- rep(as.numeric(NA), tmp.n) |
| 116 | ! |
non.free <- which(!partable$free) |
| 117 | ! |
if (length(non.free)) {
|
| 118 | ! |
partable$ustart[non.free] <- 0 |
| 119 |
} |
|
| 120 |
} |
|
| 121 |
} else {
|
|
| 122 | 237x |
partable$ustart <- as.numeric(partable$ustart) |
| 123 |
} |
|
| 124 | ||
| 125 |
# add exo column |
|
| 126 | 237x |
if (is.null(partable$exo)) {
|
| 127 | ! |
partable$exo <- rep(0, tmp.n) |
| 128 |
} else {
|
|
| 129 | 237x |
partable$exo <- as.integer(partable$exo) |
| 130 |
} |
|
| 131 | ||
| 132 |
# add label column |
|
| 133 | 237x |
if (is.null(partable$label)) {
|
| 134 | 61x |
partable$label <- rep("", tmp.n)
|
| 135 |
} else {
|
|
| 136 | 176x |
partable$label <- as.character(partable$label) |
| 137 |
} |
|
| 138 | ||
| 139 |
# order them nicely: id lhs op rhs group |
|
| 140 | 237x |
idx <- match(c("id", "lhs", "op", "rhs", "user", "block", "group",
|
| 141 | 237x |
"free", "ustart", "exo", "label"), |
| 142 | 237x |
names(partable)) |
| 143 | 237x |
tmp <- partable[idx] |
| 144 | 237x |
partable <- c(tmp, partable[-idx]) |
| 145 | ||
| 146 |
# add start column |
|
| 147 | 237x |
if (start) {
|
| 148 | 237x |
if (is.null(partable$start)) {
|
| 149 | 61x |
partable$start <- lav_start(start.method = "simple", |
| 150 | 61x |
lavpartable = partable) |
| 151 |
} |
|
| 152 |
} |
|
| 153 | 237x |
attr(partable, "ovda") <- ovda |
| 154 | 237x |
attr(partable, "vnames") <- lav_partable_vnames(partable, "*") |
| 155 | 237x |
partable |
| 156 |
} |
| 1 |
# initial version: YR 03/05/2017 |
|
| 2 | ||
| 3 |
# major change: YR 14/06/2022 for 0.6-12 |
|
| 4 |
# - summary() is now silent if not printed |
|
| 5 |
# - here, we only collect the necessary ingredients, and store them in a |
|
| 6 |
# a list |
|
| 7 |
# - the result is a S3 class lavaan.summary |
|
| 8 |
# - the actual printing is done by lav_summary_print (see lav_print.R) |
|
| 9 | ||
| 10 |
# YR 26 July 2022: add fm.args= argument to change the way (some) fit measures |
|
| 11 |
# are computed |
|
| 12 |
# YR 24 Sept 2022: add efa= argument |
|
| 13 |
# YR 19 Nov 2023: add remove.unused= argument |
|
| 14 |
# TDJ 28 March 2024: deprecate std.nox= argument ("std.nox" can be %in% standardized=)
|
|
| 15 | ||
| 16 |
# create summary of a lavaan object |
|
| 17 |
lav_object_summary <- function(object, header = TRUE, |
|
| 18 |
fit.measures = FALSE, |
|
| 19 |
baseline.model = NULL, |
|
| 20 |
h1.model = NULL, |
|
| 21 |
fm.args = |
|
| 22 |
list( |
|
| 23 |
standard.test = "default", |
|
| 24 |
scaled.test = "default", |
|
| 25 |
rmsea.ci.level = 0.90, |
|
| 26 |
rmsea.h0.closefit = 0.05, |
|
| 27 |
rmsea.h0.notclosefit = 0.08 |
|
| 28 |
), |
|
| 29 |
estimates = TRUE, |
|
| 30 |
ci = FALSE, |
|
| 31 |
fmi = FALSE, |
|
| 32 |
standardized = FALSE, |
|
| 33 |
std = standardized, |
|
| 34 |
remove.system.eq = TRUE, |
|
| 35 |
remove.eq = TRUE, |
|
| 36 |
remove.ineq = TRUE, |
|
| 37 |
remove.def = FALSE, |
|
| 38 |
remove.nonfree = FALSE, |
|
| 39 |
remove.step1 = TRUE, |
|
| 40 |
remove.unused = TRUE, |
|
| 41 |
plabel = FALSE, |
|
| 42 |
cov.std = TRUE, |
|
| 43 |
rsquare = FALSE, |
|
| 44 |
efa = FALSE, |
|
| 45 |
efa.args = |
|
| 46 |
list( |
|
| 47 |
lambda = TRUE, |
|
| 48 |
theta = TRUE, |
|
| 49 |
psi = TRUE, |
|
| 50 |
eigenvalues = TRUE, |
|
| 51 |
sumsq.table = TRUE, |
|
| 52 |
lambda.structure = FALSE, |
|
| 53 |
fs.determinacy = FALSE, |
|
| 54 |
se = FALSE, |
|
| 55 |
zstat = FALSE, |
|
| 56 |
pvalue = FALSE |
|
| 57 |
), |
|
| 58 |
modindices = FALSE, |
|
| 59 |
srmr.close.h0 = NULL) {
|
|
| 60 | ||
| 61 |
# check object |
|
| 62 | 25x |
object <- lav_object_check_version(object) |
| 63 | ||
| 64 |
# default fm.args |
|
| 65 | 25x |
default.fm.args <- list( |
| 66 | 25x |
standard.test = "default", |
| 67 | 25x |
scaled.test = "default", |
| 68 | 25x |
rmsea.ci.level = 0.90, |
| 69 | 25x |
rmsea.close.h0 = 0.05, |
| 70 | 25x |
rmsea.notclose.h0 = 0.08, |
| 71 | 25x |
robust = TRUE, |
| 72 | 25x |
cat.check.pd = TRUE |
| 73 |
) |
|
| 74 | 25x |
if (is.logical(fit.measures)) {
|
| 75 | 5x |
if (fit.measures) {
|
| 76 | ! |
fit.measures <- "default" |
| 77 |
} else {
|
|
| 78 | 5x |
fit.measures <- "none" |
| 79 |
} |
|
| 80 |
} |
|
| 81 | 25x |
if (!missing(fm.args)) {
|
| 82 | ! |
lav_deprecated_args("fit.measures", "fm.args")
|
| 83 | ! |
fm.args <- modifyList(default.fm.args, fm.args) |
| 84 |
} else {
|
|
| 85 | 25x |
fm.args <- default.fm.args |
| 86 |
} |
|
| 87 | 25x |
if (is.list(fit.measures)) {
|
| 88 | 20x |
if (is.null(names(fit.measures)) || |
| 89 | 20x |
is.null(fit.measures$fit.measures)) {
|
| 90 | ! |
lav_msg_stop(gettextf( |
| 91 | ! |
"If %s is a list, it must contain a named element %s.", |
| 92 | ! |
"fit.measures" |
| 93 |
)) |
|
| 94 |
} |
|
| 95 | 20x |
temp <- fit.measures$fit.measures |
| 96 | 20x |
fit.measures$fit.measures <- NULL |
| 97 | 20x |
fm.args <- modifyList(default.fm.args, fit.measures) |
| 98 | 20x |
fit.measures <- temp |
| 99 |
} |
|
| 100 | ||
| 101 | ||
| 102 |
# return a list with the main ingredients |
|
| 103 | 25x |
res <- list() |
| 104 | ||
| 105 |
# this is to avoid partial matching of 'std' with std.nox |
|
| 106 | 25x |
if (is.logical(std) && is.logical(standardized)) {
|
| 107 | 25x |
standardized <- std || standardized |
| 108 |
} else {
|
|
| 109 |
# At least 1 is not logical. Retain only valid standardization options. |
|
| 110 | ! |
standardized <- intersect(union(tolower(std), tolower(standardized)), |
| 111 | ! |
c("std.lv","std.all","std.nox"))
|
| 112 |
} |
|
| 113 | ||
| 114 |
# create the 'short' summary |
|
| 115 | 25x |
if (header) {
|
| 116 |
# 1. collect header information |
|
| 117 | 21x |
VERSION <- object@version |
| 118 | ||
| 119 | 21x |
res$header <- list( |
| 120 | 21x |
lavaan.version = VERSION, |
| 121 | 21x |
sam.approach = !is.null(object@internal$sam.method), |
| 122 | 21x |
optim.method = object@Options$optim.method, |
| 123 | 21x |
optim.iterations = object@optim$iterations, |
| 124 | 21x |
optim.converged = object@optim$converged |
| 125 |
) |
|
| 126 | ||
| 127 |
# sam or sem? |
|
| 128 | 21x |
if (!is.null(object@internal$sam.method)) {
|
| 129 |
# SAM version |
|
| 130 | ||
| 131 |
# 2. sam header |
|
| 132 | ! |
res$sam.header <- |
| 133 | ! |
list( |
| 134 | ! |
sam.method = object@internal$sam.method, |
| 135 | ! |
sam.local.options = object@internal$sam.local.options, |
| 136 | ! |
sam.mm.list = object@internal$sam.mm.list, |
| 137 | ! |
sam.mm.estimator = object@internal$sam.mm.estimator, |
| 138 | ! |
sam.struc.estimator = object@internal$sam.struc.estimator |
| 139 |
) |
|
| 140 | ||
| 141 |
# 3. no EFA (for now)? |
|
| 142 | ||
| 143 |
# 4. summarize lavdata |
|
| 144 | ! |
res$data <- lav_data_summary_short(object@Data) |
| 145 | ||
| 146 |
# 5a. sam local test statistics |
|
| 147 | ! |
res$sam <- list( |
| 148 | ! |
sam.method = object@internal$sam.method, |
| 149 | ! |
sam.mm.table = object@internal$sam.mm.table, |
| 150 | ! |
sam.mm.rel = object@internal$sam.mm.rel, |
| 151 | ! |
sam.struc.fit = object@internal$sam.struc.fit, |
| 152 | ! |
ngroups = object@Data@ngroups, |
| 153 | ! |
group.label = object@Data@group.label, |
| 154 | ! |
nlevels = object@Data@nlevels, |
| 155 | ! |
level.label = object@Data@level.label, |
| 156 | ! |
block.label = object@Data@block.label |
| 157 |
) |
|
| 158 | ||
| 159 |
# 5b. global test statistics (for global only) |
|
| 160 | ! |
if (object@internal$sam.method == "global") {
|
| 161 | ! |
res$test <- object@test |
| 162 |
} |
|
| 163 |
} else {
|
|
| 164 |
# SEM version |
|
| 165 | ||
| 166 |
# 2. summarize optim info (including estimator) |
|
| 167 | 21x |
nrow.ceq.jac <- nrow(object@Model@ceq.JAC) |
| 168 |
#if (object@Model@ceq.simple.only) {
|
|
| 169 |
# not needed, as nrow.ceq.jac is already zero |
|
| 170 |
# nrow.ceq.jac <- 0L |
|
| 171 |
#} |
|
| 172 | 21x |
cin.simple.only <- FALSE |
| 173 | 21x |
ceq.simple.only <- FALSE |
| 174 | 21x |
cin.simple.only <- object@Model@cin.simple.only |
| 175 | 21x |
ceq.simple.only <- object@Model@ceq.simple.only |
| 176 | 21x |
nrow.cin.jac <- nrow(object@Model@cin.JAC) |
| 177 | 21x |
if (cin.simple.only) {
|
| 178 | 1x |
nrow.cin.jac <- 0L |
| 179 |
} |
|
| 180 | 21x |
if (ceq.simple.only && cin.simple.only) {
|
| 181 | ! |
nrow.con.jac <- 0L |
| 182 | ! |
con.jac.rank <- 0L |
| 183 |
} else {
|
|
| 184 | 21x |
nrow.con.jac <- nrow(object@Model@con.jac) |
| 185 | 21x |
con.jac.rank <- qr(object@Model@con.jac)$rank |
| 186 |
} |
|
| 187 | ||
| 188 | 21x |
res$optim <- list( |
| 189 | 21x |
estimator = object@Options$estimator, |
| 190 | 21x |
estimator.args = object@Options$estimator.args, |
| 191 | 21x |
optim.method = object@Options$optim.method, |
| 192 | 21x |
npar = object@Model@nx.free, |
| 193 | 21x |
eq.constraints = object@Model@eq.constraints, |
| 194 | 21x |
nrow.ceq.jac = nrow.ceq.jac, |
| 195 | 21x |
nrow.cin.jac = nrow.cin.jac, |
| 196 | 21x |
nrow.con.jac = nrow.con.jac, |
| 197 | 21x |
con.jac.rank = con.jac.rank |
| 198 |
) |
|
| 199 | ||
| 200 | ||
| 201 |
# 3. if EFA/ESEM, summarize rotation info |
|
| 202 | 21x |
if (object@Model@nefa > 0L) {
|
| 203 | 1x |
res$rotation <- |
| 204 | 1x |
list( |
| 205 | 1x |
rotation = object@Options$rotation, |
| 206 | 1x |
rotation.args = object@Options$rotation.args |
| 207 |
) |
|
| 208 |
} |
|
| 209 | ||
| 210 |
# 4. summarize lavdata |
|
| 211 | 21x |
res$data <- lav_data_summary_short(object@Data) |
| 212 | ||
| 213 |
# 5. test statistics |
|
| 214 | 21x |
TEST <- object@test |
| 215 |
# TDJ: check for user-supplied h1 model |
|
| 216 | 21x |
if (!is.null(object@external$h1.model)) {
|
| 217 | ! |
stopifnot(inherits(object@external$h1.model, "lavaan")) |
| 218 |
## update @test slot |
|
| 219 | ! |
TEST <- lav_update_test_custom_h1(lav_obj_h0 = object, |
| 220 | ! |
lav_obj_h1 = object@external$h1.model)@test |
| 221 |
} |
|
| 222 |
# double check if we have attr(TEST, "info") (perhaps old object?) |
|
| 223 | 21x |
if (is.null(attr(TEST, "info"))) {
|
| 224 | ! |
lavdata <- object@Data |
| 225 | ! |
lavoptions <- object@Options |
| 226 | ! |
attr(TEST, "info") <- |
| 227 | ! |
list( |
| 228 | ! |
ngroups = lavdata@ngroups, |
| 229 | ! |
group.label = lavdata@group.label, |
| 230 | ! |
information = lavoptions$information, |
| 231 | ! |
h1.information = lavoptions$h1.information, |
| 232 | ! |
observed.information = lavoptions$observed.information |
| 233 |
) |
|
| 234 |
} |
|
| 235 | 21x |
res$test <- TEST |
| 236 |
} # regular sem |
|
| 237 |
} # header |
|
| 238 | ||
| 239 |
# efa-related info |
|
| 240 | 25x |
if (efa) {
|
| 241 | 4x |
res$efa <- lav_efa_summary(object, efa.args = efa.args) |
| 242 |
} # efa |
|
| 243 | ||
| 244 |
# only if requested, add the additional fit measures |
|
| 245 | 25x |
if (fit.measures != "none") {
|
| 246 |
# some early warnings (to avoid a hard stop) |
|
| 247 | ! |
if (object@Data@data.type == "none") {
|
| 248 | ! |
lav_msg_warn(gettext( |
| 249 | ! |
"fit measures not available if there is no data")) |
| 250 | ! |
} else if (length(object@Options$test) == 1L && |
| 251 | ! |
object@Options$test == "none") {
|
| 252 | ! |
lav_msg_warn(gettext( |
| 253 | ! |
"fit measures not available if test = \"none\"")) |
| 254 | ! |
} else if (object@optim$npar > 0L && !object@optim$converged) {
|
| 255 | ! |
lav_msg_warn(gettext( |
| 256 | ! |
"fit measures not available if model did not converge")) |
| 257 |
} else {
|
|
| 258 | ! |
FIT <- lav_fit_measures(object, |
| 259 | ! |
fit.measures = c(list(fit.measures = fit.measures), fm.args), |
| 260 | ! |
baseline.model = baseline.model, |
| 261 | ! |
h1.model = h1.model) |
| 262 | ! |
res$fit <- FIT |
| 263 |
} |
|
| 264 |
} |
|
| 265 | ||
| 266 |
# main ingredient: the parameter table |
|
| 267 | 25x |
if (estimates) {
|
| 268 | 24x |
PE <- lavParameterEstimates(object, |
| 269 | 24x |
ci = ci, standardized = standardized, |
| 270 | 24x |
rsquare = rsquare, fmi = fmi, |
| 271 | 24x |
cov.std = cov.std, |
| 272 | 24x |
remove.eq = remove.eq, remove.system.eq = remove.system.eq, |
| 273 | 24x |
remove.ineq = remove.ineq, remove.def = remove.def, |
| 274 | 24x |
remove.nonfree = remove.nonfree, |
| 275 | 24x |
remove.step1 = remove.step1, |
| 276 | 24x |
remove.unused = remove.unused, |
| 277 | 24x |
plabel = plabel, |
| 278 | 24x |
output = "text", |
| 279 | 24x |
header = TRUE |
| 280 |
) |
|
| 281 | 24x |
res$pe <- as.data.frame(PE) |
| 282 |
} |
|
| 283 | ||
| 284 |
# modification indices? |
|
| 285 | 25x |
if (is.logical(modindices)) {
|
| 286 | ! |
if (modindices) modindices <- list(standardized = TRUE, cov.std = cov.std) |
| 287 |
} |
|
| 288 | 25x |
if (is.list(modindices)) {
|
| 289 | ! |
MI <- do.call("modificationIndices", c(list(object = object), modindices))
|
| 290 | ! |
res$mi <- MI |
| 291 |
} |
|
| 292 | ||
| 293 |
# create lavaan.summary S3 class |
|
| 294 | 25x |
class(res) <- c("lavaan.summary", "list")
|
| 295 | ||
| 296 | 25x |
res |
| 297 |
} |
| 1 |
# what are the block values (not necessarily integers) |
|
| 2 |
lav_partable_block_values <- function(partable) {
|
|
| 3 | 16308x |
if (is.null(partable$block)) {
|
| 4 | ! |
block.values <- 1L |
| 5 |
} else {
|
|
| 6 |
# always integers |
|
| 7 | 16308x |
tmp <- partable$block[partable$block > 0L & # non-zero only |
| 8 | 16308x |
!partable$op %in% c("==", "<", ">", ":=")]
|
| 9 | 16308x |
block.values <- unique(na.omit(tmp)) # could be, eg, '2' only |
| 10 |
} |
|
| 11 | ||
| 12 | 16308x |
block.values |
| 13 |
} |
|
| 14 | ||
| 15 |
# guess number of blocks from a partable |
|
| 16 |
lav_partable_nblocks <- function(partable) {
|
|
| 17 | 477x |
length(lav_partable_block_values(partable)) |
| 18 |
} |
|
| 19 | ||
| 20 |
# what are the group values (not necessarily integers) |
|
| 21 |
lav_partable_group_values <- function(partable) {
|
|
| 22 |
# FLAT? |
|
| 23 | 1293x |
if (any(partable$op == ":")) {
|
| 24 | ! |
colon.idx <- which(partable$op == ":" & |
| 25 | ! |
tolower(partable$lhs) == "group") |
| 26 | ! |
if (length(colon.idx) > 0L) {
|
| 27 | ! |
group.values <- unique(partable$rhs[colon.idx]) |
| 28 |
} |
|
| 29 |
# regular partable |
|
| 30 | 1293x |
} else if (is.null(partable$group)) {
|
| 31 | ! |
group.values <- 1L |
| 32 | 1293x |
} else if (is.numeric(partable$group)) {
|
| 33 | 1271x |
tmp <- partable$group[partable$group > 0L & |
| 34 | 1271x |
!partable$op %in% c("==", "<", ">", ":=")]
|
| 35 | 1271x |
group.values <- unique(na.omit(tmp)) |
| 36 |
} else { # character
|
|
| 37 | 22x |
tmp <- partable$group[nchar(partable$group) > 0L & |
| 38 | 22x |
!partable$op %in% c("==", "<", ">", ":=")]
|
| 39 | 22x |
group.values <- unique(na.omit(tmp)) |
| 40 |
} |
|
| 41 | ||
| 42 | 1293x |
group.values |
| 43 |
} |
|
| 44 | ||
| 45 |
# guess number of groups from a partable |
|
| 46 |
lav_partable_ngroups <- function(partable) {
|
|
| 47 | 1118x |
length(lav_partable_group_values(partable)) |
| 48 |
} |
|
| 49 | ||
| 50 |
# what are the level values (not necessarily integers) |
|
| 51 |
lav_partable_level_values <- function(partable) {
|
|
| 52 |
# FLAT? |
|
| 53 | 3019x |
if (any(partable$op == ":")) {
|
| 54 | 12x |
colon.idx <- which(partable$op == ":" & |
| 55 | 12x |
tolower(partable$lhs) == "level") |
| 56 | 12x |
level.values <- integer(0L) |
| 57 | 12x |
if (length(colon.idx) > 0L) {
|
| 58 | 12x |
level.values <- unique(partable$rhs[colon.idx]) |
| 59 |
} |
|
| 60 |
# regular partable |
|
| 61 | 3007x |
} else if (is.null(partable$level)) {
|
| 62 | 2640x |
level.values <- 1L |
| 63 | 367x |
} else if (is.numeric(partable$level)) {
|
| 64 | 169x |
tmp <- partable$level[partable$level > 0L & |
| 65 | 169x |
!partable$op %in% c("==", "<", ">", ":=")]
|
| 66 | 169x |
level.values <- unique(na.omit(tmp)) |
| 67 |
} else { # character
|
|
| 68 | 198x |
tmp <- partable$level[nchar(partable$level) > 0L & |
| 69 | 198x |
!partable$op %in% c("==", "<", ">", ":=")]
|
| 70 | 198x |
level.values <- unique(na.omit(tmp)) |
| 71 |
} |
|
| 72 | ||
| 73 | 3019x |
level.values |
| 74 |
} |
|
| 75 | ||
| 76 |
# guess number of levels from a partable |
|
| 77 |
lav_partable_nlevels <- function(partable) {
|
|
| 78 | 2995x |
length(lav_partable_level_values(partable)) |
| 79 |
} |
|
| 80 | ||
| 81 |
# efa sets values |
|
| 82 |
lav_partable_efa_values <- function(partable) {
|
|
| 83 | 1798x |
if (is.null(partable$efa)) {
|
| 84 | 246x |
efa.values <- character(0L) |
| 85 |
} else { # should be character
|
|
| 86 | 1552x |
tmp.efa <- as.character(partable$efa) |
| 87 | 1552x |
tmp <- tmp.efa[nchar(tmp.efa) > 0L & |
| 88 | 1552x |
!partable$op %in% c("==", "<", ">", ":=")]
|
| 89 | 1552x |
efa.values <- unique(na.omit(tmp)) |
| 90 |
} |
|
| 91 | ||
| 92 | 1798x |
efa.values |
| 93 |
} |
|
| 94 | ||
| 95 |
# number of efa sets from a partable |
|
| 96 |
lav_partable_nefa <- function(partable) {
|
|
| 97 | 258x |
length(lav_partable_efa_values(partable)) |
| 98 |
} |
|
| 99 | ||
| 100 | ||
| 101 | ||
| 102 | ||
| 103 |
# number of sample statistics per block |
|
| 104 |
lav_partable_ndat <- function(partable) {
|
|
| 105 |
# global |
|
| 106 | 138x |
meanstructure <- any(partable$op == "~1") |
| 107 | 138x |
fixed.x <- any(partable$exo > 0L & partable$free == 0L) |
| 108 | 138x |
conditional.x <- any(partable$exo > 0L & partable$op == "~") |
| 109 | 138x |
categorical <- any(partable$op == "|") |
| 110 | 138x |
composites <- any(partable$op == "<~") |
| 111 | 138x |
correlation <- any(partable$op == "~*~") |
| 112 | 138x |
if (categorical) {
|
| 113 | 4x |
meanstructure <- TRUE |
| 114 |
} |
|
| 115 | ||
| 116 |
# blocks |
|
| 117 | 138x |
nblocks <- lav_partable_nblocks(partable) |
| 118 | 138x |
nlevels <- lav_partable_nlevels(partable) |
| 119 | 138x |
ndat <- integer(nblocks) |
| 120 | ||
| 121 | 138x |
for (b in seq_len(nblocks)) {
|
| 122 |
# how many observed variables in this block? |
|
| 123 | 154x |
if (conditional.x) {
|
| 124 | 4x |
ov.names <- lav_partable_vnames(partable, "ov.nox", block = b) |
| 125 |
} else {
|
|
| 126 | 150x |
ov.names <- lav_partable_vnames(partable, "ov", block = b) |
| 127 |
} |
|
| 128 | 154x |
nvar <- length(ov.names) |
| 129 | ||
| 130 |
# pstar |
|
| 131 | 154x |
pstar <- nvar * (nvar + 1) / 2 |
| 132 | 154x |
if (meanstructure) {
|
| 133 | 110x |
pstar <- pstar + nvar |
| 134 | ||
| 135 |
# no meanstructure if within level, except ov.x which is not |
|
| 136 |
# decomposed |
|
| 137 | 110x |
if (nlevels > 1L && (b %% nlevels) == 1L) {
|
| 138 |
# all zero |
|
| 139 | 8x |
pstar <- pstar - nvar |
| 140 | ||
| 141 |
# except within-only 'y' |
|
| 142 | 8x |
ov.names.y <- lav_partable_vnames(partable, "ov.nox", block = b) |
| 143 | 8x |
ov.names.y2 <- unlist(lav_partable_vnames(partable, "ov", |
| 144 | 8x |
block = seq_len(nblocks)[-b] |
| 145 |
)) |
|
| 146 | 8x |
ov.names.y <- ov.names.y[!ov.names.y %in% ov.names.y2] |
| 147 | 8x |
if (length(ov.names.y) > 0L) {
|
| 148 | ! |
pstar <- pstar + length(ov.names.y) |
| 149 |
} |
|
| 150 | ||
| 151 |
# except within-only 'x' (unless fixed.x) |
|
| 152 | 8x |
ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b) |
| 153 | 8x |
ov.names.x2 <- unlist(lav_partable_vnames(partable, "ov", |
| 154 | 8x |
block = seq_len(nblocks)[-b] |
| 155 |
)) |
|
| 156 | 8x |
ov.names.x <- ov.names.x[!ov.names.x %in% ov.names.x2] |
| 157 | 8x |
if (!fixed.x && length(ov.names.x) > 0L) {
|
| 158 | ! |
pstar <- pstar + length(ov.names.x) |
| 159 |
} |
|
| 160 |
} |
|
| 161 |
} |
|
| 162 | ||
| 163 | 154x |
ndat[b] <- pstar |
| 164 | ||
| 165 |
# correction for fixed.x? |
|
| 166 | 154x |
if (!conditional.x && fixed.x) {
|
| 167 | 60x |
ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b) |
| 168 | 60x |
nvar.x <- length(ov.names.x) |
| 169 | 60x |
pstar.x <- nvar.x * (nvar.x + 1) / 2 |
| 170 | 60x |
if (meanstructure) {
|
| 171 | 52x |
if (nlevels > 1L && (b %% nlevels) == 1L) {
|
| 172 |
# do nothing, they are already removed |
|
| 173 |
} else {
|
|
| 174 | 52x |
pstar.x <- pstar.x + nvar.x |
| 175 |
} |
|
| 176 |
} |
|
| 177 | 60x |
ndat[b] <- ndat[b] - pstar.x |
| 178 |
} |
|
| 179 | ||
| 180 |
# composites? |
|
| 181 | 154x |
if (composites) {
|
| 182 | ! |
ov.cind <- lav_partable_vnames(partable, "ov.cind", block = b) |
| 183 | ! |
covar.idx <- which(partable$op == "~~" & |
| 184 | ! |
partable$lhs %in% ov.cind & |
| 185 | ! |
partable$rhs %in% ov.cind & |
| 186 | ! |
partable$free == 0L) |
| 187 | ! |
ndat[b] <- ndat[b] - length(covar.idx) |
| 188 |
} |
|
| 189 | ||
| 190 |
# correction for ordinal data? |
|
| 191 | 154x |
if (categorical) {
|
| 192 | 4x |
ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b) |
| 193 | 4x |
nexo <- length(ov.names.x) |
| 194 | 4x |
ov.ord <- lav_partable_vnames(partable, "ov.ord", block = b) |
| 195 | 4x |
nvar.ord <- length(ov.ord) |
| 196 | 4x |
th <- lav_partable_vnames(partable, "th", block = b) |
| 197 | 4x |
nth <- length(th) |
| 198 |
# no variances |
|
| 199 | 4x |
ndat[b] <- ndat[b] - nvar.ord |
| 200 |
# no means |
|
| 201 | 4x |
ndat[b] <- ndat[b] - nvar.ord |
| 202 |
# but additional thresholds |
|
| 203 | 4x |
ndat[b] <- ndat[b] + nth |
| 204 |
# add slopes |
|
| 205 | 4x |
if (conditional.x) {
|
| 206 | 4x |
ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b) |
| 207 | 4x |
nexo <- length(ov.names.x) |
| 208 | 4x |
ndat[b] <- ndat[b] + (nvar * nexo) |
| 209 |
} |
|
| 210 |
} |
|
| 211 | ||
| 212 |
# correction for correlation not categorical |
|
| 213 | 154x |
if (correlation && !categorical) {
|
| 214 | ! |
ndat[b] <- ndat[b] - nvar |
| 215 |
} |
|
| 216 | ||
| 217 |
# correction for conditional.x not categorical |
|
| 218 | 154x |
if (conditional.x && !categorical) {
|
| 219 | ! |
ov.names.x <- lav_partable_vnames(partable, "ov.x", block = b) |
| 220 | ! |
nexo <- length(ov.names.x) |
| 221 |
# add slopes |
|
| 222 | ! |
ndat[b] <- ndat[b] + (nvar * nexo) |
| 223 |
} |
|
| 224 | ||
| 225 |
# correction for group proportions? |
|
| 226 | 154x |
group.idx <- which(partable$lhs == "group" & |
| 227 | 154x |
partable$op == "%" & |
| 228 | 154x |
partable$block == b) |
| 229 | 154x |
if (length(group.idx) > 0L) {
|
| 230 |
# ndat <- ndat + (length(group.idx) - 1L) # G - 1 (sum to one) |
|
| 231 | ! |
ndat[b] <- ndat[b] + 1L # poisson: each cell a parameter |
| 232 |
} |
|
| 233 |
} # blocks |
|
| 234 | ||
| 235 |
# sum over all blocks |
|
| 236 | 138x |
sum(ndat) |
| 237 |
} |
|
| 238 | ||
| 239 |
# total number of free parameters (ignoring equality constraints) |
|
| 240 |
lav_partable_npar <- function(partable) {
|
|
| 241 |
# we only assume non-zero values |
|
| 242 | 199x |
npar <- length(which(partable$free > 0L)) |
| 243 | 199x |
npar |
| 244 |
} |
|
| 245 | ||
| 246 |
# global degrees of freedom: ndat - npar |
|
| 247 |
# ignoring constraints! (not very useful) |
|
| 248 |
# |
|
| 249 |
# we need to find the rank of con.jac to find the exact amount |
|
| 250 |
# of non-redundant equality constraints (this is done in lav_test.R) |
|
| 251 |
lav_partable_df <- function(partable) {
|
|
| 252 | 138x |
npar <- lav_partable_npar(partable) |
| 253 | 138x |
ndat <- lav_partable_ndat(partable) |
| 254 | ||
| 255 |
# degrees of freedom |
|
| 256 | 138x |
df <- ndat - npar |
| 257 | ||
| 258 | 138x |
as.integer(df) |
| 259 |
} |
|
| 260 | ||
| 261 |
# check order of covariances: we only fill the upper.tri |
|
| 262 |
# therefore, we 'switch' lhs & rhs if they appear in the wrong order |
|
| 263 |
lav_partable_covariance_reorder <- function(partable, # nolint |
|
| 264 |
ov.names = NULL, |
|
| 265 |
lv.names = NULL) {
|
|
| 266 |
# shortcut |
|
| 267 | 79x |
cov.idx <- which(partable$op == "~~" & partable$lhs != partable$rhs) |
| 268 | 79x |
if (length(cov.idx) == 0L) {
|
| 269 |
# nothing to do |
|
| 270 | 58x |
return(partable) |
| 271 |
} |
|
| 272 | ||
| 273 |
# get names |
|
| 274 | 21x |
if (is.null(ov.names)) {
|
| 275 | 21x |
ov.names <- lav_partable_vnames(partable, "ov") |
| 276 |
} else {
|
|
| 277 | ! |
ov.names <- unlist(ov.names) |
| 278 |
} |
|
| 279 | 21x |
if (is.null(lv.names)) {
|
| 280 | 21x |
lv.names <- lav_partable_vnames(partable, "lv") |
| 281 |
# add random slopes (if any) |
|
| 282 | 21x |
if (!is.null(partable$rv) && any(nchar(partable$rv) > 0L)) {
|
| 283 | ! |
rv.names <- unique(partable$rv[nchar(partable$rv) > 0L]) |
| 284 | ! |
lv.names <- c(lv.names, rv.names) |
| 285 |
} |
|
| 286 |
} else {
|
|
| 287 | ! |
lv.names <- unlist(lv.names) |
| 288 |
} |
|
| 289 | 21x |
lv.ov.names <- c(lv.names, ov.names) |
| 290 | ||
| 291 |
# identify wrong ordering |
|
| 292 | 21x |
lhs.idx <- match(partable$lhs[cov.idx], lv.ov.names) |
| 293 | 21x |
rhs.idx <- match(partable$rhs[cov.idx], lv.ov.names) |
| 294 | 21x |
swap.idx <- cov.idx[lhs.idx > rhs.idx] |
| 295 | ||
| 296 | 21x |
if (length(swap.idx) == 0L) {
|
| 297 |
# nothing to do |
|
| 298 | 17x |
return(partable) |
| 299 |
} |
|
| 300 | ||
| 301 |
# swap! |
|
| 302 | 4x |
tmp <- partable$lhs[swap.idx] |
| 303 | 4x |
partable$lhs[swap.idx] <- partable$rhs[swap.idx] |
| 304 | 4x |
partable$rhs[swap.idx] <- tmp |
| 305 | ||
| 306 | 4x |
partable |
| 307 |
} |
|
| 308 | ||
| 309 |
# add a single parameter to an existing parameter table |
|
| 310 |
lav_partable_add <- function(partable = NULL, add = list()) {
|
|
| 311 |
# treat partable as list, not as a data.frame |
|
| 312 | ! |
partable <- as.list(partable) |
| 313 | ||
| 314 |
# number of elements |
|
| 315 | ! |
nel <- length(partable$lhs) |
| 316 | ||
| 317 |
# add copy of last row |
|
| 318 | ! |
for (c in seq_len(length(partable))) {
|
| 319 | ! |
if (is.integer(partable[[c]][[1]])) {
|
| 320 | ! |
if (partable[[c]][nel] == 0L) {
|
| 321 | ! |
partable[[c]][nel + 1] <- 0L |
| 322 | ! |
} else if (partable[[c]][nel] == 1L) {
|
| 323 | ! |
partable[[c]][nel + 1] <- 1L |
| 324 |
} else {
|
|
| 325 | ! |
partable[[c]][nel + 1] <- partable[[c]][nel] + 1L |
| 326 |
} |
|
| 327 | ! |
} else if (is.character(partable[[c]][[1]])) {
|
| 328 | ! |
partable[[c]][nel + 1] <- "" |
| 329 | ! |
} else if (is.numeric(partable[[c]][[1]])) {
|
| 330 | ! |
partable[[c]][nel + 1] <- 0 |
| 331 |
} else {
|
|
| 332 | ! |
partable[[c]][nel + 1] <- partable[[c]][nel] |
| 333 |
} |
|
| 334 | ||
| 335 |
# replace |
|
| 336 | ! |
if (names(partable)[c] %in% names(add)) {
|
| 337 | ! |
partable[[c]][nel + 1] <- add[[names(partable)[c]]] |
| 338 |
} |
|
| 339 |
} |
|
| 340 | ||
| 341 | ! |
partable |
| 342 |
} |
|
| 343 | ||
| 344 | ||
| 345 |
# look for p2-row-idx of p1 elements |
|
| 346 |
# p1 is usually a subset of p2 |
|
| 347 |
# return NA if not found |
|
| 348 |
lav_partable_map_id_p1_in_p2 <- function(p1, p2, stopifnotfound = TRUE, |
|
| 349 |
exclude.nonpar = TRUE) {
|
|
| 350 |
# check if we have a 'block' column (in both p1 and p2) |
|
| 351 | ! |
if (is.null(p1$block)) {
|
| 352 | ! |
if (is.null(p1$group)) {
|
| 353 | ! |
p1$block <- rep.int(1L, length(p1$lhs)) |
| 354 |
} else {
|
|
| 355 | ! |
p1$block <- p1$group |
| 356 |
} |
|
| 357 |
} |
|
| 358 | ! |
if (is.null(p2$block)) {
|
| 359 | ! |
if (is.null(p2$group)) {
|
| 360 | ! |
p2$block <- rep.int(1L, length(p2$lhs)) |
| 361 |
} else {
|
|
| 362 | ! |
p2$block <- p2$group |
| 363 |
} |
|
| 364 |
} |
|
| 365 | ||
| 366 |
# ALL rows from p1, or only 'parameters'? |
|
| 367 | ! |
if (exclude.nonpar) {
|
| 368 |
# get all parameters that have a '.p*' plabel |
|
| 369 |
# (they exclude "==", "<", ">", ":=") |
|
| 370 | ! |
p1.idx <- which(grepl("\\.p", p1$plabel))
|
| 371 |
} else {
|
|
| 372 |
# all of it |
|
| 373 |
# note: block should be '0' in both p1 and p2 |
|
| 374 | ! |
p1.idx <- seq_len(length(p1$lhs)) |
| 375 |
} |
|
| 376 | ! |
np1 <- length(p1.idx) |
| 377 | ||
| 378 |
# return p2.id |
|
| 379 | ! |
p2.id <- integer(np1) |
| 380 | ||
| 381 |
# check every parameter in p1 |
|
| 382 | ! |
for (i in seq_len(np1)) {
|
| 383 |
# identify parameter in p1 |
|
| 384 | ! |
lhs <- p1$lhs[i] |
| 385 | ! |
op <- p1$op[i] |
| 386 | ! |
rhs <- p1$rhs[i] |
| 387 | ! |
block <- p1$block[i] |
| 388 | ||
| 389 |
# search for corresponding parameter in p2 |
|
| 390 | ! |
p2.idx <- which(p2$lhs == lhs & p2$op == op & p2$rhs == rhs & |
| 391 | ! |
p2$block == block) |
| 392 | ||
| 393 |
# found? |
|
| 394 | ! |
if (length(p2.idx) == 0L) {
|
| 395 | ! |
if (stopifnotfound) {
|
| 396 | ! |
lav_msg_stop(gettext("parameter in p1 not found in p2:"),
|
| 397 | ! |
paste(lhs, op, rhs, "(block = ", block, ")", sep = " ") |
| 398 |
) |
|
| 399 |
} else {
|
|
| 400 | ! |
p2.id[i] <- as.integer(NA) |
| 401 |
} |
|
| 402 |
} else {
|
|
| 403 | ! |
p2.id[i] <- p2.idx |
| 404 |
} |
|
| 405 |
} |
|
| 406 | ||
| 407 | ! |
p2.id |
| 408 |
} |
|
| 409 |
lav_partable_da2ovda <- function(partable) {
|
|
| 410 |
# convert handling of ov.order = "data" with "da-operator elements" |
|
| 411 |
# to "ovda attribute" |
|
| 412 | ! |
if (any(partable$op == "da")) {
|
| 413 | ! |
da.idx <- which(partable$op == "da") |
| 414 | ! |
ov.names.data <- partable$lhs[da.idx] |
| 415 | ! |
temp <- lapply(partable, function(x) x[-da.idx]) |
| 416 |
# names(temp) <- names(partable) |
|
| 417 | ! |
attr(temp, "ovda") <- ov.names.data |
| 418 | ! |
return(temp) |
| 419 |
} |
|
| 420 | ! |
return(partable) |
| 421 |
} |
| 1 |
# print object from lavData class |
|
| 2 |
# |
|
| 3 | ||
| 4 |
setMethod( |
|
| 5 |
"show", "lavData", |
|
| 6 |
function(object) {
|
|
| 7 |
# print 'lavData' object |
|
| 8 | ! |
res <- lav_data_summary_short(object) |
| 9 | ! |
lav_data_print_short(res, nd = 3L) |
| 10 |
} |
|
| 11 |
) |
|
| 12 | ||
| 13 |
# create summary information for @lavdata slot |
|
| 14 |
lav_data_summary_short <- function(object) {
|
|
| 15 |
# which object? |
|
| 16 | 21x |
if (inherits(object, "lavaan")) {
|
| 17 |
# check object |
|
| 18 | ! |
object <- lav_object_check_version(object) |
| 19 | ! |
lavdata <- object@Data |
| 20 | 21x |
} else if (inherits(object, "lavData")) {
|
| 21 | 21x |
lavdata <- object |
| 22 |
} else {
|
|
| 23 | ! |
lav_msg_stop(gettext("object must be lavaan or lavData object"))
|
| 24 |
} |
|
| 25 | ||
| 26 |
# two or three columns (depends on nobs/norig) |
|
| 27 | 21x |
threecolumn <- FALSE |
| 28 | 21x |
for (g in 1:lavdata@ngroups) {
|
| 29 | 23x |
if (lavdata@nobs[[g]] != lavdata@norig[[g]]) {
|
| 30 | 7x |
threecolumn <- TRUE |
| 31 | 7x |
break |
| 32 |
} |
|
| 33 |
} |
|
| 34 | ||
| 35 |
# clustered data? |
|
| 36 | 21x |
clustered <- length(lavdata@cluster) > 0L |
| 37 | ||
| 38 |
# multilevel data? |
|
| 39 | 21x |
multilevel <- lavdata@nlevels > 1L |
| 40 | ||
| 41 |
# extract summary information |
|
| 42 | 21x |
datasummary <- list( |
| 43 | 21x |
ngroups = lavdata@ngroups, |
| 44 | 21x |
nobs = unlist(lavdata@nobs) |
| 45 |
) |
|
| 46 | ||
| 47 |
# norig? |
|
| 48 | 21x |
if (threecolumn) {
|
| 49 | 7x |
datasummary$norig <- unlist(lavdata@norig) |
| 50 |
} |
|
| 51 | ||
| 52 |
# multiple groups? |
|
| 53 | 21x |
if (lavdata@ngroups > 1L) {
|
| 54 | 2x |
datasummary$group.label <- lavdata@group.label |
| 55 |
} |
|
| 56 | ||
| 57 |
# sampling weights? |
|
| 58 | 21x |
if (!is.null(lavdata@weights[[1L]])) {
|
| 59 | ! |
datasummary$sampling.weights <- lavdata@sampling.weights |
| 60 |
} |
|
| 61 | ||
| 62 |
# clustered/multilevel data? |
|
| 63 | 21x |
if (clustered) {
|
| 64 | 1x |
if (multilevel) {
|
| 65 | 1x |
datasummary$nlevels <- lavdata@nlevels |
| 66 |
} |
|
| 67 | 1x |
datasummary$cluster <- lavdata@cluster |
| 68 | ||
| 69 | 1x |
if (lavdata@ngroups == 1L) {
|
| 70 | ! |
datasummary$nclusters <- unlist(lavdata@Lp[[1]]$nclusters) |
| 71 |
} else {
|
|
| 72 | 1x |
tmp <- vector("list", length = lavdata@ngroups)
|
| 73 | 1x |
for (g in seq_len(lavdata@ngroups)) {
|
| 74 | 2x |
tmp[[g]] <- unlist(lavdata@Lp[[g]]$nclusters) |
| 75 |
} |
|
| 76 | 1x |
datasummary$nclusters <- tmp |
| 77 |
} |
|
| 78 |
} |
|
| 79 | ||
| 80 |
# missing data? |
|
| 81 | 21x |
if (!is.null(lavdata@Mp[[1L]])) {
|
| 82 | 5x |
datasummary$npatterns <- sapply(lavdata@Mp, "[[", "npatterns") |
| 83 | 5x |
if (multilevel && !is.null(lavdata@Mp[[1L]]$Zp)) {
|
| 84 | ! |
datasummary$npatterns2 <- sapply(lapply( |
| 85 | ! |
lavdata@Mp, |
| 86 | ! |
"[[", "Zp" |
| 87 | ! |
), "[[", "npatterns") |
| 88 |
} |
|
| 89 |
} |
|
| 90 | ||
| 91 | 21x |
datasummary |
| 92 |
} |
|
| 93 | ||
| 94 |
lav_data_print_short <- function(object, nd = 3L) {
|
|
| 95 |
# object should data summary |
|
| 96 | 21x |
if (inherits(object, "lavaan")) {
|
| 97 | ! |
object <- lav_data_summary_short(object) |
| 98 |
} |
|
| 99 | 21x |
datasummary <- object |
| 100 | ||
| 101 | 21x |
num.format <- paste("%", max(8L, nd + 5L), ".", nd, "f", sep = "")
|
| 102 | ||
| 103 |
# threecolumn |
|
| 104 | 21x |
threecolumn <- !is.null(datasummary$norig) |
| 105 | ||
| 106 |
# multilevel? |
|
| 107 | 21x |
multilevel <- !is.null(datasummary$nlevels) |
| 108 | ||
| 109 |
# clustered? |
|
| 110 | 21x |
clustered <- !is.null(datasummary$cluster) && is.null(datasummary$nlevels) |
| 111 | ||
| 112 |
# header? no, for historical reasons only |
|
| 113 |
# cat("Data information:\n\n")
|
|
| 114 | ||
| 115 | 21x |
c1 <- c2 <- c3 <- character(0L) |
| 116 | ||
| 117 |
# number of observations |
|
| 118 | 21x |
if (datasummary$ngroups == 1L) {
|
| 119 | 19x |
if (threecolumn) {
|
| 120 | 7x |
c1 <- c(c1, "") |
| 121 | 7x |
c2 <- c(c2, "Used") |
| 122 | 7x |
c3 <- c(c3, "Total") |
| 123 |
} |
|
| 124 | 19x |
c1 <- c(c1, "Number of observations") |
| 125 | 19x |
c2 <- c(c2, datasummary$nobs) |
| 126 | 19x |
c3 <- c(c3, ifelse(threecolumn, datasummary$norig, "")) |
| 127 |
} else {
|
|
| 128 | 2x |
c1 <- c(c1, "Number of observations per group:") |
| 129 | 2x |
if (threecolumn) {
|
| 130 | ! |
c2 <- c(c2, "Used") |
| 131 | ! |
c3 <- c(c3, "Total") |
| 132 |
} else {
|
|
| 133 | 2x |
c2 <- c(c2, "") |
| 134 | 2x |
c3 <- c(c3, "") |
| 135 |
} |
|
| 136 | 2x |
for (g in 1:datasummary$ngroups) {
|
| 137 | 4x |
c1 <- c(c1, sprintf(" %-40s", datasummary$group.label[g]))
|
| 138 | 4x |
c2 <- c(c2, datasummary$nobs[g]) |
| 139 | 4x |
c3 <- c(c3, ifelse(threecolumn, datasummary$norig[g], "")) |
| 140 |
} # g |
|
| 141 |
} |
|
| 142 | ||
| 143 |
# number of clusters |
|
| 144 | 21x |
if (datasummary$ngroups == 1L) {
|
| 145 | 19x |
if (multilevel) {
|
| 146 | ! |
for (l in 2:datasummary$nlevels) {
|
| 147 | ! |
c1 <- c( |
| 148 | ! |
c1, |
| 149 | ! |
paste("Number of clusters [",
|
| 150 | ! |
datasummary$cluster[l - 1], "]", |
| 151 | ! |
sep = "" |
| 152 |
) |
|
| 153 |
) |
|
| 154 | ! |
c2 <- c(c2, datasummary$nclusters[l]) |
| 155 | ! |
c3 <- c(c3, "") |
| 156 |
} |
|
| 157 | 19x |
} else if (clustered) {
|
| 158 | ! |
c1 <- c(c1, paste("Number of clusters [", datasummary$cluster, "]",
|
| 159 | ! |
sep = "" |
| 160 |
)) |
|
| 161 | ! |
c2 <- c(c2, datasummary$nclusters[2]) |
| 162 | ! |
c3 <- c(c3, "") |
| 163 |
} |
|
| 164 |
} else {
|
|
| 165 | 2x |
if (multilevel) {
|
| 166 | 1x |
for (l in 2:datasummary$nlevels) {
|
| 167 | 1x |
c1 <- c( |
| 168 | 1x |
c1, |
| 169 | 1x |
paste("Number of clusters [", datasummary$cluster[l - 1], "]:",
|
| 170 | 1x |
sep = "" |
| 171 |
) |
|
| 172 |
) |
|
| 173 | 1x |
c2 <- c(c2, "") |
| 174 | 1x |
c3 <- c(c3, "") |
| 175 | 1x |
for (g in 1:datasummary$ngroups) {
|
| 176 | 2x |
c1 <- c(c1, sprintf(" %-40s", datasummary$group.label[g]))
|
| 177 | 2x |
c2 <- c(c2, datasummary$nclusters[[g]][l]) |
| 178 | 2x |
c3 <- c(c3, "") |
| 179 |
} |
|
| 180 |
} |
|
| 181 | 1x |
} else if (clustered) {
|
| 182 | ! |
c1 <- c( |
| 183 | ! |
c1, |
| 184 | ! |
paste("Number of clusters [", datasummary$cluster, "]:", sep = "")
|
| 185 |
) |
|
| 186 | ! |
c2 <- c(c2, "") |
| 187 | ! |
c3 <- c(c3, "") |
| 188 | ! |
for (g in 1:datasummary$ngroups) {
|
| 189 | ! |
c1 <- c(c1, sprintf(" %-40s", datasummary$group.label[g]))
|
| 190 | ! |
c2 <- c(c2, datasummary$nclusters[[g]][2]) |
| 191 | ! |
c3 <- c(c3, "") |
| 192 |
} |
|
| 193 |
} |
|
| 194 |
} |
|
| 195 | ||
| 196 |
# missing patterns? |
|
| 197 | 21x |
if (!is.null(datasummary$npatterns)) {
|
| 198 | 5x |
if (datasummary$ngroups == 1L) {
|
| 199 | 5x |
if (multilevel) {
|
| 200 | ! |
c1 <- c(c1, "Number of missing patterns -- level 1") |
| 201 | ! |
c2 <- c(c2, datasummary$npatterns) |
| 202 | ! |
c3 <- c(c3, "") |
| 203 | ! |
if (!is.null(datasummary$npatterns2)) {
|
| 204 | ! |
c1 <- c(c1, "Number of missing patterns -- level 2") |
| 205 | ! |
c2 <- c(c2, datasummary$npatterns2) |
| 206 | ! |
c3 <- c(c3, "") |
| 207 |
} |
|
| 208 |
} else {
|
|
| 209 | 5x |
c1 <- c(c1, "Number of missing patterns") |
| 210 | 5x |
c2 <- c(c2, datasummary$npatterns) |
| 211 | 5x |
c3 <- c(c3, "") |
| 212 |
} |
|
| 213 |
} else {
|
|
| 214 | ! |
if (multilevel) {
|
| 215 | ! |
c1 <- c(c1, "Number of missing patterns per group:") |
| 216 | ! |
c2 <- c(c2, "") |
| 217 | ! |
c3 <- c(c3, "") |
| 218 | ! |
for (g in 1:datasummary$ngroups) {
|
| 219 | ! |
c1 <- c( |
| 220 | ! |
c1, |
| 221 | ! |
paste(sprintf( |
| 222 | ! |
" %-40s", |
| 223 | ! |
datasummary$group.label[g] |
| 224 | ! |
), "-- level 1") |
| 225 |
) |
|
| 226 | ! |
c2 <- c(c2, datasummary$npatterns[g]) |
| 227 | ! |
c3 <- c(c3, "") |
| 228 | ! |
if (!is.null(datasummary$npatterns2)) {
|
| 229 | ! |
c1 <- c( |
| 230 | ! |
c1, |
| 231 | ! |
paste(sprintf( |
| 232 | ! |
" %-40s", |
| 233 | ! |
datasummary$group.label[g] |
| 234 | ! |
), "-- level 2") |
| 235 |
) |
|
| 236 | ! |
c2 <- c(c2, datasummary$npatterns2[g]) |
| 237 | ! |
c3 <- c(c3, "") |
| 238 |
} |
|
| 239 |
} |
|
| 240 |
} else {
|
|
| 241 | ! |
c1 <- c(c1, "Number of missing patterns per group:") |
| 242 | ! |
c2 <- c(c2, "") |
| 243 | ! |
c3 <- c(c3, "") |
| 244 | ! |
for (g in 1:datasummary$ngroups) {
|
| 245 | ! |
c1 <- c(c1, sprintf(" %-40s", datasummary$group.label[g]))
|
| 246 | ! |
c2 <- c(c2, datasummary$npatterns[g]) |
| 247 | ! |
c3 <- c(c3, "") |
| 248 |
} |
|
| 249 |
} |
|
| 250 |
} |
|
| 251 |
} |
|
| 252 | ||
| 253 |
# sampling weights? |
|
| 254 | 21x |
if (!is.null(datasummary$sampling.weights)) {
|
| 255 | ! |
c1 <- c(c1, "Sampling weights variable") |
| 256 | ! |
c2 <- c(c2, datasummary$sampling.weights) |
| 257 | ! |
c3 <- c(c3, "") |
| 258 |
} |
|
| 259 | ||
| 260 |
# format c1/c2 |
|
| 261 | 21x |
c1 <- format(c1, width = 43L) |
| 262 | 21x |
c2 <- format(c2, width = 8L + max(0, (nd - 3L)) * 4L, justify = "right") |
| 263 | 21x |
c3 <- format(c3, width = 8L + nd, justify = "right") |
| 264 | ||
| 265 |
# create character matrix |
|
| 266 | 21x |
if (threecolumn) {
|
| 267 | 7x |
M <- cbind(c1, c2, c3, deparse.level = 0) |
| 268 |
} else {
|
|
| 269 | 14x |
M <- cbind(c1, c2, deparse.level = 0) |
| 270 |
} |
|
| 271 | 21x |
colnames(M) <- rep("", ncol(M))
|
| 272 | 21x |
rownames(M) <- rep(" ", nrow(M))
|
| 273 | ||
| 274 |
|
|
| 275 | 21x |
write.table(M, row.names = TRUE, col.names = FALSE, quote = FALSE) |
| 276 | ||
| 277 | 21x |
invisible(M) |
| 278 |
} |
| 1 |
# constructor of the matrix lavoptions$representation |
|
| 2 |
# |
|
| 3 |
# initial version: YR 22/11/2010 |
|
| 4 |
# - YR 14 Jan 2014: moved to lav_model.R |
|
| 5 |
# - YR 18 Nov 2014: more efficient handling of linear equality constraints |
|
| 6 |
# - YR 02 Dec 2014: allow for bare-minimum parameter tables |
|
| 7 |
# - YR 25 Jan 2017: collect options in lavoptions |
|
| 8 |
# - YR 12 Mar 2021: add lavpta as argument; create model attributes (ma) |
|
| 9 |
# - YR 21 Jan 2025: add composites |
|
| 10 | ||
| 11 |
# construct MATRIX lavoptions$representation of the model |
|
| 12 |
lav_model <- function(lavpartable = NULL, # nolint |
|
| 13 |
lavoptions = NULL, |
|
| 14 |
th.idx = list()) {
|
|
| 15 |
# handle bare-minimum partables |
|
| 16 | 144x |
lavpartable <- lav_partable_complete(lavpartable) |
| 17 | 144x |
lavpta = lav_partable_attributes(lavpartable) |
| 18 | 144x |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 19 | ||
| 20 |
# global info from user model |
|
| 21 | 144x |
nblocks <- lav_partable_nblocks(lavpartable) |
| 22 | 144x |
ngroups <- lav_partable_ngroups(lavpartable) |
| 23 | 144x |
meanstructure <- any(lavpartable$op == "~1") |
| 24 | 144x |
correlation <- lavoptions$correlation |
| 25 | 144x |
if (is.null(correlation)) {
|
| 26 | ! |
correlation <- FALSE |
| 27 |
} |
|
| 28 | 144x |
composites.option <- lavoptions$composites |
| 29 | 144x |
if (is.null(composites.option)) {
|
| 30 | ! |
composites.option <- TRUE |
| 31 |
} |
|
| 32 | 144x |
composites <- any(lavpartable$op == "<~") && composites.option |
| 33 | 144x |
categorical <- any(lavpartable$op == "|") |
| 34 | 144x |
if (categorical) {
|
| 35 | 4x |
meanstructure <- TRUE |
| 36 | ||
| 37 |
# handle th.idx if length(th.idx) != nblocks |
|
| 38 | 4x |
if (nblocks != length(th.idx)) {
|
| 39 | ! |
th.idx <- rep(th.idx, each = nblocks) |
| 40 |
} |
|
| 41 |
} |
|
| 42 | 144x |
group.w.free <- any(lavpartable$lhs == "group" & lavpartable$op == "%") |
| 43 | 144x |
multilevel <- FALSE |
| 44 | 144x |
if (!is.null(lavpartable$level)) {
|
| 45 | 4x |
nlevels <- lav_partable_nlevels(lavpartable) |
| 46 | 4x |
if (nlevels > 1L) {
|
| 47 | 4x |
multilevel <- TRUE |
| 48 |
} |
|
| 49 |
} else {
|
|
| 50 | 140x |
nlevels <- 1L |
| 51 |
} |
|
| 52 | ||
| 53 | 144x |
nefa <- lav_partable_nefa(lavpartable) |
| 54 | 144x |
if (nefa > 0L) {
|
| 55 | 8x |
efa.values <- lav_partable_efa_values(lavpartable) |
| 56 |
} |
|
| 57 | ||
| 58 |
# check for simple equality constraints |
|
| 59 | 144x |
eq.simple <- any(lavpartable$free > 0L & duplicated(lavpartable$free)) |
| 60 | 144x |
if (eq.simple) {
|
| 61 |
# just like in <0.5-18, add (temporary) 'unco' column |
|
| 62 |
# so we can fill in x.unco.idx |
|
| 63 | ! |
lavpartable$unco <- integer(length(lavpartable$id)) |
| 64 | ! |
idx.free <- which(lavpartable$free > 0L) |
| 65 | ! |
lavpartable$unco[idx.free] <- seq_along(idx.free) |
| 66 |
} |
|
| 67 | ||
| 68 |
# handle variable definitions and (in)equality constraints |
|
| 69 | 144x |
tmp.con <- lav_constraints_parse( |
| 70 | 144x |
partable = lavpartable, |
| 71 | 144x |
constraints = NULL |
| 72 |
) |
|
| 73 | ||
| 74 |
# handle *linear* equality constraints special |
|
| 75 | 144x |
if (tmp.con$ceq.linear.only.flag) {
|
| 76 | 10x |
con.jac <- tmp.con$ceq.JAC |
| 77 | 10x |
con.lambda <- numeric(nrow(tmp.con$ceq.JAC)) |
| 78 | 10x |
attr(con.jac, "inactive.idx") <- integer(0L) |
| 79 | 10x |
attr(con.jac, "ceq.idx") <- seq_len(nrow(tmp.con$ceq.JAC)) |
| 80 |
} else {
|
|
| 81 | 134x |
con.jac <- matrix(0, 0, 0) |
| 82 | 134x |
con.lambda <- numeric(0) |
| 83 |
} |
|
| 84 | ||
| 85 |
# select model matrices |
|
| 86 | 144x |
if (lavoptions$representation == "LISREL") {
|
| 87 | 144x |
tmp.rep <- lav_lisrel(lavpartable, target = NULL, extra = TRUE, |
| 88 | 144x |
allow.composites = composites) |
| 89 | ! |
} else if (lavoptions$representation == "RAM") {
|
| 90 | ! |
tmp.rep <- lav_ram(lavpartable, target = NULL, extra = TRUE) |
| 91 |
} else {
|
|
| 92 | ! |
lav_msg_stop(gettextf( |
| 93 | ! |
"%1$s argument must be either %2$s or %3$s", |
| 94 | ! |
"representation", "LISREL", "RAM")) |
| 95 |
} |
|
| 96 | ! |
if (lav_debug()) print(tmp.rep) |
| 97 | ||
| 98 |
# FIXME: check for non-existing parameters |
|
| 99 | 144x |
bad.idx <- which((tmp.rep$mat == "" | is.na(tmp.rep$row) | is.na(tmp.rep$col)) & |
| 100 | 144x |
!lavpartable$op %in% c("==", "<", ">", ":="))
|
| 101 | ||
| 102 | 144x |
if (length(bad.idx) > 0L) {
|
| 103 | ! |
this.formula <- paste(lavpartable$lhs[bad.idx[1]], |
| 104 | ! |
lavpartable$op[bad.idx[1]], |
| 105 | ! |
lavpartable$rhs[bad.idx[1]], |
| 106 | ! |
sep = " " |
| 107 |
) |
|
| 108 | ! |
if (lavoptions$representation == "LISREL") {
|
| 109 | ! |
lav_msg_stop(gettextf( |
| 110 | ! |
"a model parameter is not defined in the LISREL representation %s. |
| 111 | ! |
Upgrade to latent variables or consider using representation = 'RAM'.", |
| 112 | ! |
this.formula) ) |
| 113 |
} else {
|
|
| 114 | ! |
lav_msg_stop( |
| 115 | ! |
gettextf("parameter is not defined: %s", this.formula)
|
| 116 |
) |
|
| 117 |
} |
|
| 118 |
} |
|
| 119 | ||
| 120 |
# prepare nG-sized slots |
|
| 121 | 144x |
tmp.ng <- sum(unlist(attr(tmp.rep, "mmNumber"))) |
| 122 | 144x |
tmp.glist <- vector(mode = "list", tmp.ng) |
| 123 | 144x |
names(tmp.glist) <- unlist(attr(tmp.rep, "mmNames")) |
| 124 | 144x |
dim.names <- vector(mode = "list", length = tmp.ng) |
| 125 | 144x |
is.symmetric <- logical(tmp.ng) |
| 126 | 144x |
mm.size <- integer(tmp.ng) |
| 127 | ||
| 128 | 144x |
m.free.idx <- m.user.idx <- vector(mode = "list", length = tmp.ng) |
| 129 | 144x |
x.free.idx <- x.unco.idx <- x.user.idx <- vector( |
| 130 | 144x |
mode = "list", |
| 131 | 144x |
length = tmp.ng |
| 132 |
) |
|
| 133 | ||
| 134 |
# prepare nblocks-sized slots |
|
| 135 | 144x |
nvar <- integer(nblocks) |
| 136 | 144x |
nmat <- unlist(attr(tmp.rep, "mmNumber")) |
| 137 | 144x |
num.idx <- vector("list", length = nblocks)
|
| 138 | 144x |
nexo <- integer(nblocks) |
| 139 | 144x |
ov.x.dummy.ov.idx <- vector(mode = "list", length = nblocks) |
| 140 | 144x |
ov.x.dummy.lv.idx <- vector(mode = "list", length = nblocks) |
| 141 | 144x |
ov.y.dummy.ov.idx <- vector(mode = "list", length = nblocks) |
| 142 | 144x |
ov.y.dummy.lv.idx <- vector(mode = "list", length = nblocks) |
| 143 | 144x |
ov.efa.idx <- vector(mode = "list", length = nblocks) |
| 144 | 144x |
lv.efa.idx <- vector(mode = "list", length = nblocks) |
| 145 | ||
| 146 | 144x |
offset <- 0L |
| 147 |
# keep track of ov.names across blocks |
|
| 148 | 144x |
for (g in 1:nblocks) {
|
| 149 |
# observed and latent variables for this block |
|
| 150 | 161x |
ov.names <- lav_partable_vnames(lavpartable, "ov", block = g) |
| 151 | 161x |
ov.names.nox <- lav_partable_vnames(lavpartable, "ov.nox", block = g) |
| 152 | 161x |
ov.names.x <- lav_partable_vnames(lavpartable, "ov.x", block = g) |
| 153 | 161x |
ov.num <- lav_partable_vnames(lavpartable, "ov.num", block = g) |
| 154 | 161x |
if (lavoptions$conditional.x) {
|
| 155 | 4x |
if (nlevels > 1L) {
|
| 156 | ! |
if (ngroups == 1L) {
|
| 157 | ! |
other.block.names <- lav_partable_vnames(lavpartable, "ov", |
| 158 | ! |
block = seq_len(nblocks)[-g] |
| 159 |
) |
|
| 160 |
} else {
|
|
| 161 |
# TEST ME! |
|
| 162 |
# which group is this? |
|
| 163 | ! |
this.group <- ceiling(g / nlevels) |
| 164 | ! |
blocks.within.group <- (this.group - 1L) * nlevels + seq_len(nlevels) |
| 165 | ! |
other.block.names <- lav_partable_vnames(lavpartable, "ov", |
| 166 | ! |
block = blocks.within.group[-g] |
| 167 |
) |
|
| 168 |
} |
|
| 169 | ||
| 170 | ||
| 171 | ! |
if (length(ov.names.x) > 0L) {
|
| 172 | ! |
idx <- which(ov.names.x %in% other.block.names) |
| 173 | ! |
if (length(idx) > 0L) {
|
| 174 | ! |
ov.names.nox <- unique(c(ov.names.nox, ov.names.x[idx])) |
| 175 | ! |
ov.names.x <- ov.names.x[-idx] |
| 176 | ! |
ov.names <- ov.names.nox |
| 177 |
} |
|
| 178 |
} |
|
| 179 |
} |
|
| 180 | 4x |
nvar[g] <- length(ov.names.nox) |
| 181 | 4x |
if (correlation) {
|
| 182 | ! |
num.idx[[g]] <- integer(0L) |
| 183 |
} else {
|
|
| 184 | 4x |
num.idx[[g]] <- which(ov.names.nox %in% ov.num) |
| 185 |
} |
|
| 186 |
} else {
|
|
| 187 | 157x |
nvar[g] <- length(ov.names) |
| 188 | 157x |
if (correlation) {
|
| 189 | ! |
num.idx[[g]] <- integer(0L) |
| 190 |
} else {
|
|
| 191 | 157x |
num.idx[[g]] <- which(ov.names %in% ov.num) |
| 192 |
} |
|
| 193 |
} |
|
| 194 | 161x |
nexo[g] <- length(ov.names.x) |
| 195 | ||
| 196 | 161x |
if (nefa > 0L) {
|
| 197 | 8x |
lv.names <- lav_partable_vnames(lavpartable, "lv", block = g) |
| 198 |
} |
|
| 199 | ||
| 200 |
# model matrices for this block |
|
| 201 | 161x |
mm.number <- attr(tmp.rep, "mmNumber")[[g]] |
| 202 | 161x |
mm.names <- attr(tmp.rep, "mmNames")[[g]] |
| 203 | 161x |
mm.symmetric <- attr(tmp.rep, "mmSymmetric")[[g]] |
| 204 | 161x |
mm.dim.names <- attr(tmp.rep, "mmDimNames")[[g]] |
| 205 | 161x |
mm.rows <- attr(tmp.rep, "mmRows")[[g]] |
| 206 | 161x |
mm.cols <- attr(tmp.rep, "mmCols")[[g]] |
| 207 | ||
| 208 | 161x |
for (mm in 1:mm.number) {
|
| 209 |
# offset in tmp.glist |
|
| 210 | 771x |
offset <- offset + 1L |
| 211 | ||
| 212 |
# matrix size, symmetric, dim.names |
|
| 213 | 771x |
if (mm.symmetric[mm]) {
|
| 214 | 326x |
tmp.n <- mm.rows[mm] |
| 215 | 326x |
mm.size <- as.integer(tmp.n * (tmp.n + 1) / 2) |
| 216 |
} else {
|
|
| 217 | 445x |
mm.size <- as.integer(mm.rows[mm] * mm.cols[mm]) |
| 218 |
} |
|
| 219 | 771x |
mm.size[offset] <- mm.size |
| 220 | 771x |
is.symmetric[offset] <- mm.symmetric[mm] |
| 221 | 771x |
dim.names[[offset]] <- mm.dim.names[[mm]] |
| 222 | ||
| 223 |
# select elements for this matrix |
|
| 224 | 771x |
idx <- which(lavpartable$block == g & tmp.rep$mat == mm.names[mm]) |
| 225 | ||
| 226 |
# create empty `pattern' matrix |
|
| 227 |
# FIXME: one day, we may want to use sparse matrices... |
|
| 228 |
# but they should not slow things down! |
|
| 229 | 771x |
tmp <- matrix(0L, |
| 230 | 771x |
nrow = mm.rows[mm], |
| 231 | 771x |
ncol = mm.cols[mm] |
| 232 |
) |
|
| 233 | ||
| 234 |
# 1. first assign free values only, to get vector index |
|
| 235 |
# -> to be used in lav_model_objective |
|
| 236 | 771x |
tmp[cbind(tmp.rep$row[idx], tmp.rep$col[idx])] <- lavpartable$free[idx] |
| 237 | 771x |
if (mm.symmetric[mm]) {
|
| 238 |
# NOTE: we assume everything is in the UPPER tri! |
|
| 239 | 326x |
tmp.tt <- t(tmp) |
| 240 | 326x |
tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)] |
| 241 |
} |
|
| 242 | 771x |
m.free.idx[[offset]] <- which(tmp > 0) |
| 243 | 771x |
x.free.idx[[offset]] <- tmp[which(tmp > 0)] |
| 244 | ||
| 245 |
# 2. if simple equality constraints, unconstrained free parameters |
|
| 246 |
# -> to be used in lav_model_gradient |
|
| 247 | 771x |
if (eq.simple) {
|
| 248 | ! |
tmp[cbind( |
| 249 | ! |
tmp.rep$row[idx], |
| 250 | ! |
tmp.rep$col[idx] |
| 251 | ! |
)] <- lavpartable$unco[idx] |
| 252 | ! |
if (mm.symmetric[mm]) {
|
| 253 |
# NOTE: we assume everything is in the UPPER tri! |
|
| 254 | ! |
tmp.tt <- t(tmp) |
| 255 | ! |
tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)] |
| 256 |
} |
|
| 257 |
# m.unco.idx[[offset]] <- which(tmp > 0) |
|
| 258 | ! |
x.unco.idx[[offset]] <- tmp[which(tmp > 0)] |
| 259 |
} else {
|
|
| 260 |
# m.unco.idx[[offset]] <- m.free.idx[[offset]] |
|
| 261 | 771x |
x.unco.idx[[offset]] <- x.free.idx[[offset]] |
| 262 |
} |
|
| 263 | ||
| 264 |
# 3. general mapping between user and tmp.glist |
|
| 265 | 771x |
tmp[cbind(tmp.rep$row[idx], tmp.rep$col[idx])] <- lavpartable$id[idx] |
| 266 | 771x |
if (mm.symmetric[mm]) {
|
| 267 | 326x |
tmp.tt <- t(tmp) |
| 268 | 326x |
tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)] |
| 269 |
} |
|
| 270 | 771x |
m.user.idx[[offset]] <- which(tmp > 0) |
| 271 | 771x |
x.user.idx[[offset]] <- tmp[which(tmp > 0)] |
| 272 | ||
| 273 |
# 4. now assign starting/fixed values |
|
| 274 |
# create empty matrix |
|
| 275 |
# FIXME: again, we may want to use sparse matrices here... |
|
| 276 | 771x |
tmp <- matrix(0.0, |
| 277 | 771x |
nrow = mm.rows[mm], |
| 278 | 771x |
ncol = mm.cols[mm] |
| 279 |
) |
|
| 280 | 771x |
tmp[cbind(tmp.rep$row[idx], tmp.rep$col[idx])] <- lavpartable$start[idx] |
| 281 | 771x |
if (mm.symmetric[mm]) {
|
| 282 | 326x |
tmp.tt <- t(tmp) |
| 283 | 326x |
tmp[lower.tri(tmp)] <- tmp.tt[lower.tri(tmp.tt)] |
| 284 |
} |
|
| 285 | ||
| 286 |
# 4b. override with cov.x (if conditional.x = TRUE) |
|
| 287 |
# new in 0.6-1 |
|
| 288 |
# shouldn't be needed, if lavpartable$start contains cov.x values |
|
| 289 |
# if(mm.names[mm] == "cov.x") {
|
|
| 290 |
# tmp <- cov.x[[g]] |
|
| 291 |
# } |
|
| 292 |
# 4c. override with mean.x (if conditional.x = TRUE) |
|
| 293 |
# new in 0.6-1 |
|
| 294 |
# shouldn't be needed, if lavpartable$start contains mean.x values |
|
| 295 |
# if(mm.names[mm] == "mean.x") {
|
|
| 296 |
# tmp <- as.matrix(mean.x[[g]]) |
|
| 297 |
# } |
|
| 298 | ||
| 299 |
# representation specific stuff |
|
| 300 | 771x |
if (lavoptions$representation == "LISREL" && |
| 301 | 771x |
mm.names[mm] == "lambda") {
|
| 302 | 161x |
ov.dummy.names.nox <- attr(tmp.rep, "ov.dummy.names.nox")[[g]] |
| 303 | 161x |
ov.dummy.names.x <- attr(tmp.rep, "ov.dummy.names.x")[[g]] |
| 304 | 161x |
ov.dummy.names <- c(ov.dummy.names.nox, ov.dummy.names.x) |
| 305 |
# define dummy latent variables |
|
| 306 | 161x |
if (length(ov.dummy.names)) {
|
| 307 |
# in this case, lv.names will be extended with the dummys |
|
| 308 | 38x |
tmp.lv.names <- mm.dim.names$psi[[1]] |
| 309 | 38x |
row.tmp.idx <- match(ov.dummy.names, ov.names) |
| 310 | 38x |
col.tmp.idx <- match(ov.dummy.names, tmp.lv.names) |
| 311 |
# Fix lambda values to 1.0 |
|
| 312 | 38x |
tmp[cbind(row.tmp.idx, col.tmp.idx)] <- 1.0 |
| 313 | ||
| 314 | 38x |
ov.x.dummy.ov.idx[[g]] <- match(ov.dummy.names.x, ov.names) |
| 315 | 38x |
ov.x.dummy.lv.idx[[g]] <- match(ov.dummy.names.x, tmp.lv.names) |
| 316 | 38x |
ov.y.dummy.ov.idx[[g]] <- match(ov.dummy.names.nox, ov.names) |
| 317 | 38x |
ov.y.dummy.lv.idx[[g]] <- match(ov.dummy.names.nox, tmp.lv.names) |
| 318 |
} |
|
| 319 |
} |
|
| 320 | ||
| 321 |
# representation specific |
|
| 322 | 771x |
if (lavoptions$representation == "LISREL" && mm.names[mm] == "delta") {
|
| 323 |
# only categorical values are listed in the lavpartable |
|
| 324 |
# but all remaining values should be 1.0 |
|
| 325 | 4x |
idx <- which(tmp[, 1L] == 0.0) |
| 326 | 4x |
tmp[idx, 1L] <- 1.0 |
| 327 |
} |
|
| 328 | ||
| 329 |
# representation specific |
|
| 330 | 771x |
if (lavoptions$representation == "RAM" && mm.names[mm] == "ov.idx") {
|
| 331 | ! |
tmp[1, ] <- attr(tmp.rep, "ov.idx")[[g]] |
| 332 |
} |
|
| 333 | ||
| 334 |
# assign matrix to tmp.glist |
|
| 335 | 771x |
tmp.glist[[offset]] <- tmp |
| 336 |
} # mm |
|
| 337 | ||
| 338 |
# efa related info |
|
| 339 | 161x |
if (nefa > 0L) {
|
| 340 | 8x |
ov.efa.idx[[g]] <- vector("list", length = nefa)
|
| 341 | 8x |
lv.efa.idx[[g]] <- vector("list", length = nefa)
|
| 342 | 8x |
for (set in seq_len(nefa)) {
|
| 343 |
# determine ov idx for this set |
|
| 344 | 8x |
ov.efa <- |
| 345 | 8x |
unique(lavpartable$rhs[lavpartable$op == "=~" & |
| 346 | 8x |
lavpartable$block == g & |
| 347 | 8x |
lavpartable$efa == efa.values[set]]) |
| 348 | 8x |
ov.efa.idx[[g]][[set]] <- match(ov.efa, ov.names) |
| 349 | ||
| 350 | 8x |
lv.efa <- |
| 351 | 8x |
unique(lavpartable$lhs[lavpartable$op == "=~" & |
| 352 | 8x |
lavpartable$block == g & |
| 353 | 8x |
lavpartable$efa == efa.values[set]]) |
| 354 | 8x |
lv.efa.idx[[g]][[set]] <- match(lv.efa, lv.names) |
| 355 |
} |
|
| 356 | 8x |
names(ov.efa.idx[[g]]) <- efa.values |
| 357 | 8x |
names(lv.efa.idx[[g]]) <- efa.values |
| 358 |
} # efa |
|
| 359 | ||
| 360 |
# set variances composites (new in 0.6-20) |
|
| 361 | 161x |
if (composites) {
|
| 362 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0L, nmat))[g] |
| 363 | ! |
tmp.glist[mm.in.group] <- |
| 364 | ! |
lav_lisrel_composites_variances(tmp.glist[mm.in.group]) |
| 365 |
} |
|
| 366 |
} # g |
|
| 367 | ||
| 368 |
# fixed.x parameters? |
|
| 369 |
# fixed.x <- any(lavpartable$exo > 0L & lavpartable$free == 0L) |
|
| 370 |
# if(categorical) {
|
|
| 371 |
# fixed.x <- TRUE |
|
| 372 |
# } |
|
| 373 | ||
| 374 |
# dirty hack to mimic MUML |
|
| 375 | 144x |
if (!is.null(lavoptions$tech.muml.scale)) {
|
| 376 | ! |
lav_msg_warn(gettext("using muml scale in group 2"))
|
| 377 | ||
| 378 |
# find matrix |
|
| 379 | ! |
lambda.idx <- which(names(tmp.glist) == "lambda")[2L] |
| 380 | ||
| 381 |
# find rows/cols |
|
| 382 | ! |
b.names <- paste0("b", ov.names) ## ad-hoc assumption!!!
|
| 383 | ! |
tmp.cols <- match(b.names, tmp.lv.names) |
| 384 | ! |
tmp.rows <- seq_len(nvar[2]) |
| 385 | ! |
stopifnot(length(tmp.cols) == length(tmp.rows)) |
| 386 | ! |
tmp.glist[[lambda.idx]][cbind(tmp.rows, tmp.cols)] <- |
| 387 | ! |
lavoptions$tech.muml.scale |
| 388 |
} |
|
| 389 | ||
| 390 |
# which free parameters are observed variances? |
|
| 391 | 144x |
ov.names <- lav_partable_vnames(lavpartable, "ov") |
| 392 | 144x |
x.free.var.idx <- lavpartable$free[lavpartable$free & |
| 393 |
# !duplicated(lavpartable$free) & |
|
| 394 | 144x |
lavpartable$lhs %in% ov.names & |
| 395 | 144x |
lavpartable$op == "~~" & |
| 396 | 144x |
lavpartable$lhs == lavpartable$rhs] |
| 397 | ||
| 398 | 144x |
rv.lv <- rv.ov <- list() |
| 399 | 144x |
if (multilevel) {
|
| 400 |
# store information about random slopes (if any) |
|
| 401 | 4x |
lv.names <- lav_partable_vnames(lavpartable, "lv") |
| 402 |
# we should also add splitted-y names (x) to lv.names |
|
| 403 |
# FIXME: make this work for multiple work multilevel |
|
| 404 | 4x |
level.values <- lav_partable_level_values(lavpartable) |
| 405 | 4x |
ovx1 <- lav_object_vnames(lavpartable, "ov.x", level = level.values[1]) |
| 406 | 4x |
ovx2 <- lav_object_vnames(lavpartable, "ov.x", level = level.values[2]) |
| 407 | 4x |
ovx12 <- ovx2[ovx2 %in% ovx1] |
| 408 | 4x |
lv.names <- c(lv.names, ovx12) |
| 409 | ||
| 410 |
# RV LV |
|
| 411 | 4x |
rv.idx <- which(nchar(lavpartable$rv) > 0L & |
| 412 | 4x |
lavpartable$level == level.values[1] & |
| 413 | 4x |
lavpartable$rhs %in% lv.names) |
| 414 | 4x |
if (length(rv.idx)) {
|
| 415 | ! |
rv.lv <- lapply(rv.idx, function(x) {
|
| 416 | ! |
c(lavpartable$lhs[x], lavpartable$rhs[x]) |
| 417 |
}) |
|
| 418 | ! |
names(rv.lv) <- lavpartable$rv[rv.idx] |
| 419 |
} |
|
| 420 | ||
| 421 |
# RV OV |
|
| 422 | 4x |
rv.idx <- which(nchar(lavpartable$rv) > 0L & |
| 423 | 4x |
lavpartable$level == level.values[1] & |
| 424 | 4x |
!lavpartable$rhs %in% lv.names) |
| 425 | 4x |
if (length(rv.idx)) {
|
| 426 | ! |
rv.ov <- lapply(rv.idx, function(x) {
|
| 427 | ! |
c(lavpartable$lhs[x], lavpartable$rhs[x]) |
| 428 |
}) |
|
| 429 | ! |
names(rv.ov) <- lavpartable$rv[rv.idx] |
| 430 |
} |
|
| 431 |
} # multilevel |
|
| 432 | ||
| 433 |
# new in 0.6-9: model properties |
|
| 434 | 144x |
modprop <- lav_model_properties( |
| 435 | 144x |
GLIST = tmp.glist, |
| 436 | 144x |
lavpartable = lavpartable, |
| 437 | 144x |
nmat = nmat, |
| 438 | 144x |
m.free.idx = m.free.idx |
| 439 |
) |
|
| 440 | ||
| 441 | 144x |
tmp.model <- new("lavModel",
|
| 442 | 144x |
GLIST = tmp.glist, |
| 443 | 144x |
dimNames = dim.names, |
| 444 | 144x |
isSymmetric = is.symmetric, |
| 445 | 144x |
mmSize = mm.size, |
| 446 | 144x |
representation = lavoptions$representation, |
| 447 | 144x |
modprop = modprop, |
| 448 | 144x |
meanstructure = meanstructure, |
| 449 | 144x |
correlation = correlation, |
| 450 | 144x |
composites = composites, |
| 451 | 144x |
categorical = categorical, |
| 452 | 144x |
multilevel = multilevel, |
| 453 | 144x |
link = lavoptions$link, |
| 454 | 144x |
nblocks = nblocks, |
| 455 | 144x |
ngroups = ngroups, # breaks rsem???? |
| 456 | 144x |
nefa = nefa, |
| 457 | 144x |
group.w.free = group.w.free, |
| 458 | 144x |
nmat = nmat, |
| 459 | 144x |
nvar = nvar, |
| 460 | 144x |
num.idx = num.idx, |
| 461 | 144x |
th.idx = th.idx, |
| 462 | 144x |
nx.free = max(lavpartable$free), |
| 463 | 144x |
nx.unco = if (is.null(lavpartable$unco)) {
|
| 464 | 144x |
max(lavpartable$free) |
| 465 |
} else {
|
|
| 466 | ! |
max(lavpartable$unco) |
| 467 |
}, |
|
| 468 | 144x |
nx.user = max(lavpartable$id), |
| 469 | 144x |
m.free.idx = m.free.idx, |
| 470 | 144x |
x.free.idx = x.free.idx, |
| 471 | 144x |
x.free.var.idx = x.free.var.idx, |
| 472 |
# m.unco.idx=m.unco.idx, |
|
| 473 | 144x |
x.unco.idx = x.unco.idx, |
| 474 | 144x |
m.user.idx = m.user.idx, |
| 475 | 144x |
x.user.idx = x.user.idx, |
| 476 | 144x |
x.def.idx = which(lavpartable$op == ":="), |
| 477 | 144x |
x.ceq.idx = which(lavpartable$op == "=="), |
| 478 | 144x |
x.cin.idx = which(lavpartable$op == ">" | lavpartable$op == "<"), |
| 479 | 144x |
ceq.simple.only = tmp.con$ceq.simple.only, |
| 480 | 144x |
ceq.simple.K = tmp.con$ceq.simple.K, |
| 481 | 144x |
eq.constraints = tmp.con$ceq.linear.only.flag, |
| 482 | 144x |
eq.constraints.K = tmp.con$ceq.JAC.NULL, |
| 483 | 144x |
eq.constraints.k0 = tmp.con$ceq.rhs.NULL, |
| 484 | 144x |
def.function = tmp.con$def.function, |
| 485 | 144x |
ceq.function = tmp.con$ceq.function, |
| 486 | 144x |
ceq.JAC = tmp.con$ceq.JAC, |
| 487 | 144x |
ceq.rhs = tmp.con$ceq.rhs, |
| 488 | 144x |
ceq.jacobian = tmp.con$ceq.jacobian, |
| 489 | 144x |
ceq.linear.idx = tmp.con$ceq.linear.idx, |
| 490 | 144x |
ceq.nonlinear.idx = tmp.con$ceq.nonlinear.idx, |
| 491 | 144x |
cin.simple.only = tmp.con$cin.simple.only, |
| 492 | 144x |
cin.function = tmp.con$cin.function, |
| 493 | 144x |
cin.JAC = tmp.con$cin.JAC, |
| 494 | 144x |
cin.rhs = tmp.con$cin.rhs, |
| 495 | 144x |
cin.jacobian = tmp.con$cin.jacobian, |
| 496 | 144x |
cin.linear.idx = tmp.con$cin.linear.idx, |
| 497 | 144x |
cin.nonlinear.idx = tmp.con$cin.nonlinear.idx, |
| 498 | 144x |
con.jac = con.jac, |
| 499 | 144x |
con.lambda = con.lambda, |
| 500 | 144x |
nexo = nexo, |
| 501 | 144x |
fixed.x = lavoptions$fixed.x, |
| 502 | 144x |
conditional.x = lavoptions$conditional.x, |
| 503 | 144x |
parameterization = lavoptions$parameterization, |
| 504 | 144x |
ov.x.dummy.ov.idx = ov.x.dummy.ov.idx, |
| 505 | 144x |
ov.x.dummy.lv.idx = ov.x.dummy.lv.idx, |
| 506 | 144x |
ov.y.dummy.ov.idx = ov.y.dummy.ov.idx, |
| 507 | 144x |
ov.y.dummy.lv.idx = ov.y.dummy.lv.idx, |
| 508 | 144x |
ov.efa.idx = ov.efa.idx, |
| 509 | 144x |
lv.efa.idx = lv.efa.idx, |
| 510 | 144x |
rv.lv = rv.lv, |
| 511 | 144x |
rv.ov = rv.ov, |
| 512 | 144x |
estimator = lavoptions$estimator, |
| 513 | 144x |
estimator.args = lavoptions$estimator.args |
| 514 |
) |
|
| 515 | ||
| 516 | 144x |
if (lav_debug()) {
|
| 517 | ! |
cat("lavaan debug: lavaanModel\n")
|
| 518 | ! |
print(str(tmp.model)) |
| 519 | ! |
print(tmp.model@GLIST) |
| 520 |
} |
|
| 521 | ||
| 522 | 144x |
tmp.model |
| 523 |
} |
|
| 524 | ||
| 525 |
# for backwards compatibility |
|
| 526 |
# tmp.model <- lav_model |
| 1 |
# utility functions needed for lav_cfa_* |
|
| 2 | ||
| 3 |
# compute THETA and PSI, given lambda using either ULS or GLS |
|
| 4 |
# this function assumes: |
|
| 5 |
# - THETA is diagonal |
|
| 6 |
# - PSI is unrestricted |
|
| 7 |
# - we assume W = S^{-1}
|
|
| 8 |
# |
|
| 9 |
# YR 17 oct 2022: - add lower/upper bounds for theta (only to compute PSI) |
|
| 10 |
# - use 'lambda' correction to ensure PSI is positive definite |
|
| 11 |
# YR 02 feb 2023: - add psi.mapping.ML argument |
|
| 12 |
lav_cfa_lambda2thetapsi <- function(lambda = NULL, S = NULL, S.inv = NULL, |
|
| 13 |
GLS = FALSE, psi.mapping.ML = FALSE, |
|
| 14 |
nobs = 20L) {
|
|
| 15 | ! |
LAMBDA <- as.matrix(lambda) |
| 16 | ! |
nvar <- nrow(LAMBDA) |
| 17 | ! |
nfac <- ncol(LAMBDA) |
| 18 | ||
| 19 | ! |
if (GLS) {
|
| 20 |
# see Browne, 1974 section 4 case II |
|
| 21 | ! |
if (is.null(S.inv)) {
|
| 22 | ! |
W <- solve(S) |
| 23 |
} else {
|
|
| 24 | ! |
W <- S.inv |
| 25 |
} |
|
| 26 | ! |
tLW <- crossprod(LAMBDA, W) |
| 27 | ! |
M <- solve(tLW %*% LAMBDA, tLW) # GLS mapping |
| 28 |
# D <- W %*% LAMBDA %*% M # symmmetric |
|
| 29 | ! |
D <- crossprod(M, tLW) |
| 30 |
# theta <- solve(W*W - D*D, diag(W %*% S %*% W - D %*% S %*% D)) |
|
| 31 | ! |
theta <- try(solve(W * W - D * D, diag(W - D)), # because W == S^{-1}
|
| 32 | ! |
silent = TRUE |
| 33 |
) |
|
| 34 | ! |
if (inherits(theta, "try-error")) {
|
| 35 |
# what to do? |
|
| 36 | ! |
lav_msg_warn(gettext( |
| 37 | ! |
"problem computing THETA values; trying pace algorithm")) |
| 38 | ! |
theta <- lav_efa_pace(S = S, nfactors = nfac, theta.only = TRUE) |
| 39 |
} |
|
| 40 |
} else {
|
|
| 41 |
# see Hagglund 1982, section 4 |
|
| 42 | ! |
M <- solve(crossprod(LAMBDA), t(LAMBDA)) # ULS mapping function |
| 43 | ! |
D <- LAMBDA %*% M |
| 44 | ! |
theta <- try(solve(diag(nvar) - D * D, diag(S - (D %*% S %*% D))), |
| 45 | ! |
silent = TRUE |
| 46 |
) |
|
| 47 | ! |
if (inherits(theta, "try-error")) {
|
| 48 |
# what to do? |
|
| 49 | ! |
lav_msg_warn(gettext( |
| 50 | ! |
"problem computing THETA values; trying pace algorithm")) |
| 51 | ! |
theta <- lav_efa_pace(S = S, nfactors = nfac, theta.only = TRUE) |
| 52 |
} |
|
| 53 |
} |
|
| 54 | ! |
theta.nobounds <- theta |
| 55 | ||
| 56 |
# ALWAYS check bounds for theta (only to to compute PSI)! |
|
| 57 | ! |
theta.bounds <- TRUE |
| 58 | ! |
if (theta.bounds) {
|
| 59 | ! |
diagS <- diag(S) |
| 60 |
# lower bound |
|
| 61 | ! |
lower.bound <- diagS * 0 # * 0.01 |
| 62 | ! |
too.small.idx <- which(theta < lower.bound) |
| 63 | ! |
if (length(too.small.idx) > 0L) {
|
| 64 | ! |
theta[too.small.idx] <- lower.bound[too.small.idx] |
| 65 |
} |
|
| 66 | ||
| 67 |
# upper bound |
|
| 68 | ! |
upper.bound <- diagS * 1 # * 0.99 |
| 69 | ! |
too.large.idx <- which(theta > upper.bound) |
| 70 | ! |
if (length(too.large.idx) > 0L) {
|
| 71 | ! |
theta[too.large.idx] <- upper.bound[too.large.idx] |
| 72 |
} |
|
| 73 |
} |
|
| 74 | ||
| 75 |
# psi |
|
| 76 | ! |
diag.theta <- diag(theta, nvar) |
| 77 | ! |
lambda <- try(lav_matrix_symmetric_diff_smallest_root(S, diag.theta), |
| 78 | ! |
silent = TRUE |
| 79 |
) |
|
| 80 | ! |
if (inherits(lambda, "try-error")) {
|
| 81 | ! |
lav_msg_warn(gettext("failed to compute lambda"))
|
| 82 | ! |
SminTheta <- S - diag.theta # and hope for the best |
| 83 |
} else {
|
|
| 84 | ! |
cutoff <- 1 + 1 / (nobs - 1) |
| 85 | ! |
if (lambda < cutoff) {
|
| 86 | ! |
lambda.star <- lambda - 1 / (nobs - 1) |
| 87 | ! |
SminTheta <- S - lambda.star * diag.theta |
| 88 |
} else {
|
|
| 89 | ! |
SminTheta <- S - diag.theta |
| 90 |
} |
|
| 91 |
} |
|
| 92 | ||
| 93 |
# just like local SAM |
|
| 94 | ! |
if (psi.mapping.ML) {
|
| 95 | ! |
Ti <- 1 / theta |
| 96 | ! |
zero.theta.idx <- which(abs(theta) < 0.01) # be conservative |
| 97 | ! |
if (length(zero.theta.idx) > 0L) {
|
| 98 | ! |
Ti[zero.theta.idx] <- 1 |
| 99 |
} |
|
| 100 | ! |
M <- solve(t(LAMBDA) %*% diag(Ti, nvar) %*% LAMBDA) %*% t(LAMBDA) %*% diag(Ti, nvar) |
| 101 | ! |
PSI <- M %*% SminTheta %*% t(M) # ML |
| 102 |
} else {
|
|
| 103 | ! |
PSI <- M %*% SminTheta %*% t(M) # ULS/GLS |
| 104 |
} |
|
| 105 | ||
| 106 |
# we take care of the bounds later! |
|
| 107 | ! |
list(lambda = LAMBDA, theta = theta.nobounds, psi = PSI) |
| 108 |
} |
|
| 109 | ||
| 110 |
# compute PSI, given lambda and theta using either ULS, GLS, ML |
|
| 111 |
# this function assumes: |
|
| 112 |
# - THETA is diagonal |
|
| 113 |
# - PSI is unrestricted |
|
| 114 |
# |
|
| 115 |
# YR 08 Mar 2023: - first version |
|
| 116 |
lav_cfa_lambdatheta2psi <- function(lambda = NULL, theta = NULL, # vector! |
|
| 117 |
S = NULL, S.inv = NULL, |
|
| 118 |
mapping = "ML", nobs = 20L) {
|
|
| 119 | ! |
LAMBDA <- as.matrix(lambda) |
| 120 | ! |
nvar <- nrow(LAMBDA) |
| 121 | ! |
nfac <- ncol(LAMBDA) |
| 122 | ||
| 123 | ! |
theta.nobounds <- theta |
| 124 | ||
| 125 |
# ALWAYS check bounds for theta to compute PSI |
|
| 126 | ! |
diagS <- diag(S) |
| 127 |
# lower bound |
|
| 128 | ! |
lower.bound <- diagS * 0 # * 0.01 |
| 129 | ! |
too.small.idx <- which(theta < lower.bound) |
| 130 | ! |
if (length(too.small.idx) > 0L) {
|
| 131 | ! |
theta[too.small.idx] <- lower.bound[too.small.idx] |
| 132 |
} |
|
| 133 | ||
| 134 |
# upper bound |
|
| 135 | ! |
upper.bound <- diagS * 1 # * 0.99 |
| 136 | ! |
too.large.idx <- which(theta > upper.bound) |
| 137 | ! |
if (length(too.large.idx) > 0L) {
|
| 138 | ! |
theta[too.large.idx] <- upper.bound[too.large.idx] |
| 139 |
} |
|
| 140 | ||
| 141 |
# psi |
|
| 142 | ! |
diag.theta <- diag(theta, nvar) |
| 143 | ! |
lambda <- try(lav_matrix_symmetric_diff_smallest_root(S, diag.theta), |
| 144 | ! |
silent = TRUE |
| 145 |
) |
|
| 146 | ! |
if (inherits(lambda, "try-error")) {
|
| 147 | ! |
lav_msg_warn(gettext("failed to compute lambda"))
|
| 148 | ! |
SminTheta <- S - diag.theta # and hope for the best |
| 149 |
} else {
|
|
| 150 | ! |
cutoff <- 1 + 1 / (nobs - 1) |
| 151 | ! |
if (lambda < cutoff) {
|
| 152 | ! |
lambda.star <- lambda - 1 / (nobs - 1) |
| 153 | ! |
SminTheta <- S - lambda.star * diag.theta |
| 154 |
} else {
|
|
| 155 | ! |
SminTheta <- S - diag.theta |
| 156 |
} |
|
| 157 |
} |
|
| 158 | ||
| 159 |
# mapping matrix |
|
| 160 | ! |
if (mapping == "ML") {
|
| 161 | ! |
Ti <- 1 / theta |
| 162 | ! |
zero.theta.idx <- which(abs(theta) < 0.01) # be conservative |
| 163 | ! |
if (length(zero.theta.idx) > 0L) {
|
| 164 | ! |
Ti[zero.theta.idx] <- 1 |
| 165 |
} |
|
| 166 | ! |
M <- solve(t(LAMBDA) %*% diag(Ti, nvar) %*% LAMBDA) %*% t(LAMBDA) %*% diag(Ti, nvar) |
| 167 | ! |
} else if (mapping == "GLS") {
|
| 168 | ! |
if (is.null(S.inv)) {
|
| 169 | ! |
S.inv <- try(solve(S), silent = TRUE) |
| 170 |
} |
|
| 171 | ! |
if (inherits(S.inv, "try-error")) {
|
| 172 | ! |
M <- tcrossprod(solve(crossprod(LAMBDA)), LAMBDA) |
| 173 |
} else {
|
|
| 174 | ! |
M <- solve(t(LAMBDA) %*% S.inv %*% LAMBDA) %*% t(LAMBDA) %*% S.inv |
| 175 |
} |
|
| 176 | ! |
} else if (mapping == "ULS") {
|
| 177 | ! |
M <- tcrossprod(solve(crossprod(LAMBDA)), LAMBDA) |
| 178 |
} |
|
| 179 | ||
| 180 |
# compute PSI |
|
| 181 | ! |
PSI <- M %*% SminTheta %*% t(M) |
| 182 | ||
| 183 | ! |
PSI |
| 184 |
} |
|
| 185 | ||
| 186 |
# compute theta elements for a 1-factor model |
|
| 187 |
lav_cfa_theta_spearman <- function(S, bounds = "wide") {
|
|
| 188 | ! |
p <- ncol(S) |
| 189 | ! |
out <- numeric(p) |
| 190 | ! |
R <- cov2cor(S) |
| 191 | ! |
for (p.idx in seq_len(p)) {
|
| 192 | ! |
var.p <- R[p.idx, p.idx] |
| 193 | ! |
x <- R[, p.idx][-p.idx] |
| 194 | ! |
aa <- lav_matrix_vech(tcrossprod(x), diagonal = FALSE) |
| 195 | ! |
ss <- lav_matrix_vech(R[-p.idx, -p.idx, drop = FALSE], diagonal = FALSE) |
| 196 | ! |
h2 <- mean(aa / ss) # communaliteit |
| 197 | ! |
if (bounds == "standard") {
|
| 198 | ! |
h2[h2 < 0] <- 0 |
| 199 | ! |
h2[h2 > 1] <- 1 |
| 200 | ! |
} else if (bounds == "wide") {
|
| 201 | ! |
h2[h2 < -0.05] <- -0.05 # correponds to lower bound ov.var "wide" |
| 202 | ! |
h2[h2 > +1.20] <- +1.20 # correponds to upper bound ov.var "wide" |
| 203 |
} |
|
| 204 | ! |
out[p.idx] <- (1 - h2) * S[p.idx, p.idx] |
| 205 |
} |
|
| 206 | ! |
out |
| 207 |
} |
| 1 |
# user-visible routine to |
|
| 2 |
# compute polychoric/polyserial/... correlations |
|
| 3 |
# |
|
| 4 |
# YR 17 Sept 2013 |
|
| 5 |
# |
|
| 6 |
# - YR 26 Nov 2013: big change - make it a wrapper around lavaan() |
|
| 7 |
# estimator = "none" means two.step (starting values) |
|
| 8 | ||
| 9 |
lav_object_cor <- function(object, |
|
| 10 |
# lav.data options |
|
| 11 |
ordered = NULL, |
|
| 12 |
group = NULL, |
|
| 13 |
missing = "listwise", |
|
| 14 |
ov.names.x = NULL, |
|
| 15 |
sampling.weights = NULL, |
|
| 16 |
# lavaan options |
|
| 17 |
se = "none", |
|
| 18 |
test = "none", |
|
| 19 |
estimator = "two.step", |
|
| 20 |
baseline = FALSE, |
|
| 21 |
# other options (for lavaan) |
|
| 22 |
..., |
|
| 23 |
cor.smooth = FALSE, |
|
| 24 |
cor.smooth.tol = 1e-04, # was 1e-06 in <0.6-14 |
|
| 25 |
output = "cor") {
|
|
| 26 |
# shortcut if object = lavaan object |
|
| 27 | 20x |
if (inherits(object, "lavaan")) {
|
| 28 |
# check object |
|
| 29 | 20x |
object <- lav_object_check_version(object) |
| 30 | 20x |
dotdotdot <- list(...) |
| 31 | 20x |
if (length(dotdotdot) > 0L) {
|
| 32 | ! |
for (j in seq_along(dotdotdot)) {
|
| 33 | ! |
lav_msg_warn(gettextf( |
| 34 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 35 | ! |
"function lav_object_cor for lavaan-object") |
| 36 |
) |
|
| 37 |
} |
|
| 38 |
} |
|
| 39 | 20x |
out <- lav_object_cor_output(object, output = output) |
| 40 | 20x |
return(out) |
| 41 |
} |
|
| 42 | ||
| 43 |
# check estimator |
|
| 44 | ! |
estimator <- tolower(estimator) |
| 45 | ! |
if (estimator %in% c("two.step", "two.stage")) {
|
| 46 | ! |
estimator <- "none" |
| 47 |
} |
|
| 48 | ||
| 49 |
# se? |
|
| 50 | ! |
se <- tolower(se) |
| 51 | ! |
output <- tolower(output) |
| 52 | ! |
if (se != "none") {
|
| 53 | ! |
if (output %in% c("cor", "cov", "sampstat", "th", "thresholds")) {
|
| 54 | ! |
lav_msg_warn(gettext("argument `se' is ignored since standard errors
|
| 55 | ! |
are not needed for the requested `output'")) |
| 56 | ! |
se <- "none" |
| 57 |
} |
|
| 58 |
} |
|
| 59 | ||
| 60 |
# extract sampling.weights.normalization from dots (for lav_lavdata() call) |
|
| 61 | ! |
dots <- list(...) |
| 62 | ! |
sampling.weights.normalization <- "total" |
| 63 | ! |
if (!is.null(dots$sampling.weights.normalization)) {
|
| 64 | ! |
sampling.weights.normalization <- dots$sampling.weights.normalization |
| 65 |
} |
|
| 66 | ||
| 67 | ||
| 68 |
# check object class |
|
| 69 | ! |
if (inherits(object, "lavData")) {
|
| 70 | ! |
lav.data <- object |
| 71 | ! |
} else if (inherits(object, "data.frame") || |
| 72 | ! |
inherits(object, "matrix")) {
|
| 73 | ! |
object <- as.data.frame(object) |
| 74 | ! |
NAMES <- names(object) |
| 75 | ! |
if (!is.null(group)) {
|
| 76 | ! |
NAMES <- NAMES[-match(group, NAMES)] |
| 77 |
} |
|
| 78 | ! |
if (!is.null(sampling.weights)) {
|
| 79 | ! |
NAMES <- NAMES[-match(sampling.weights, NAMES)] |
| 80 |
} |
|
| 81 | ! |
if (is.logical(ordered)) {
|
| 82 | ! |
ordered.flag <- ordered |
| 83 | ! |
if (ordered.flag) {
|
| 84 | ! |
ordered <- NAMES |
| 85 | ! |
if (length(ov.names.x) > 0L) {
|
| 86 | ! |
ordered <- ordered[-which(ordered %in% ov.names.x)] |
| 87 |
} |
|
| 88 |
} else {
|
|
| 89 | ! |
ordered <- character(0L) |
| 90 |
} |
|
| 91 | ! |
} else if (is.null(ordered)) {
|
| 92 | ! |
ordered <- character(0L) |
| 93 | ! |
} else if (!is.character(ordered)) {
|
| 94 | ! |
lav_msg_stop(gettext("ordered argument must be a character vector"))
|
| 95 | ! |
} else if (length(ordered) == 1L && nchar(ordered) == 0L) {
|
| 96 | ! |
ordered <- character(0L) |
| 97 |
} else {
|
|
| 98 |
# check if all names in "ordered" occur in the dataset? |
|
| 99 | ! |
missing.idx <- which(!ordered %in% NAMES) |
| 100 | ! |
if (length(missing.idx) > 0L) {
|
| 101 | ! |
lav_msg_warn(gettextf( |
| 102 | ! |
"ordered variable(s): %s could not be found |
| 103 | ! |
in the data and will be ignored", |
| 104 | ! |
lav_msg_view(ordered[missing.idx]))) |
| 105 |
} |
|
| 106 |
} |
|
| 107 | ! |
lav.data <- lav_lavdata( |
| 108 | ! |
data = object, group = group, |
| 109 | ! |
ov.names = NAMES, ordered = ordered, |
| 110 | ! |
sampling.weights = sampling.weights, |
| 111 | ! |
ov.names.x = ov.names.x, |
| 112 | ! |
lavoptions = list( |
| 113 | ! |
missing = missing, |
| 114 | ! |
sampling.weights.normalization = sampling.weights.normalization |
| 115 |
) |
|
| 116 |
) |
|
| 117 |
} else {
|
|
| 118 | ! |
lav_msg_stop(gettext("lav_object_cor can not handle objects of class"),
|
| 119 | ! |
paste(class(object), collapse = " ") |
| 120 |
) |
|
| 121 |
} |
|
| 122 | ||
| 123 |
# set default estimator if se != "none" |
|
| 124 | ! |
categorical <- any(lav.data@ov$type == "ordered") |
| 125 | ! |
if (se != "none" && estimator == "none") {
|
| 126 | ! |
if (categorical) {
|
| 127 | ! |
estimator <- "WLSMV" |
| 128 |
} else {
|
|
| 129 | ! |
estimator <- "ML" |
| 130 |
} |
|
| 131 |
} |
|
| 132 | ||
| 133 |
# extract more partable options from dots |
|
| 134 | ! |
meanstructure <- FALSE |
| 135 | ! |
fixed.x <- FALSE |
| 136 | ! |
mimic <- "lavaan" |
| 137 | ! |
conditional.x <- FALSE |
| 138 | ! |
if (!is.null(dots$meanstructure)) {
|
| 139 | ! |
meanstructure <- dots$meanstructure |
| 140 |
} |
|
| 141 | ! |
if (lav.data@ngroups > 1L || categorical || tolower(missing) %in% c("ml", "fiml", "direct")) {
|
| 142 | ! |
meanstructure <- TRUE |
| 143 |
} |
|
| 144 | ! |
if (!is.null(dots$fixed.x)) {
|
| 145 | ! |
fixed.x <- dots$fixed.x |
| 146 |
} |
|
| 147 | ! |
if (!is.null(dots$mimic)) {
|
| 148 | ! |
mimic <- dots$mimic |
| 149 |
} |
|
| 150 | ! |
if (!is.null(dots$conditional.x)) {
|
| 151 | ! |
conditional.x <- dots$conditional.x |
| 152 |
} |
|
| 153 | ||
| 154 |
# override, only for backwards compatibility (eg moments() in JWileymisc) |
|
| 155 |
# if(missing %in% c("ml", "fiml")) {
|
|
| 156 |
# meanstructure = TRUE |
|
| 157 |
# } |
|
| 158 | ||
| 159 |
# generate partable for unrestricted model |
|
| 160 | ! |
PT.un <- |
| 161 | ! |
lav_partable_unrestricted( |
| 162 | ! |
lavobject = NULL, |
| 163 | ! |
lavdata = lav.data, |
| 164 | ! |
lavoptions = list( |
| 165 | ! |
meanstructure = meanstructure, |
| 166 | ! |
fixed.x = fixed.x, |
| 167 | ! |
conditional.x = conditional.x, |
| 168 |
# sampling.weights.normalization = sampling.weights.normalization, |
|
| 169 | ! |
group.w.free = FALSE, |
| 170 | ! |
missing = missing, |
| 171 | ! |
estimator = estimator, |
| 172 | ! |
mimic = mimic |
| 173 |
), |
|
| 174 | ! |
sample.cov = NULL, |
| 175 | ! |
sample.mean = NULL, |
| 176 | ! |
sample.th = NULL |
| 177 |
) |
|
| 178 | ||
| 179 | ||
| 180 | ! |
FIT <- lavaan( |
| 181 | ! |
slotParTable = PT.un, slotData = lav.data, |
| 182 | ! |
model.type = "unrestricted", |
| 183 | ! |
missing = missing, |
| 184 | ! |
baseline = baseline, h1 = TRUE, # must be TRUE! |
| 185 | ! |
se = se, test = test, estimator = estimator, ... |
| 186 |
) |
|
| 187 | ||
| 188 | ! |
out <- lav_object_cor_output(FIT, output = output) |
| 189 | ||
| 190 |
# smooth correlation matrix? (only if output = "cor") |
|
| 191 | ! |
if (output == "cor" && cor.smooth) {
|
| 192 | ! |
tmp.attr <- attributes(out) |
| 193 | ! |
out <- cov2cor(lav_matrix_symmetric_force_pd(out, tol = cor.smooth.tol)) |
| 194 |
# we lost most of the attributes |
|
| 195 | ! |
attributes(out) <- tmp.attr |
| 196 |
} |
|
| 197 | ||
| 198 | ! |
out |
| 199 |
} |
|
| 200 |
lavCor <- lav_object_cor # synonym #nolint |
|
| 201 | ||
| 202 |
lav_object_cor_output <- function(object, output = "cor") {
|
|
| 203 |
# check output |
|
| 204 | 20x |
if (output %in% c("cor", "cov")) {
|
| 205 | 20x |
out <- lavInspect(object, "sampstat") |
| 206 | 20x |
if (object@Data@ngroups == 1L) {
|
| 207 | 18x |
if (object@Model@conditional.x) {
|
| 208 | 1x |
out <- out$res.cov |
| 209 |
} else {
|
|
| 210 | 17x |
out <- out$cov |
| 211 |
} |
|
| 212 | 18x |
if (output == "cor") {
|
| 213 | 18x |
out <- cov2cor(out) |
| 214 |
} |
|
| 215 |
} else {
|
|
| 216 | 2x |
if (object@Model@conditional.x) {
|
| 217 | ! |
out <- lapply(out, "[[", "res.cov") |
| 218 |
} else {
|
|
| 219 | 2x |
out <- lapply(out, "[[", "cov") |
| 220 |
} |
|
| 221 | 2x |
if (output == "cor") {
|
| 222 | 2x |
out <- lapply(out, cov2cor) |
| 223 |
} |
|
| 224 |
} |
|
| 225 | ! |
} else if (output %in% c("th", "thresholds")) {
|
| 226 | ! |
out <- lavInspect(object, "sampstat") |
| 227 | ! |
if (object@Data@ngroups == 1L) {
|
| 228 | ! |
if (object@Model@conditional.x) {
|
| 229 | ! |
out <- out$res.th |
| 230 |
} else {
|
|
| 231 | ! |
out <- out$th |
| 232 |
} |
|
| 233 |
} else {
|
|
| 234 | ! |
if (object@Model@conditional.x) {
|
| 235 | ! |
out <- lapply(out, "[[", "res.th") |
| 236 |
} else {
|
|
| 237 | ! |
out <- lapply(out, "[[", "th") |
| 238 |
} |
|
| 239 |
} |
|
| 240 | ! |
} else if (output %in% c("sampstat")) {
|
| 241 | ! |
out <- lavInspect(object, "sampstat") |
| 242 | ! |
} else if (output %in% c( |
| 243 | ! |
"parameterEstimates", "pe", |
| 244 | ! |
"parameterestimates", "est" |
| 245 |
)) {
|
|
| 246 | ! |
out <- standardizedSolution(object) |
| 247 |
} else {
|
|
| 248 | ! |
out <- object |
| 249 |
} |
|
| 250 | ||
| 251 | 20x |
out |
| 252 |
} |
| 1 |
# inspect a lavaanList object |
|
| 2 | ||
| 3 |
lav_lavaanlist_inspect <- function(object, what = "free", ...) {
|
|
| 4 | ! |
dotdotdot <- list(...) |
| 5 | ! |
if (length(dotdotdot) > 0L) {
|
| 6 | ! |
for (j in seq_along(dotdotdot)) {
|
| 7 | ! |
lav_msg_warn(gettextf( |
| 8 | ! |
"Unknown argument %s for %s", sQuote(names(dotdotdot)[j]), |
| 9 | ! |
sQuote("inspect"))
|
| 10 |
) |
|
| 11 |
} |
|
| 12 |
} |
|
| 13 | ! |
lavListInspect( |
| 14 | ! |
object = object, |
| 15 | ! |
what = what, |
| 16 | ! |
add.labels = TRUE, |
| 17 | ! |
add.class = TRUE, |
| 18 | ! |
drop.list.single.group = TRUE |
| 19 |
) |
|
| 20 |
} |
|
| 21 | ||
| 22 |
# the `tech' version: no labels, full matrices, ... for further processing |
|
| 23 |
lav_lavaanlist_lavtech <- function(object, |
|
| 24 |
what = "free", |
|
| 25 |
add.labels = FALSE, |
|
| 26 |
add.class = FALSE, |
|
| 27 |
list.by.group = FALSE, |
|
| 28 |
drop.list.single.group = FALSE) {
|
|
| 29 | ! |
lavListInspect( |
| 30 | ! |
object = object, what = what, |
| 31 | ! |
add.labels = add.labels, add.class = add.class, |
| 32 | ! |
list.by.group = list.by.group, |
| 33 | ! |
drop.list.single.group = drop.list.single.group |
| 34 |
) |
|
| 35 |
} |
|
| 36 | ||
| 37 |
lavListTech <- function(object, |
|
| 38 |
what = "free", |
|
| 39 |
add.labels = FALSE, |
|
| 40 |
add.class = FALSE, |
|
| 41 |
list.by.group = FALSE, |
|
| 42 |
drop.list.single.group = FALSE) {
|
|
| 43 | ! |
lavListInspect( |
| 44 | ! |
object = object, what = what, |
| 45 | ! |
add.labels = add.labels, add.class = add.class, |
| 46 | ! |
list.by.group = list.by.group, |
| 47 | ! |
drop.list.single.group = drop.list.single.group |
| 48 |
) |
|
| 49 |
} |
|
| 50 | ||
| 51 |
# just in case some uses lavInspect on a lavaanList object |
|
| 52 |
lav_lavaanlist_lavinspect <- function(object, |
|
| 53 |
what = "free", |
|
| 54 |
add.labels = TRUE, |
|
| 55 |
add.class = TRUE, |
|
| 56 |
list.by.group = TRUE, |
|
| 57 |
drop.list.single.group = TRUE) {
|
|
| 58 | ! |
lavListInspect( |
| 59 | ! |
object = object, what = what, |
| 60 | ! |
add.labels = add.labels, add.class = add.class, |
| 61 | ! |
list.by.group = list.by.group, |
| 62 | ! |
drop.list.single.group = drop.list.single.group |
| 63 |
) |
|
| 64 |
} |
|
| 65 | ||
| 66 |
lavListInspect <- function(object, |
|
| 67 |
what = "free", |
|
| 68 |
add.labels = TRUE, |
|
| 69 |
add.class = TRUE, |
|
| 70 |
list.by.group = TRUE, |
|
| 71 |
drop.list.single.group = TRUE) {
|
|
| 72 |
# object must inherit from class lavaanList |
|
| 73 | ! |
stopifnot(inherits(object, "lavaanList")) |
| 74 | ||
| 75 |
# only a single argument |
|
| 76 | ! |
if (length(what) > 1) {
|
| 77 | ! |
lav_msg_stop(gettext( |
| 78 | ! |
"`what' arguments contains multiple arguments; only one is allowed")) |
| 79 |
} |
|
| 80 | ||
| 81 |
# be case insensitive |
|
| 82 | ! |
what <- tolower(what) |
| 83 | ||
| 84 | ||
| 85 |
#### model matrices, with different contents #### |
|
| 86 | ! |
if (what == "free") {
|
| 87 | ! |
lav_lavaanlist_inspect_modelmatrices(object, |
| 88 | ! |
what = "free", |
| 89 | ! |
type = "free", add.labels = add.labels, add.class = add.class, |
| 90 | ! |
list.by.group = list.by.group, |
| 91 | ! |
drop.list.single.group = drop.list.single.group |
| 92 |
) |
|
| 93 | ! |
} else if (what == "partable" || what == "user") {
|
| 94 | ! |
lav_lavaanlist_inspect_modelmatrices(object, |
| 95 | ! |
what = "free", |
| 96 | ! |
type = "partable", add.labels = add.labels, add.class = add.class, |
| 97 | ! |
list.by.group = list.by.group, |
| 98 | ! |
drop.list.single.group = drop.list.single.group |
| 99 |
) |
|
| 100 | ! |
} else if (what == "start" || what == "starting.values") {
|
| 101 | ! |
lav_lavaanlist_inspect_modelmatrices(object, |
| 102 | ! |
what = "start", |
| 103 | ! |
add.labels = add.labels, add.class = add.class, |
| 104 | ! |
list.by.group = list.by.group, |
| 105 | ! |
drop.list.single.group = drop.list.single.group |
| 106 |
) |
|
| 107 | ||
| 108 | ||
| 109 |
#### parameter table #### |
|
| 110 | ! |
} else if (what == "list") {
|
| 111 | ! |
parTable(object) |
| 112 | ||
| 113 |
#### data + missingness #### |
|
| 114 | ! |
} else if (what == "ngroups") {
|
| 115 | ! |
object@Data@ngroups |
| 116 | ! |
} else if (what == "group") {
|
| 117 | ! |
object@Data@group |
| 118 | ! |
} else if (what == "cluster") {
|
| 119 | ! |
object@Data@cluster |
| 120 | ! |
} else if (what == "nlevels") {
|
| 121 | ! |
object@Data@nlevels |
| 122 | ! |
} else if (what == "nclusters") {
|
| 123 | ! |
lav_object_inspect_cluster_info(object, |
| 124 | ! |
level = 2L, |
| 125 | ! |
what = "nclusters", |
| 126 | ! |
drop.list.single.group = drop.list.single.group |
| 127 |
) |
|
| 128 | ! |
} else if (what == "ncluster.size") {
|
| 129 | ! |
lav_object_inspect_cluster_info(object, |
| 130 | ! |
level = 2L, |
| 131 | ! |
what = "ncluster.size", |
| 132 | ! |
drop.list.single.group = drop.list.single.group |
| 133 |
) |
|
| 134 | ! |
} else if (what == "cluster.size") {
|
| 135 | ! |
lav_object_inspect_cluster_info(object, |
| 136 | ! |
level = 2L, |
| 137 | ! |
what = "cluster.size", |
| 138 | ! |
drop.list.single.group = drop.list.single.group |
| 139 |
) |
|
| 140 | ! |
} else if (what == "cluster.id") {
|
| 141 | ! |
lav_object_inspect_cluster_info(object, |
| 142 | ! |
level = 2L, |
| 143 | ! |
what = "cluster.id", |
| 144 | ! |
drop.list.single.group = drop.list.single.group |
| 145 |
) |
|
| 146 | ! |
} else if (what == "cluster.idx") {
|
| 147 | ! |
lav_object_inspect_cluster_info(object, |
| 148 | ! |
level = 2L, |
| 149 | ! |
what = "cluster.idx", |
| 150 | ! |
drop.list.single.group = drop.list.single.group |
| 151 |
) |
|
| 152 | ! |
} else if (what == "cluster.label") {
|
| 153 | ! |
lav_object_inspect_cluster_info(object, |
| 154 | ! |
level = 2L, |
| 155 | ! |
what = "cluster.label", |
| 156 | ! |
drop.list.single.group = drop.list.single.group |
| 157 |
) |
|
| 158 | ! |
} else if (what == "cluster.sizes") {
|
| 159 | ! |
lav_object_inspect_cluster_info(object, |
| 160 | ! |
level = 2L, |
| 161 | ! |
what = "cluster.sizes", |
| 162 | ! |
drop.list.single.group = drop.list.single.group |
| 163 |
) |
|
| 164 | ! |
} else if (what == "average.cluster.size") {
|
| 165 | ! |
lav_object_inspect_cluster_info(object, |
| 166 | ! |
level = 2L, |
| 167 | ! |
what = "average.cluster.size", |
| 168 | ! |
drop.list.single.group = drop.list.single.group |
| 169 |
) |
|
| 170 | ! |
} else if (what == "ordered") {
|
| 171 | ! |
object@Data@ordered |
| 172 | ! |
} else if (what == "group.label") {
|
| 173 | ! |
object@Data@group.label |
| 174 | ! |
} else if (what == "level.label") {
|
| 175 | ! |
object@Data@level.label |
| 176 | ! |
} else if (what == "nobs") { # only for original!
|
| 177 | ! |
unlist(object@Data@nobs) |
| 178 | ! |
} else if (what == "norig") { # only for original!
|
| 179 | ! |
unlist(object@Data@norig) |
| 180 | ! |
} else if (what == "ntotal") { # only for original!
|
| 181 | ! |
sum(unlist(object@Data@nobs)) |
| 182 | ||
| 183 |
#### from the model object (but stable) over datasets? #### |
|
| 184 | ! |
} else if (what == "th.idx") {
|
| 185 | ! |
lav_lavaanlist_inspect_th_idx(object, |
| 186 | ! |
add.labels = add.labels, add.class = add.class, |
| 187 | ! |
drop.list.single.group = drop.list.single.group |
| 188 |
) |
|
| 189 | ||
| 190 | ||
| 191 |
#### meanstructure, categorical #### |
|
| 192 | ! |
} else if (what == "meanstructure") {
|
| 193 | ! |
object@Model@meanstructure |
| 194 | ! |
} else if (what == "categorical") {
|
| 195 | ! |
object@Model@categorical |
| 196 | ! |
} else if (what == "fixed.x") {
|
| 197 | ! |
object@Model@fixed.x |
| 198 | ! |
} else if (what == "parameterization") {
|
| 199 | ! |
object@Model@parameterization |
| 200 | ||
| 201 |
# options |
|
| 202 | ! |
} else if (what == "options" || what == "lavoptions") {
|
| 203 | ! |
object@Options |
| 204 | ||
| 205 |
# call |
|
| 206 | ! |
} else if (what == "call") {
|
| 207 | ! |
as.list(object@call) |
| 208 | ||
| 209 |
#### not found #### |
|
| 210 |
} else {
|
|
| 211 | ! |
lav_msg_stop(gettextf( |
| 212 | ! |
"unknown `what' argument in inspect function: `%s'", what)) |
| 213 |
} |
|
| 214 |
} |
|
| 215 | ||
| 216 | ||
| 217 |
lav_lavaanlist_inspect_start <- function(object) {
|
|
| 218 |
# from 0.5-19, they are in the partable |
|
| 219 | ! |
if (!is.null(object@ParTable$start)) {
|
| 220 | ! |
OUT <- object@ParTable$start |
| 221 |
} else {
|
|
| 222 |
# in < 0.5-19, we should look in @Fit@start |
|
| 223 | ! |
OUT <- object@Fit@start |
| 224 |
} |
|
| 225 | ||
| 226 | ! |
OUT |
| 227 |
} |
|
| 228 | ||
| 229 |
lav_lavaanlist_inspect_modelmatrices <- function( |
|
| 230 |
object, what = "free", |
|
| 231 |
type = "free", add.labels = FALSE, add.class = FALSE, |
|
| 232 |
list.by.group = FALSE, |
|
| 233 |
drop.list.single.group = FALSE) {
|
|
| 234 | ! |
GLIST <- object@Model@GLIST |
| 235 | ||
| 236 | ! |
for (mm in 1:length(GLIST)) {
|
| 237 | ! |
if (add.labels) {
|
| 238 | ! |
dimnames(GLIST[[mm]]) <- object@Model@dimNames[[mm]] |
| 239 |
} |
|
| 240 | ||
| 241 | ! |
if (what == "free") {
|
| 242 |
# fill in free parameter counts |
|
| 243 | ! |
if (type == "free") {
|
| 244 | ! |
m.el.idx <- object@Model@m.free.idx[[mm]] |
| 245 | ! |
x.el.idx <- object@Model@x.free.idx[[mm]] |
| 246 |
# } else if(type == "unco") {
|
|
| 247 |
# m.el.idx <- object@Model@m.unco.idx[[mm]] |
|
| 248 |
# x.el.idx <- object@Model@x.unco.idx[[mm]] |
|
| 249 | ! |
} else if (type == "partable") {
|
| 250 | ! |
m.el.idx <- object@Model@m.user.idx[[mm]] |
| 251 | ! |
x.el.idx <- object@Model@x.user.idx[[mm]] |
| 252 |
} else {
|
|
| 253 | ! |
lav_msg_stop(gettextf("unknown type argument: %s", type))
|
| 254 |
} |
|
| 255 |
# erase everything |
|
| 256 | ! |
GLIST[[mm]][, ] <- 0.0 |
| 257 | ! |
GLIST[[mm]][m.el.idx] <- x.el.idx |
| 258 | ! |
} else if (what == "start") {
|
| 259 |
# fill in starting values |
|
| 260 | ! |
m.user.idx <- object@Model@m.user.idx[[mm]] |
| 261 | ! |
x.user.idx <- object@Model@x.user.idx[[mm]] |
| 262 | ! |
START <- lav_lavaanlist_inspect_start(object) |
| 263 | ! |
GLIST[[mm]][m.user.idx] <- START[x.user.idx] |
| 264 |
} |
|
| 265 | ||
| 266 |
# class |
|
| 267 | ! |
if (add.class) {
|
| 268 | ! |
if (object@Model@isSymmetric[mm]) {
|
| 269 | ! |
class(GLIST[[mm]]) <- c("lavaan.matrix.symmetric", "matrix")
|
| 270 |
} else {
|
|
| 271 | ! |
class(GLIST[[mm]]) <- c("lavaan.matrix", "matrix")
|
| 272 |
} |
|
| 273 |
} |
|
| 274 |
} |
|
| 275 | ||
| 276 |
# try to reflect `equality constraints' |
|
| 277 | ! |
con.flag <- FALSE |
| 278 | ! |
if (what == "free" && object@Model@eq.constraints) {
|
| 279 |
# extract constraints from parameter table |
|
| 280 | ! |
PT <- parTable(object) |
| 281 | ! |
CON <- PT[PT$op %in% c("==", "<", ">"), c("lhs", "op", "rhs")]
|
| 282 | ! |
rownames(CON) <- NULL |
| 283 | ||
| 284 |
# replace 'labels' by parameter numbers |
|
| 285 | ! |
ID <- lav_partable_constraints_label_id(PT) |
| 286 | ! |
LABEL <- names(ID) |
| 287 | ! |
for (con in 1:nrow(CON)) {
|
| 288 |
# lhs |
|
| 289 | ! |
LHS.labels <- all.vars(as.formula(paste("~", CON[con, "lhs"])))
|
| 290 | ||
| 291 | ! |
if (length(LHS.labels) > 0L) {
|
| 292 |
# par id |
|
| 293 | ! |
LHS.freeid <- ID[match(LHS.labels, LABEL)] |
| 294 | ||
| 295 |
# substitute |
|
| 296 | ! |
tmp <- CON[con, "lhs"] |
| 297 | ! |
for (pat in 1:length(LHS.labels)) {
|
| 298 | ! |
tmp <- sub(LHS.labels[pat], LHS.freeid[pat], tmp) |
| 299 |
} |
|
| 300 | ! |
CON[con, "lhs"] <- tmp |
| 301 |
} |
|
| 302 | ||
| 303 |
# rhs |
|
| 304 | ! |
RHS.labels <- all.vars(as.formula(paste("~", CON[con, "rhs"])))
|
| 305 | ||
| 306 | ! |
if (length(RHS.labels) > 0L) {
|
| 307 |
# par id |
|
| 308 | ! |
RHS.freeid <- ID[match(RHS.labels, LABEL)] |
| 309 |
# substitute |
|
| 310 | ! |
tmp <- CON[con, "rhs"] |
| 311 | ! |
for (pat in 1:length(RHS.labels)) {
|
| 312 | ! |
tmp <- sub(RHS.labels[pat], RHS.freeid[pat], tmp) |
| 313 |
} |
|
| 314 | ! |
CON[con, "rhs"] <- tmp |
| 315 |
} |
|
| 316 |
} # con |
|
| 317 | ||
| 318 |
# add this info at the top |
|
| 319 |
# GLIST <- c(constraints = list(CON), GLIST) |
|
| 320 |
# no, not a good idea, it does not work with list.by.group |
|
| 321 | ||
| 322 |
# add it as a 'header' attribute? |
|
| 323 | ! |
attr(CON, "header") <- "Note: model contains equality constraints:" |
| 324 | ! |
con.flag <- TRUE |
| 325 |
} |
|
| 326 | ||
| 327 |
# should we group them per group? |
|
| 328 | ! |
if (list.by.group) {
|
| 329 | ! |
lavmodel <- object@Model |
| 330 | ! |
nmat <- lavmodel@nmat |
| 331 | ||
| 332 | ! |
OUT <- vector("list", length = object@Data@ngroups)
|
| 333 | ! |
for (g in 1:object@Data@ngroups) {
|
| 334 |
# which mm belong to group g? |
|
| 335 | ! |
mm.in.group <- 1:nmat[g] + cumsum(c(0, nmat))[g] |
| 336 | ! |
mm.names <- names(GLIST[mm.in.group]) |
| 337 | ||
| 338 | ! |
OUT[[g]] <- GLIST[mm.in.group] |
| 339 |
} |
|
| 340 | ||
| 341 | ! |
if (object@Data@ngroups == 1L && drop.list.single.group) {
|
| 342 | ! |
OUT <- OUT[[1]] |
| 343 |
} else {
|
|
| 344 | ! |
if (length(object@Data@group.label) > 0L) {
|
| 345 | ! |
names(OUT) <- unlist(object@Data@group.label) |
| 346 |
} |
|
| 347 |
} |
|
| 348 |
} else {
|
|
| 349 | ! |
OUT <- GLIST |
| 350 |
} |
|
| 351 | ||
| 352 |
# header |
|
| 353 | ! |
if (con.flag) {
|
| 354 | ! |
attr(OUT, "header") <- CON |
| 355 |
} |
|
| 356 | ||
| 357 |
# lavaan.list |
|
| 358 | ! |
if (add.class) {
|
| 359 | ! |
class(OUT) <- c("lavaan.list", "list")
|
| 360 |
} |
|
| 361 | ||
| 362 | ! |
OUT |
| 363 |
} |
|
| 364 | ||
| 365 |
lav_lavaanlist_inspect_th_idx <- function( |
|
| 366 |
object, |
|
| 367 |
add.labels = FALSE, add.class = FALSE, drop.list.single.group = FALSE) {
|
|
| 368 |
# thresholds idx -- usually, we get it from SampleStats |
|
| 369 |
# but fortunately, there is a copy in Model, but no names... |
|
| 370 | ! |
OUT <- object@Model@th.idx |
| 371 | ||
| 372 |
# nblocks |
|
| 373 | ! |
nblocks <- length(OUT) |
| 374 | ||
| 375 |
# labels + class |
|
| 376 | ! |
for (b in seq_len(nblocks)) {
|
| 377 |
# if(add.labels && length(OUT[[b]]) > 0L) {
|
|
| 378 |
# names(OUT[[b]]) <- object@SampleStats@th.names[[b]] |
|
| 379 |
# } |
|
| 380 | ! |
if (add.class && !is.null(OUT[[b]])) {
|
| 381 | ! |
class(OUT[[b]]) <- c("lavaan.vector", "numeric")
|
| 382 |
} |
|
| 383 |
} |
|
| 384 | ||
| 385 | ! |
if (nblocks == 1L && drop.list.single.group) {
|
| 386 | ! |
OUT <- OUT[[1]] |
| 387 |
} else {
|
|
| 388 | ! |
if (object@Data@nlevels == 1L && |
| 389 | ! |
length(object@Data@group.label) > 0L) {
|
| 390 | ! |
names(OUT) <- unlist(object@Data@group.label) |
| 391 | ! |
} else if (object@Data@nlevels > 1L && |
| 392 | ! |
length(object@Data@group.label) == 0L) {
|
| 393 | ! |
names(OUT) <- object@Data@level.label |
| 394 |
} |
|
| 395 |
} |
|
| 396 | ||
| 397 | ! |
OUT |
| 398 |
} |
| 1 |
# generate lavaan model syntax from a list of model matrices |
|
| 2 |
# |
|
| 3 |
# YR -- 4 Dec 2021 |
|
| 4 |
# |
|
| 5 |
# - currently for a single group/level only |
|
| 6 |
# - continuous setting only; the model matrices are LAMBDA, PSI, THETA and |
|
| 7 |
# optionally BETA |
|
| 8 |
# |
|
| 9 |
# we return a single string |
|
| 10 | ||
| 11 |
lav_syntax_mlist <- function(MLIST, ov.prefix = "y", lv.prefix = "f", |
|
| 12 |
include.values = TRUE) {
|
|
| 13 |
# model matrices |
|
| 14 | ! |
LAMBDA <- MLIST$lambda |
| 15 | ! |
THETA <- MLIST$theta |
| 16 | ! |
PSI <- MLIST$psi |
| 17 | ! |
BETA <- MLIST$beta |
| 18 | ||
| 19 |
# check prefix |
|
| 20 | ! |
if (ov.prefix == lv.prefix) {
|
| 21 | ! |
lav_msg_stop(gettext("ov.prefix can not be the same as lv.prefix"))
|
| 22 |
} |
|
| 23 | ||
| 24 | ! |
header <- "# syntax generated by lav_syntax_mlist()" |
| 25 | ||
| 26 |
# LAMBDA |
|
| 27 | ! |
if (!is.null(LAMBDA)) {
|
| 28 | ! |
IDXV <- row(LAMBDA)[(LAMBDA != 0)] |
| 29 | ! |
IDXF <- col(LAMBDA)[(LAMBDA != 0)] |
| 30 |
# lambda.txt <- character(nfactors) |
|
| 31 |
# for(f in seq_len(nfactors)) {
|
|
| 32 |
# var.idx <- which(LAMBDA[,f] != 0.0) |
|
| 33 |
# lambda.vals <- LAMBDA[var.idx, f] |
|
| 34 |
# lambda.txt[f] <- paste( paste0(lv.prefix, f), "=~", |
|
| 35 |
# paste(lambda.vals, "*", |
|
| 36 |
# paste0(ov.prefix, var.idx), |
|
| 37 |
# sep = "", collapse = " + ") ) |
|
| 38 |
# } |
|
| 39 | ! |
nel <- length(IDXF) |
| 40 | ! |
lambda.txt <- character(nel) |
| 41 | ! |
for (i in seq_len(nel)) {
|
| 42 | ! |
if (include.values) {
|
| 43 | ! |
lambda.txt[i] <- paste0( |
| 44 | ! |
paste0(lv.prefix, IDXF[i]), " =~ ", |
| 45 | ! |
LAMBDA[IDXV[i], IDXF[i]], "*", |
| 46 | ! |
paste0(ov.prefix, IDXV[i]) |
| 47 |
) |
|
| 48 |
} else {
|
|
| 49 | ! |
lambda.txt[i] <- paste0( |
| 50 | ! |
paste0(lv.prefix, IDXF[i]), " =~ ", |
| 51 | ! |
paste0(ov.prefix, IDXV[i]) |
| 52 |
) |
|
| 53 |
} |
|
| 54 |
} |
|
| 55 |
} else {
|
|
| 56 | ! |
lambda.txt <- character(0L) |
| 57 |
} |
|
| 58 | ||
| 59 |
# THETA |
|
| 60 | ! |
if (!is.null(THETA)) {
|
| 61 | ! |
IDX1 <- row(THETA)[(THETA != 0) & upper.tri(THETA, diag = TRUE)] |
| 62 | ! |
IDX2 <- col(THETA)[(THETA != 0) & upper.tri(THETA, diag = TRUE)] |
| 63 | ! |
nel <- length(IDX1) |
| 64 | ! |
theta.txt <- character(nel) |
| 65 | ! |
for (i in seq_len(nel)) {
|
| 66 | ! |
if (include.values) {
|
| 67 | ! |
theta.txt[i] <- paste0( |
| 68 | ! |
paste0(ov.prefix, IDX1[i]), " ~~ ", |
| 69 | ! |
THETA[IDX1[i], IDX2[i]], "*", |
| 70 | ! |
paste0(ov.prefix, IDX2[i]) |
| 71 |
) |
|
| 72 |
} else {
|
|
| 73 | ! |
theta.txt[i] <- paste0( |
| 74 | ! |
paste0(ov.prefix, IDX1[i]), " ~~ ", |
| 75 | ! |
paste0(ov.prefix, IDX2[i]) |
| 76 |
) |
|
| 77 |
} |
|
| 78 |
} |
|
| 79 |
} else {
|
|
| 80 | ! |
theta.txt <- character(0L) |
| 81 |
} |
|
| 82 | ||
| 83 |
# PSI |
|
| 84 | ! |
if (!is.null(PSI)) {
|
| 85 | ! |
IDX1 <- row(PSI)[(PSI != 0) & upper.tri(PSI, diag = TRUE)] |
| 86 | ! |
IDX2 <- col(PSI)[(PSI != 0) & upper.tri(PSI, diag = TRUE)] |
| 87 | ! |
nel <- length(IDX1) |
| 88 | ! |
psi.txt <- character(nel) |
| 89 | ! |
for (i in seq_len(nel)) {
|
| 90 | ! |
if (include.values) {
|
| 91 | ! |
psi.txt[i] <- paste0( |
| 92 | ! |
paste0(lv.prefix, IDX1[i]), " ~~ ", |
| 93 | ! |
PSI[IDX1[i], IDX2[i]], "*", |
| 94 | ! |
paste0(lv.prefix, IDX2[i]) |
| 95 |
) |
|
| 96 |
} else {
|
|
| 97 | ! |
psi.txt[i] <- paste0( |
| 98 | ! |
paste0(lv.prefix, IDX1[i]), " ~~ ", |
| 99 | ! |
paste0(lv.prefix, IDX2[i]) |
| 100 |
) |
|
| 101 |
} |
|
| 102 |
} |
|
| 103 |
} else {
|
|
| 104 | ! |
psi.txt <- character(0L) |
| 105 |
} |
|
| 106 | ||
| 107 |
# BETA |
|
| 108 | ! |
if (!is.null(BETA)) {
|
| 109 | ! |
IDX1 <- row(BETA)[(BETA != 0)] |
| 110 | ! |
IDX2 <- col(BETA)[(BETA != 0)] |
| 111 | ! |
nel <- length(IDX1) |
| 112 | ! |
beta.txt <- character(nel) |
| 113 | ! |
for (i in seq_len(nel)) {
|
| 114 | ! |
if (include.values) {
|
| 115 | ! |
beta.txt[i] <- paste0( |
| 116 | ! |
paste0(lv.prefix, IDX1[i]), " ~ ", |
| 117 | ! |
BETA[IDX1[i], IDX2[i]], "*", |
| 118 | ! |
paste0(lv.prefix, IDX2[i]) |
| 119 |
) |
|
| 120 |
} else {
|
|
| 121 | ! |
beta.txt[i] <- paste0( |
| 122 | ! |
paste0(lv.prefix, IDX1[i]), " ~ ", |
| 123 | ! |
paste0(lv.prefix, IDX2[i]) |
| 124 |
) |
|
| 125 |
} |
|
| 126 |
} |
|
| 127 |
} else {
|
|
| 128 | ! |
beta.txt <- character(0L) |
| 129 |
} |
|
| 130 | ||
| 131 |
# assemble |
|
| 132 | ! |
syntax <- paste(c(header, lambda.txt, theta.txt, psi.txt, beta.txt, ""), |
| 133 | ! |
collapse = "\n" |
| 134 |
) |
|
| 135 | ||
| 136 | ! |
syntax |
| 137 |
} |
| 1 |
# deprecated: only kept in order to avoid some older packages |
|
| 2 |
lav_model_fit <- function(lavpartable = NULL, |
|
| 3 |
lavmodel = NULL, |
|
| 4 |
lavimplied = NULL, |
|
| 5 |
x = NULL, |
|
| 6 |
VCOV = NULL, |
|
| 7 |
TEST = NULL) {
|
|
| 8 | 140x |
stopifnot(is.list(lavpartable), inherits(lavmodel, "lavModel")) |
| 9 | ||
| 10 |
# extract information from 'x' |
|
| 11 | 140x |
iterations <- attr(x, "iterations") |
| 12 | 140x |
converged <- attr(x, "converged") |
| 13 | 140x |
fx <- attr(x, "fx") |
| 14 | 140x |
fx.group <- attr(fx, "fx.group") |
| 15 | 140x |
if (!is.null(attr(fx, "logl.group"))) {
|
| 16 | ! |
logl.group <- attr(fx, "logl.group") |
| 17 | ! |
logl <- sum(logl.group) |
| 18 |
} else {
|
|
| 19 | 140x |
logl.group <- as.numeric(NA) |
| 20 | 140x |
logl <- as.numeric(NA) |
| 21 |
} |
|
| 22 |
# print(fx.group) |
|
| 23 | 140x |
control <- attr(x, "control") |
| 24 | 140x |
attributes(fx) <- NULL |
| 25 | 140x |
x.copy <- x # we are going to change it (remove attributes) |
| 26 | 140x |
attributes(x.copy) <- NULL |
| 27 | 140x |
est <- lav_model_get_parameters(lavmodel = lavmodel, type = "user") |
| 28 | ||
| 29 |
# did we compute standard errors? |
|
| 30 | 140x |
if (is.null(lavpartable$se)) {
|
| 31 | 3x |
if (is.null(VCOV)) {
|
| 32 | 3x |
se <- rep(as.numeric(NA), lavmodel@nx.user) |
| 33 | 3x |
se[lavpartable$free == 0L] <- 0 |
| 34 |
} else {
|
|
| 35 | ! |
se <- lav_model_vcov_se( |
| 36 | ! |
lavmodel = lavmodel, |
| 37 | ! |
lavpartable = lavpartable, |
| 38 | ! |
VCOV = VCOV, |
| 39 | ! |
BOOT = attr(VCOV, "BOOT.COEF") |
| 40 |
) |
|
| 41 |
} |
|
| 42 |
} else {
|
|
| 43 | 137x |
se <- as.numeric(lavpartable$se) # could be logical NA |
| 44 |
} |
|
| 45 | ||
| 46 |
# did we compute test statistics |
|
| 47 | 140x |
if (is.null(TEST)) {
|
| 48 | ! |
test <- list() |
| 49 |
} else {
|
|
| 50 | 140x |
test <- TEST |
| 51 |
} |
|
| 52 | ||
| 53 |
# for convenience: compute lavmodel-implied Sigma and Mu |
|
| 54 | 140x |
if (is.null(lavimplied) || length(lavimplied) == 0L) {
|
| 55 | ! |
implied <- lav_model_implied(lavmodel) |
| 56 |
} else {
|
|
| 57 | 140x |
implied <- lavimplied |
| 58 |
} |
|
| 59 | ||
| 60 |
# if bootstrapped parameters, add attr to 'est' |
|
| 61 | 140x |
if (!is.null(attr(VCOV, "BOOT.COEF"))) {
|
| 62 | ! |
attr(est, "BOOT.COEF") <- attr(VCOV, "BOOT.COEF") |
| 63 |
} |
|
| 64 | ||
| 65 |
# partrace? |
|
| 66 | 140x |
if (!is.null(attr(x, "partrace"))) {
|
| 67 | ! |
PARTRACE <- attr(x, "partrace") |
| 68 |
} else {
|
|
| 69 | 140x |
PARTRACE <- matrix(0, 0L, 0L) |
| 70 |
} |
|
| 71 | ||
| 72 | 140x |
new("Fit",
|
| 73 | 140x |
npar = max(lavpartable$free), |
| 74 | 140x |
x = x.copy, |
| 75 | 140x |
partrace = PARTRACE, |
| 76 | 140x |
start = lavpartable$start, # needed? (package stremo!) |
| 77 | 140x |
est = est, # at least 5 packages!! |
| 78 | 140x |
se = se, |
| 79 | 140x |
fx = fx, |
| 80 | 140x |
fx.group = fx.group, |
| 81 | 140x |
logl = logl, |
| 82 | 140x |
logl.group = logl.group, |
| 83 | 140x |
iterations = iterations, |
| 84 | 140x |
converged = converged, |
| 85 | 140x |
control = control, |
| 86 | 140x |
Sigma.hat = if (lavmodel@conditional.x) implied$res.cov else implied$cov, |
| 87 | 140x |
Mu.hat = if (lavmodel@conditional.x) implied$res.int else implied$mean, |
| 88 | 140x |
TH = if (lavmodel@conditional.x) implied$res.th else implied$th, |
| 89 | 140x |
test = test |
| 90 |
) |
|
| 91 |
} |
| 1 |
lav_samplestats_wls_obs <- function(mean.g, cov.g, var.g, |
|
| 2 |
th.g, th.idx.g, |
|
| 3 |
res.int.g, res.cov.g, res.var.g, res.th.g, |
|
| 4 |
res.slopes.g, |
|
| 5 |
group.w.g, |
|
| 6 |
categorical = FALSE, |
|
| 7 |
conditional.x = FALSE, |
|
| 8 |
meanstructure = FALSE, |
|
| 9 |
correlation = FALSE, |
|
| 10 |
slopestructure = FALSE, |
|
| 11 |
group.w.free = FALSE) {
|
|
| 12 |
# WLS.obs |
|
| 13 | 77x |
if (categorical) {
|
| 14 |
# order of elements is important here: |
|
| 15 |
# 1. thresholds + (negative) means (interleaved) |
|
| 16 |
# 2. slopes (if any) |
|
| 17 |
# 3. variances (if any) |
|
| 18 |
# 4. covariance matrix (no diagonal!) |
|
| 19 | ||
| 20 |
# NOTE: prior to 0.5-17, we had this: |
|
| 21 |
# TH[ov.types == "numeric"] <- -1*TH[ov.types == "numeric"] |
|
| 22 |
# which is WRONG if we have more than one threshold per variable |
|
| 23 |
# (thanks to Sacha Epskamp for spotting this!) |
|
| 24 | 2x |
if (conditional.x) {
|
| 25 | 2x |
TH <- res.th.g |
| 26 | 2x |
TH[th.idx.g == 0] <- -1 * TH[th.idx.g == 0] |
| 27 | ||
| 28 | 2x |
nvar <- length(res.var.g) |
| 29 | 2x |
num.idx <- which(!seq_len(nvar) %in% th.idx.g) |
| 30 | ||
| 31 | 2x |
WLS.obs <- c( |
| 32 | 2x |
TH, |
| 33 | 2x |
lav_matrix_vec(res.slopes.g), |
| 34 | 2x |
res.var.g[num.idx], |
| 35 | 2x |
lav_matrix_vech(res.cov.g, diagonal = FALSE) |
| 36 |
) |
|
| 37 |
} else {
|
|
| 38 | ! |
TH <- th.g |
| 39 | ! |
TH[th.idx.g == 0] <- -1 * TH[th.idx.g == 0] |
| 40 | ||
| 41 | ! |
nvar <- length(var.g) |
| 42 | ! |
num.idx <- which(!seq_len(nvar) %in% th.idx.g) |
| 43 | ||
| 44 | ! |
WLS.obs <- c( |
| 45 | ! |
TH, |
| 46 | ! |
var.g[num.idx], |
| 47 | ! |
lav_matrix_vech(cov.g, diagonal = FALSE) |
| 48 |
) |
|
| 49 |
} |
|
| 50 |
} else {
|
|
| 51 |
# CONTINUOUS: |
|
| 52 | 75x |
DIAG <- TRUE |
| 53 | 75x |
if (correlation) {
|
| 54 | ! |
DIAG <- FALSE |
| 55 |
} |
|
| 56 | 75x |
if (conditional.x) {
|
| 57 | ! |
if (meanstructure) {
|
| 58 | ! |
if (slopestructure) {
|
| 59 |
# order = vec(Beta), where first row are intercepts |
|
| 60 |
# cbind(res.int, res.slopes) is t(Beta) |
|
| 61 |
# so we need vecr |
|
| 62 | ! |
WLS.obs <- c( |
| 63 | ! |
lav_matrix_vecr(cbind( |
| 64 | ! |
res.int.g, |
| 65 | ! |
res.slopes.g |
| 66 |
)), |
|
| 67 | ! |
lav_matrix_vech(res.cov.g, diagonal = DIAG) |
| 68 |
) |
|
| 69 |
} else {
|
|
| 70 | ! |
WLS.obs <- c( |
| 71 | ! |
res.int.g, |
| 72 | ! |
lav_matrix_vech(res.cov.g, diagonal = DIAG) |
| 73 |
) |
|
| 74 |
} |
|
| 75 |
} else {
|
|
| 76 | ! |
if (slopestructure) {
|
| 77 | ! |
WLS.obs <- c( |
| 78 | ! |
lav_matrix_vecr(res.slopes.g), |
| 79 | ! |
lav_matrix_vech(res.cov.g, diagonal = DIAG) |
| 80 |
) |
|
| 81 |
} else {
|
|
| 82 | ! |
WLS.obs <- lav_matrix_vech(res.cov.g, diagonal = DIAG) |
| 83 |
} |
|
| 84 |
} |
|
| 85 |
} else {
|
|
| 86 | 75x |
if (meanstructure) {
|
| 87 | 53x |
WLS.obs <- c( |
| 88 | 53x |
mean.g, |
| 89 | 53x |
lav_matrix_vech(cov.g, diagonal = DIAG) |
| 90 |
) |
|
| 91 |
} else {
|
|
| 92 | 22x |
WLS.obs <- lav_matrix_vech(cov.g, diagonal = DIAG) |
| 93 |
} |
|
| 94 |
} |
|
| 95 |
} |
|
| 96 | ||
| 97 |
# group.w.free? |
|
| 98 | 77x |
if (group.w.free) {
|
| 99 | ! |
WLS.obs <- c(group.w.g, WLS.obs) |
| 100 |
} |
|
| 101 | ||
| 102 | 77x |
WLS.obs |
| 103 |
} |
| 1 |
# SAM step 2: estimate structural part |
|
| 2 | ||
| 3 |
lav_sam_step2 <- function(STEP1 = NULL, FIT = NULL, |
|
| 4 |
sam.method = "local", struc.args = list()) {
|
|
| 5 | ! |
lavoptions <- FIT@Options |
| 6 | ! |
lavpta <- FIT@pta |
| 7 | ! |
nlevels <- lavpta$nlevels |
| 8 | ! |
PT <- STEP1$PT |
| 9 | ||
| 10 |
# Gamma available? |
|
| 11 | ! |
gamma.flag <- FALSE |
| 12 | ! |
if (sam.method %in% c("local", "fsr", "cfsr") &&
|
| 13 | ! |
!is.null(STEP1$Gamma.eta[[1]])) {
|
| 14 | ! |
gamma.flag <- TRUE |
| 15 |
} |
|
| 16 | ||
| 17 | ! |
LV.names <- unique(unlist(FIT@pta$vnames$lv.regular)) |
| 18 | ||
| 19 |
# adjust options |
|
| 20 | ! |
lavoptions.PA <- lavoptions |
| 21 | ! |
if (lavoptions.PA$se == "naive") {
|
| 22 | ! |
lavoptions.PA$se <- "standard" |
| 23 | ! |
} else if (gamma.flag) {
|
| 24 | ! |
lavoptions.PA$se <- "robust.sem" |
| 25 | ! |
lavoptions.PA$test <- "satorra.bentler" |
| 26 |
} else {
|
|
| 27 |
# twostep or none -> none |
|
| 28 | ! |
lavoptions.PA$se <- "none" |
| 29 |
} |
|
| 30 |
# lavoptions.PA$fixed.x <- TRUE # may be false if indicator is predictor |
|
| 31 | ! |
if (!lavoptions.PA$conditional.x) {
|
| 32 | ! |
lavoptions.PA$fixed.x <- FALSE # until we fix this... |
| 33 |
} |
|
| 34 | ! |
lavoptions.PA$categorical <- FALSE |
| 35 | ! |
lavoptions.PA$.categorical <- FALSE |
| 36 | ! |
lavoptions.PA$rotation <- "none" |
| 37 | ! |
lavoptions.PA <- modifyList(lavoptions.PA, struc.args) |
| 38 | ||
| 39 | ! |
if (gamma.flag) {
|
| 40 | ! |
lavoptions.PA$check.vcov <- FALSE # always non-pd if interactions + fixed.x = FALSE |
| 41 |
} |
|
| 42 | ||
| 43 |
# override, no matter what |
|
| 44 | ! |
lavoptions.PA$do.fit <- TRUE |
| 45 | ||
| 46 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 47 | ! |
lavoptions.PA$missing <- "listwise" |
| 48 | ! |
lavoptions.PA$sample.cov.rescale <- FALSE |
| 49 |
# lavoptions.PA$baseline <- FALSE |
|
| 50 |
# lavoptions.PA$h1 <- FALSE |
|
| 51 |
# lavoptions.PA$implied <- FALSE |
|
| 52 | ! |
lavoptions.PA$loglik <- FALSE |
| 53 |
} else {
|
|
| 54 | ! |
lavoptions.PA$h1 <- FALSE |
| 55 |
# lavoptions.PA$implied <- FALSE |
|
| 56 | ! |
lavoptions.PA$loglik <- FALSE |
| 57 |
} |
|
| 58 | ||
| 59 | ||
| 60 |
# construct PTS |
|
| 61 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 62 |
# extract structural part |
|
| 63 | ! |
PTS <- lav_partable_subset_structural_model(PT, |
| 64 | ! |
add.idx = TRUE, |
| 65 | ! |
add.exo.cov = TRUE, |
| 66 | ! |
fixed.x = lavoptions.PA$fixed.x, |
| 67 | ! |
conditional.x = lavoptions.PA$conditional.x, |
| 68 | ! |
free.fixed.var = TRUE, |
| 69 | ! |
meanstructure = lavoptions.PA$meanstructure |
| 70 |
) |
|
| 71 | ||
| 72 |
# any 'extra' parameters: not (free) in PT, but free in PTS (user == 3) |
|
| 73 |
# - fixed.x in PT, but fixed.x = FALSE is PTS |
|
| 74 |
# - fixed-to-zero interceps in PT, but free in PTS |
|
| 75 |
# - add.exo.cov: absent/fixed-to-zero in PT, but add/free in PTS |
|
| 76 | ! |
extra.id <- which(PTS$user == 3L) |
| 77 | ||
| 78 |
# remove est/se/start columns |
|
| 79 | ! |
PTS$est <- NULL |
| 80 | ! |
PTS$se <- NULL |
| 81 | ! |
PTS$start <- NULL |
| 82 | ||
| 83 | ! |
if (nlevels > 1L) {
|
| 84 | ! |
PTS$level <- NULL |
| 85 | ! |
PTS$group <- NULL |
| 86 | ! |
PTS$group <- PTS$block |
| 87 | ! |
NOBS <- FIT@Data@Lp[[1]]$nclusters |
| 88 |
} else {
|
|
| 89 | ! |
NOBS <- FIT@Data@nobs |
| 90 |
} |
|
| 91 | ||
| 92 |
# if meanstructure, 'free' user=0 intercepts? |
|
| 93 |
# if (lavoptions.PA$meanstructure) {
|
|
| 94 |
# extra.int.idx <- which(PTS$op == "~1" & PTS$user == 0L & |
|
| 95 |
# PTS$free == 0L & |
|
| 96 |
# PTS$exo == 0L) # needed? |
|
| 97 |
# if (length(extra.int.idx) > 0L) {
|
|
| 98 |
# PTS$free[extra.int.idx] <- 1L |
|
| 99 |
# PTS$ustart[extra.int.idx] <- as.numeric(NA) |
|
| 100 |
# PTS$free[PTS$free > 0L] <- |
|
| 101 |
# seq_len(length(PTS$free[PTS$free > 0L])) |
|
| 102 |
# PTS$user[extra.int.idx] <- 3L |
|
| 103 |
# } |
|
| 104 |
# } else {
|
|
| 105 |
# extra.int.idx <- integer(0L) |
|
| 106 |
# } |
|
| 107 |
# extra.id <- c(extra.id, extra.int.idx) |
|
| 108 | ||
| 109 | ! |
reg.idx <- attr(PTS, "idx") |
| 110 | ! |
attr(PTS, "idx") <- NULL |
| 111 |
} else {
|
|
| 112 |
# global SAM |
|
| 113 | ||
| 114 |
# the measurement model parameters now become fixed ustart values |
|
| 115 | ! |
PT$ustart[PT$free > 0] <- PT$est[PT$free > 0] |
| 116 | ||
| 117 | ! |
reg.idx <- lav_partable_subset_structural_model( |
| 118 | ! |
PT = PT, |
| 119 | ! |
idx.only = TRUE |
| 120 |
) |
|
| 121 | ||
| 122 |
# remove 'exogenous' factor variances (if any) from reg.idx |
|
| 123 | ! |
lv.names.x <- LV.names[LV.names %in% unlist(lavpta$vnames$eqs.x) & |
| 124 | ! |
!LV.names %in% unlist(lavpta$vnames$eqs.y)] |
| 125 | ! |
if ((lavoptions.PA$fixed.x || lavoptions.PA$std.lv) && |
| 126 | ! |
length(lv.names.x) > 0L) {
|
| 127 | ! |
var.idx <- which(PT$lhs %in% lv.names.x & |
| 128 | ! |
PT$op == "~~" & |
| 129 | ! |
PT$lhs == PT$rhs) |
| 130 | ! |
rm.idx <- which(reg.idx %in% var.idx) |
| 131 | ! |
if (length(rm.idx) > 0L) {
|
| 132 | ! |
reg.idx <- reg.idx[-rm.idx] |
| 133 |
} |
|
| 134 |
} |
|
| 135 | ||
| 136 |
# adapt parameter table for structural part |
|
| 137 | ! |
PTS <- PT |
| 138 | ||
| 139 |
# remove constraints we don't need |
|
| 140 | ! |
con.idx <- which(PTS$op %in% c("==", "<", ">", ":="))
|
| 141 | ! |
if (length(con.idx) > 0L) {
|
| 142 | ! |
needed.idx <- which(con.idx %in% reg.idx) |
| 143 | ! |
if (length(needed.idx) > 0L) {
|
| 144 | ! |
con.idx <- con.idx[-needed.idx] |
| 145 |
} |
|
| 146 | ! |
if (length(con.idx) > 0L) {
|
| 147 | ! |
PTS <- as.data.frame(PTS, stringsAsFactors = FALSE) |
| 148 | ! |
PTS <- PTS[-con.idx, ] |
| 149 |
} |
|
| 150 |
} |
|
| 151 | ! |
PTS$est <- NULL |
| 152 | ! |
PTS$se <- NULL |
| 153 | ||
| 154 |
# 'fix' step 1 parameters |
|
| 155 | ! |
PTS$free[!PTS$id %in% reg.idx & PTS$free > 0L] <- 0L |
| 156 | ||
| 157 |
# but free up residual variances if fixed (eg std.lv = TRUE) (new in 0.6-20) |
|
| 158 | ! |
var.idx <- reg.idx[which(PT$free[reg.idx] == 0L & |
| 159 | ! |
PT$user[reg.idx] != 1L & |
| 160 | ! |
PT$op[reg.idx] == "~~")] # FIXME: more? |
| 161 | ! |
PTS$free[var.idx] <- max(PTS$free) + seq_len(length(var.idx)) |
| 162 | ||
| 163 |
# set 'ustart' values for free FIT.PA parameter to NA |
|
| 164 | ! |
PTS$ustart[PTS$free > 0L] <- as.numeric(NA) |
| 165 | ||
| 166 | ! |
PTS <- lav_partable_complete(PTS) |
| 167 | ||
| 168 | ! |
extra.id <- extra.int.idx <- integer(0L) |
| 169 |
} # global |
|
| 170 | ||
| 171 |
# fit structural model |
|
| 172 | ! |
if (lav_verbose()) {
|
| 173 | ! |
cat("Fitting the structural part ... \n")
|
| 174 |
} |
|
| 175 | ! |
if (sam.method %in% c("local", "fsr", "cfsr")) {
|
| 176 | ! |
if (gamma.flag) {
|
| 177 | ! |
NACOV <- STEP1$Gamma.eta |
| 178 | ! |
ov.order <- "data" |
| 179 |
} else {
|
|
| 180 | ! |
NACOV <- NULL |
| 181 | ! |
ov.order <- "model" |
| 182 |
} |
|
| 183 | ! |
FIT.PA <- lavaan::lavaan(PTS, |
| 184 | ! |
sample.cov = STEP1$VETA, |
| 185 | ! |
sample.mean = STEP1$EETA, |
| 186 | ! |
sample.nobs = NOBS, |
| 187 | ! |
NACOV = NACOV, |
| 188 | ! |
slotOptions = lavoptions.PA, |
| 189 | ! |
verbose = FALSE |
| 190 |
) |
|
| 191 |
} else {
|
|
| 192 | ! |
FIT.PA <- lavaan::lavaan( |
| 193 | ! |
model = PTS, |
| 194 | ! |
slotData = FIT@Data, |
| 195 | ! |
slotSampleStats = FIT@SampleStats, |
| 196 | ! |
slotOptions = lavoptions.PA, |
| 197 | ! |
verbose = FALSE |
| 198 |
) |
|
| 199 |
} |
|
| 200 | ! |
if (lav_verbose()) {
|
| 201 | ! |
cat("Fitting the structural part ... done.\n")
|
| 202 |
} |
|
| 203 | ||
| 204 |
# which parameters from PTS do we wish to fill in: |
|
| 205 |
# - all 'free' parameters |
|
| 206 |
# - :=, <, > (if any) |
|
| 207 |
# - and NOT element with user=3 (add.exo.cov = TRUE, extra.int.idx) |
|
| 208 | ! |
pts.idx <- which((PTS$free > 0L | (PTS$op %in% c(":=", "<", ">"))) &
|
| 209 | ! |
!PTS$user == 3L) |
| 210 | ||
| 211 |
# find corresponding rows in PT |
|
| 212 | ! |
PTS2 <- as.data.frame(PTS, stringsAsFactors = FALSE) |
| 213 | ! |
pt.idx <- lav_partable_map_id_p1_in_p2(PTS2[pts.idx, ], PT, |
| 214 | ! |
exclude.nonpar = FALSE |
| 215 |
) |
|
| 216 |
# fill in |
|
| 217 | ! |
PT$est[pt.idx] <- FIT.PA@ParTable$est[pts.idx] |
| 218 | ||
| 219 |
# create step2.free.idx |
|
| 220 | ! |
p2.idx <- seq_len(length(PT$lhs)) %in% pt.idx & PT$free > 0 # no def! |
| 221 | ! |
step2.free.idx <- STEP1$PT.free[p2.idx] |
| 222 | ||
| 223 |
# add 'step' column in PT |
|
| 224 | ! |
PT$step <- rep(1L, length(PT$lhs)) |
| 225 | ! |
PT$step[seq_len(length(PT$lhs)) %in% reg.idx] <- 2L |
| 226 | ||
| 227 | ! |
STEP2 <- list( |
| 228 | ! |
FIT.PA = FIT.PA, PT = PT, reg.idx = reg.idx, |
| 229 | ! |
step2.free.idx = step2.free.idx, extra.id = extra.id, |
| 230 | ! |
pt.idx = pt.idx, pts.idx = pts.idx |
| 231 |
) |
|
| 232 | ||
| 233 | ! |
STEP2 |
| 234 |
} |
| 1 |
# compare two nested models, by default using the chi-square |
|
| 2 |
# difference test |
|
| 3 | ||
| 4 |
# - in 0.5-16, SB.classic = TRUE is the default again (for now) |
|
| 5 |
# - in 0.5-18, SB.classic is replaced by 'method', with the following |
|
| 6 |
# options: |
|
| 7 |
# method = "default" (we choose a default method, based on the estimator) |
|
| 8 |
# method = "standard" (option to explicitly avoid robust adjustment) |
|
| 9 |
# method = "Satorra.2000" |
|
| 10 |
# method = "Satorra.Bentler.2001" |
|
| 11 |
# method = "Satorra.Bentler.2010" |
|
| 12 |
# method = "mean.var.adjusted.PLRT" |
|
| 13 |
# |
|
| 14 |
# - 0.6-13: RMSEA.D (also known as 'RDR') is added to the table (also if scaled, |
|
| 15 |
# since 0.6-20) |
|
| 16 |
# - 0.6-13: fix multiple-group UG^2 bug in Satorra.2000 (reported by |
|
| 17 |
# Gronneberg, Foldnes and Moss) |
|
| 18 |
# |
|
| 19 |
# - 0.6-18: |
|
| 20 |
# New option method = "standard" (to explicitly avoid robust adjustment) |
|
| 21 |
# New test= argument to select scaled stat when method="satorra.bentler.2001/2010" |
|
| 22 | ||
| 23 | ||
| 24 |
lavTestLRT <- function(object, ..., method = "default", test = "default", |
|
| 25 |
A.method = "delta", scaled.shifted = TRUE, # only when method="Satorra.2000" |
|
| 26 |
type = "Chisq", model.names = NULL) {
|
|
| 27 | 40x |
type <- tolower(type[1]) |
| 28 | 40x |
test <- tolower(test[1]) |
| 29 | 40x |
method <- tolower(gsub("[-_\\.]", "", method[1]))
|
| 30 | 40x |
if (type %in% c("browne", "browne.residual.adf", "browne.residual.nt")) {
|
| 31 | ! |
if (type == "browne") {
|
| 32 | ! |
type <- "browne.residual.adf" |
| 33 |
} |
|
| 34 | ! |
if (!method %in% c("default", "standard")) {
|
| 35 | ! |
lav_msg_stop(gettext( |
| 36 | ! |
"method cannot be used if type is browne.residual.adf or |
| 37 | ! |
browne.residual.nt")) |
| 38 |
} |
|
| 39 | ! |
method <- "default" |
| 40 |
} |
|
| 41 | ||
| 42 |
# NOTE: if we add additional arguments, it is not the same generic |
|
| 43 |
# anova() function anymore, and match.call will be screwed up |
|
| 44 | ||
| 45 | 40x |
mcall <- match.call(expand.dots = TRUE) |
| 46 | 40x |
dots <- list(...) |
| 47 | 40x |
modp <- if (length(dots)) {
|
| 48 | ! |
sapply(dots, inherits, "lavaan") |
| 49 |
} else {
|
|
| 50 | 40x |
logical(0L) |
| 51 |
} |
|
| 52 |
# check object |
|
| 53 | 40x |
object <- lav_object_check_version(object) |
| 54 |
# check models in dots |
|
| 55 | 40x |
dots[modp] <- lapply(dots[modp], lav_object_check_version) |
| 56 | ||
| 57 |
# some general properties (taken from the first model) |
|
| 58 | 40x |
estimator <- object@Options$estimator |
| 59 | 40x |
likelihood <- object@Options$likelihood |
| 60 | 40x |
ngroups <- object@Data@ngroups |
| 61 | 40x |
nobs <- object@SampleStats@nobs |
| 62 | 40x |
ntotal <- object@SampleStats@ntotal |
| 63 | ||
| 64 |
# TDJ: check for user-supplied h1 model |
|
| 65 | 40x |
user_h1_exists <- FALSE |
| 66 | 40x |
if (!is.null(object@external$h1.model)) {
|
| 67 | ! |
if (inherits(object@external$h1.model, "lavaan")) {
|
| 68 | ! |
user_h1_exists <- TRUE |
| 69 |
} |
|
| 70 |
} |
|
| 71 | ||
| 72 |
# shortcut for single argument (just plain LRT) |
|
| 73 | 40x |
if (!any(modp) && !user_h1_exists) {
|
| 74 | 40x |
if (type == "cf") {
|
| 75 | ! |
lav_msg_warn(gettext("`type' argument is ignored for a single model"))
|
| 76 |
} |
|
| 77 | 40x |
return(lav_test_lrt_single_model(object, method = method, test = test, type = type)) |
| 78 |
} |
|
| 79 | ||
| 80 |
# list of models |
|
| 81 | ! |
mods <- c(list(object), dots[modp]) |
| 82 | ! |
if (!is.null(model.names)) {
|
| 83 | ! |
names(mods) <- model.names |
| 84 |
} else {
|
|
| 85 | ! |
names(mods) <- sapply( |
| 86 | ! |
as.list(mcall)[which(c(FALSE, TRUE, modp))], |
| 87 | ! |
function(x) deparse(x) |
| 88 |
) |
|
| 89 |
} |
|
| 90 |
# TDJ: Add user-supplied h1 model, if it exists |
|
| 91 | ! |
if (user_h1_exists) mods$user_h1 <- object@external$h1.model |
| 92 | ||
| 93 |
# put them in order (using degrees of freedom) |
|
| 94 | ! |
ndf <- sapply(mods, function(x) x@test[[1]]$df) |
| 95 | ! |
order.idx <- order(ndf) |
| 96 | ! |
mods <- mods[order.idx] |
| 97 | ! |
ndf <- ndf[order.idx] |
| 98 | ||
| 99 |
# here come the checks -- eventually, an option may skip this |
|
| 100 | ! |
if (TRUE) {
|
| 101 |
# 1. same set of observed variables? |
|
| 102 | ! |
ov.names <- lapply(mods, function(x) {
|
| 103 | ! |
sort(lav_object_vnames(x)) |
| 104 |
}) |
|
| 105 | ! |
OV <- ov.names[[1L]] # the observed variable names of the first model |
| 106 | ! |
if (!all(sapply(ov.names, function(x) identical(x, OV)))) {
|
| 107 | ! |
lav_msg_warn(gettext( |
| 108 | ! |
"some models are based on a different set of observed variables")) |
| 109 |
} |
|
| 110 |
## wow FIXME: we may need to reorder the rows/columns first!! |
|
| 111 |
# COVS <- lapply(mods, function(x) slot(slot(x, "Sample"), "cov")[[1]]) |
|
| 112 |
# if(!all(sapply(COVS, all.equal, COVS[[1]]))) {
|
|
| 113 |
# stop("lavaan ERROR: models must be fit to the same data")
|
|
| 114 |
# } |
|
| 115 |
# 2. nested models? *different* npars? |
|
| 116 | ||
| 117 |
# TODO! |
|
| 118 | ||
| 119 |
# 3. all meanstructure? |
|
| 120 | ! |
mean.structure <- sapply(mods, lavInspect, "meanstructure") |
| 121 | ! |
if (sum(mean.structure) > 0L && |
| 122 | ! |
sum(mean.structure) < length(mean.structure)) {
|
| 123 | ! |
lav_msg_warn(gettext("not all models have a meanstructure"))
|
| 124 |
} |
|
| 125 | ||
| 126 |
# 4. all converged? |
|
| 127 | ! |
if (!all(sapply(mods, lavInspect, "converged"))) {
|
| 128 | ! |
lav_msg_warn(gettext("not all models converged"))
|
| 129 |
} |
|
| 130 |
} |
|
| 131 | ||
| 132 | ! |
mods.scaled <- unlist(lapply(mods, function(x) {
|
| 133 | ! |
any(c( |
| 134 | ! |
"satorra.bentler", "yuan.bentler", "yuan.bentler.mplus", |
| 135 | ! |
"mean.var.adjusted", "scaled.shifted" |
| 136 | ! |
) %in% |
| 137 | ! |
unlist(sapply(slot(x, "test"), "[[", "test"))) |
| 138 |
})) |
|
| 139 | ||
| 140 | ! |
if (all(mods.scaled | ndf == 0) && any(mods.scaled)) {
|
| 141 |
# Note: if df=0, test is not really robust, hence the above condition |
|
| 142 | ! |
scaled <- TRUE |
| 143 |
# which test to choose by default? |
|
| 144 |
# i.e., not determined by method= |
|
| 145 | ! |
scaledList <- sapply(mods[[ which(ndf > 0)[1] ]]@test, # first mod with df>0 |
| 146 |
#FIXME? If no mods have df > 0, this still yields error |
|
| 147 | ! |
function(x) !is.null(x$scaled.test.stat)) |
| 148 | ! |
scaled.idx <- which(scaledList)[[1]] |
| 149 | ! |
default.TEST <- object@test[[scaled.idx]]$test |
| 150 | ! |
if (test == "default") {
|
| 151 | ! |
TEST <- default.TEST |
| 152 | ! |
} else if (!test %in% c("satorra.bentler", "yuan.bentler", "yuan.bentler.mplus",
|
| 153 | ! |
"mean.var.adjusted", "scaled.shifted")) {
|
| 154 | ! |
lav_msg_stop(gettextf( |
| 155 | ! |
"test = %s not found in object. See available tests in |
| 156 | ! |
lavInspect(object, \"options\")$test.", dQuote(test))) |
| 157 | ! |
} else TEST <- test |
| 158 | ||
| 159 |
## is the test available from all models? |
|
| 160 | ! |
check.scaled <- unlist(lapply(mods, function(x) {
|
| 161 | ! |
TEST %in% unlist(sapply(slot(x, "test"), "[[", "test")) |
| 162 |
})) |
|
| 163 | ||
| 164 | ! |
if (any(!check.scaled)) {
|
| 165 | ! |
lav_msg_stop(gettextf( |
| 166 | ! |
"test = %1$s not found in model(s): %2$s. Find available tests per model |
| 167 | ! |
using lavInspect(fit, \"options\")$test.", dQuote(test), |
| 168 | ! |
lav_msg_view(names(mods)[which(!check.scaled)], "none"))) |
| 169 |
} |
|
| 170 | ||
| 171 | ! |
} else if (!any(mods.scaled)) { # thanks to R.M. Bee to fix this
|
| 172 | ! |
scaled <- FALSE |
| 173 | ! |
TEST <- "standard" |
| 174 | ! |
method <- "standard" |
| 175 |
} else {
|
|
| 176 | ! |
lav_msg_stop(gettext( |
| 177 | ! |
"some models (but not all) have scaled test statistics")) |
| 178 |
} |
|
| 179 | ! |
if (type %in% c("browne.residual.adf", "browne.residual.nt")) {
|
| 180 | ! |
scaled <- FALSE |
| 181 | ! |
method <- "standard" |
| 182 |
} |
|
| 183 | ! |
if (method == "standard") {
|
| 184 | ! |
scaled <- FALSE |
| 185 |
} |
|
| 186 | ||
| 187 |
# select method |
|
| 188 | ! |
if (method == "default") {
|
| 189 | ! |
if (estimator == "PML") {
|
| 190 | ! |
method <- "mean.var.adjusted.PLRT" |
| 191 | ! |
} else if (scaled) {
|
| 192 | ! |
if (TEST %in% c( |
| 193 | ! |
"satorra.bentler", "yuan.bentler", |
| 194 | ! |
"yuan.bentler.mplus" |
| 195 |
)) {
|
|
| 196 | ! |
method <- "satorra.bentler.2001" |
| 197 |
} else {
|
|
| 198 | ! |
method <- "satorra.2000" |
| 199 |
} |
|
| 200 |
} else {
|
|
| 201 |
# nothing to do |
|
| 202 |
} |
|
| 203 | ! |
} else if (method == "meanvaradjustedplrt" || |
| 204 | ! |
method == "mean.var.adjusted.PLRT") {
|
| 205 | ! |
method <- "mean.var.adjusted.PLRT" |
| 206 | ! |
stopifnot(estimator == "PML") |
| 207 | ! |
} else if (method == "satorra2000") {
|
| 208 | ! |
method <- "satorra.2000" |
| 209 | ! |
} else if (method == "satorrabentler2001") {
|
| 210 | ! |
method <- "satorra.bentler.2001" |
| 211 | ! |
} else if (method == "satorrabentler2010") {
|
| 212 | ! |
method <- "satorra.bentler.2010" |
| 213 | ||
| 214 |
## only option left: |
|
| 215 | ! |
} else if (method != "standard") {
|
| 216 | ! |
lav_msg_stop( |
| 217 | ! |
gettextf("unknown method for scaled difference test: %s.", method))
|
| 218 |
} |
|
| 219 | ||
| 220 |
## in case users specify method= or test= (but still type="chisq"), |
|
| 221 |
## make sure the arguments are consistent for scaled tests |
|
| 222 | ! |
if (method %in% c("satorra.bentler.2001","satorra.bentler.2010") && scaled &&
|
| 223 | ! |
(!TEST %in% c("satorra.bentler","yuan.bentler","yuan.bentler.mplus")) ) {
|
| 224 | ! |
lav_msg_stop(gettextf( |
| 225 | ! |
"method = %s only available when models are fitted with test = |
| 226 | ! |
\"satorra.bentler\", \"yuan.bentler\", or \"yuan.bentler.mplus\".", |
| 227 | ! |
dQuote(method))) |
| 228 |
} else {
|
|
| 229 |
## method="satorra.2000" still available when TEST != scaled.shifted |
|
| 230 |
## Or !scaled, so nothing to do. |
|
| 231 |
} |
|
| 232 | ||
| 233 |
# check method if scaled = FALSE |
|
| 234 | ! |
if (type == "chisq" && !scaled && |
| 235 | ! |
method %in% c( |
| 236 | ! |
"mean.var.adjusted.PLRT", |
| 237 | ! |
"satorra.bentler.2001", |
| 238 | ! |
"satorra.2000", |
| 239 | ! |
"satorra.bentler.2010" |
| 240 |
)) {
|
|
| 241 | ! |
lav_msg_warn(gettextf( |
| 242 | ! |
"method = %s but no robust test statistics were used; switching to the |
| 243 | ! |
standard chi-squared difference test", dQuote(method))) |
| 244 | ! |
method <- "standard" |
| 245 |
} |
|
| 246 | ||
| 247 | ||
| 248 |
# which models have used a MEANSTRUCTURE? |
|
| 249 | ! |
mods.meanstructure <- sapply(mods, function(x) {
|
| 250 | ! |
unlist(slot( |
| 251 | ! |
slot(x, "Model"), |
| 252 | ! |
"meanstructure" |
| 253 |
)) |
|
| 254 |
}) |
|
| 255 | ! |
if (all(mods.meanstructure)) {
|
| 256 | ! |
meanstructure <- "ok" |
| 257 | ! |
} else if (sum(mods.meanstructure) == 0) {
|
| 258 | ! |
meanstructure <- "ok" |
| 259 |
} else {
|
|
| 260 | ! |
lav_msg_stop(gettext("some models (but not all) have a meanstructure"))
|
| 261 |
} |
|
| 262 | ||
| 263 |
# collect statistics for each model |
|
| 264 | ! |
if (type == "chisq") {
|
| 265 | ! |
Df <- sapply(mods, function(x) slot(x, "test")[[1]]$df) |
| 266 | ! |
STAT <- sapply(mods, function(x) slot(x, "test")[[1]]$stat) |
| 267 | ! |
} else if (type == "browne.residual.nt") {
|
| 268 | ! |
TESTlist <- lapply( |
| 269 | ! |
mods, |
| 270 | ! |
function(x) lavTest(x, test = "browne.residual.nt") |
| 271 |
) |
|
| 272 | ! |
Df <- sapply(TESTlist, function(x) x$df) |
| 273 | ! |
STAT <- sapply(TESTlist, function(x) x$stat) |
| 274 | ! |
} else if (type == "browne.residual.adf") {
|
| 275 | ! |
TESTlist <- lapply( |
| 276 | ! |
mods, |
| 277 | ! |
function(x) lavTest(x, test = "browne.residual.adf") |
| 278 |
) |
|
| 279 | ! |
Df <- sapply(TESTlist, function(x) x$df) |
| 280 | ! |
STAT <- sapply(TESTlist, function(x) x$stat) |
| 281 | ! |
} else if (type == "cf") {
|
| 282 | ! |
tmp <- lapply(mods, lavTablesFitCf) |
| 283 | ! |
STAT <- unlist(tmp) |
| 284 | ! |
Df <- unlist(lapply(tmp, attr, "DF")) |
| 285 |
} else {
|
|
| 286 | ! |
lav_msg_stop(gettextf("test type unknown: %s", type))
|
| 287 |
} |
|
| 288 | ||
| 289 |
# difference statistics |
|
| 290 | ! |
STAT.delta <- STAT.delta.orig <- c(NA, diff(STAT)) |
| 291 | ! |
Df.delta <- Df.delta.orig <- c(NA, diff(Df)) |
| 292 | ||
| 293 |
# check for negative values in STAT.delta |
|
| 294 |
# but with a tolerance (0.6-12)! |
|
| 295 | ! |
if (any(STAT.delta[-1] < -1 * .Machine$double.eps^(1 / 3))) {
|
| 296 | ! |
lav_msg_warn(gettextf( |
| 297 | ! |
"Some restricted models fit better than less restricted models; either |
| 298 | ! |
these models are not nested, or the less restricted model failed to reach |
| 299 | ! |
a global optimum.Smallest difference = %s.", min(STAT.delta[-1]))) |
| 300 |
} |
|
| 301 | ||
| 302 |
# prepare for scaling versions |
|
| 303 | ! |
if (method == "satorra.2000" && scaled.shifted) {
|
| 304 | ! |
a.delta <- b.delta <- rep(as.numeric(NA), length(STAT)) |
| 305 | ! |
c.delta <- NULL |
| 306 | ! |
} else if (method %in% c("satorra.bentler.2001","satorra.bentler.2010",
|
| 307 | ! |
"satorra.2000")) {
|
| 308 | ! |
c.delta <- rep(as.numeric(NA), length(STAT)) |
| 309 |
} |
|
| 310 | ||
| 311 |
# correction for scaled test statistics |
|
| 312 | ! |
if (type == "chisq" && scaled) {
|
| 313 | ! |
if (method == "satorra.bentler.2001") {
|
| 314 |
# use formula from Satorra & Bentler 2001 |
|
| 315 | ! |
for (m in seq_len(length(mods) - 1L)) {
|
| 316 | ! |
out <- lav_test_diff_SatorraBentler2001(mods[[m]], mods[[m + 1]], |
| 317 |
# in case not @test[[2]]: |
|
| 318 | ! |
test = TEST) |
| 319 | ! |
STAT.delta[m + 1] <- out$T.delta |
| 320 | ! |
Df.delta[m + 1] <- out$df.delta |
| 321 | ! |
c.delta[m + 1] <- out$scaling.factor |
| 322 |
} |
|
| 323 | ! |
} else if (method == "mean.var.adjusted.PLRT") {
|
| 324 | ! |
for (m in seq_len(length(mods) - 1L)) {
|
| 325 | ! |
out <- lav_pml_test_plrt(mods[[m]], mods[[m + 1]]) |
| 326 | ! |
STAT.delta[m + 1] <- out$FSMA.PLRT |
| 327 | ! |
Df.delta[m + 1] <- out$adj.df |
| 328 |
} |
|
| 329 | ! |
} else if (method == "satorra.bentler.2010") {
|
| 330 | ! |
for (m in seq_len(length(mods) - 1L)) {
|
| 331 | ! |
out <- lav_test_diff_SatorraBentler2010(mods[[m]], mods[[m + 1]], |
| 332 | ! |
test = TEST, # in case not @test[[2]] |
| 333 | ! |
H1 = FALSE |
| 334 | ! |
) # must be F |
| 335 | ||
| 336 | ! |
STAT.delta[m + 1] <- out$T.delta |
| 337 | ! |
Df.delta[m + 1] <- out$df.delta |
| 338 | ! |
c.delta[m + 1] <- out$scaling.factor |
| 339 |
} |
|
| 340 | ! |
} else if (method == "satorra.2000") {
|
| 341 | ! |
for (m in seq_len(length(mods) - 1L)) {
|
| 342 | ! |
if (TEST %in% c( |
| 343 | ! |
"satorra.bentler", "yuan.bentler", |
| 344 | ! |
"yuan.bentler.mplus" |
| 345 |
)) {
|
|
| 346 | ! |
Satterthwaite <- FALSE |
| 347 |
} else {
|
|
| 348 | ! |
Satterthwaite <- TRUE |
| 349 |
} |
|
| 350 | ! |
out <- lav_test_diff_Satorra2000(mods[[m]], mods[[m + 1]], |
| 351 | ! |
H1 = TRUE, |
| 352 | ! |
Satterthwaite = Satterthwaite, |
| 353 | ! |
scaled.shifted = scaled.shifted, |
| 354 | ! |
A.method = A.method |
| 355 |
) |
|
| 356 | ! |
STAT.delta[m + 1] <- out$T.delta |
| 357 | ! |
Df.delta[m + 1] <- out$df.delta |
| 358 | ! |
if (scaled.shifted) {
|
| 359 | ! |
a.delta[m + 1] <- out$a |
| 360 | ! |
b.delta[m + 1] <- out$b |
| 361 |
} else {
|
|
| 362 | ! |
c.delta[m + 1] <- out$scaling.factor |
| 363 |
} |
|
| 364 |
} |
|
| 365 |
} |
|
| 366 |
} |
|
| 367 | ||
| 368 |
# check if scaled diff failed somehow |
|
| 369 | ! |
if (scaled && |
| 370 | ! |
( (method %in% c("satorra.bentler.2001", "satorra.bentler.2010") &&
|
| 371 | ! |
is.na(out$scaling.factor)) || |
| 372 | ! |
(method == "satorra.2000" && scaled.shifted && is.na(out$a)) || |
| 373 | ! |
(method == "satorra.2000" && !scaled.shifted && |
| 374 | ! |
is.na(out$scaling.factor)) ) |
| 375 |
) {
|
|
| 376 | ! |
scaled <- FALSE |
| 377 |
} |
|
| 378 | ||
| 379 | ||
| 380 |
# unname |
|
| 381 | ! |
STAT.delta <- unname(STAT.delta) |
| 382 |
# zap small values (for near-zero values) (anova class does not use rounding) |
|
| 383 | ! |
STAT.delta <- round(STAT.delta, 10) |
| 384 | ! |
Df.delta <- unname(Df.delta) |
| 385 | ! |
STAT.delta.orig <- unname(STAT.delta.orig) |
| 386 | ! |
Df.delta.orig <- unname(Df.delta.orig) |
| 387 | ! |
if (scaled && !is.null(c.delta)) {
|
| 388 | ! |
c.delta <- unname(c.delta) |
| 389 |
} |
|
| 390 | ||
| 391 |
# Pvalue |
|
| 392 | ! |
Pvalue.delta <- pchisq(STAT.delta, Df.delta, lower.tail = FALSE) |
| 393 | ||
| 394 |
# new in 0.6-13: RMSEA (RMSEA.D or RDR) |
|
| 395 | ! |
if (object@Options$missing == "listwise") {
|
| 396 | ! |
if (scaled && !is.null(c.delta)) {
|
| 397 | ! |
c.hat <- c.delta[-1] |
| 398 |
} else {
|
|
| 399 | ! |
c.hat <- rep(1, length(STAT.delta.orig) - 1L) |
| 400 |
} |
|
| 401 | ! |
RMSEA.delta <- c(NA, lav_fit_rmsea( |
| 402 | ! |
X2 = STAT.delta.orig[-1], |
| 403 | ! |
df = Df.delta.orig[-1], |
| 404 | ! |
N = ntotal, |
| 405 | ! |
G = ngroups, |
| 406 | ! |
c.hat = c.hat |
| 407 |
)) |
|
| 408 |
} |
|
| 409 | ||
| 410 |
# AIC/BIC |
|
| 411 | ! |
aic <- bic <- rep(NA, length(mods)) |
| 412 | ! |
if (estimator == "ML") {
|
| 413 | ! |
aic <- sapply(mods, FUN = AIC) |
| 414 | ! |
bic <- sapply(mods, FUN = BIC) |
| 415 | ! |
} else if (estimator == "PML") {
|
| 416 | ! |
OUT <- lapply(mods, lav_pml_object_aic_bic) |
| 417 | ! |
aic <- sapply(OUT, "[[", "PL_AIC") |
| 418 | ! |
bic <- sapply(OUT, "[[", "PL_BIC") |
| 419 |
} |
|
| 420 | ||
| 421 | ! |
if (estimator == "PML") {
|
| 422 | ! |
val <- data.frame( |
| 423 | ! |
Df = Df, |
| 424 | ! |
PL_AIC = aic, |
| 425 | ! |
PL_BIC = bic, |
| 426 | ! |
Chisq = STAT, |
| 427 | ! |
"Chisq diff" = STAT.delta, |
| 428 | ! |
"Df diff" = Df.delta, |
| 429 | ! |
"Pr(>Chisq)" = Pvalue.delta, |
| 430 | ! |
row.names = names(mods), |
| 431 | ! |
check.names = FALSE |
| 432 |
) |
|
| 433 | ! |
} else if (object@Options$missing == "listwise") {
|
| 434 | ! |
val <- data.frame( |
| 435 | ! |
Df = Df, |
| 436 | ! |
AIC = aic, |
| 437 | ! |
BIC = bic, |
| 438 | ! |
Chisq = STAT, |
| 439 | ! |
"Chisq diff" = STAT.delta, |
| 440 | ! |
"RMSEA" = RMSEA.delta, |
| 441 | ! |
"Df diff" = Df.delta, |
| 442 | ! |
"Pr(>Chisq)" = Pvalue.delta, |
| 443 | ! |
row.names = names(mods), |
| 444 | ! |
check.names = FALSE |
| 445 |
) |
|
| 446 |
} else {
|
|
| 447 | ! |
val <- data.frame( |
| 448 | ! |
Df = Df, |
| 449 | ! |
AIC = aic, |
| 450 | ! |
BIC = bic, |
| 451 | ! |
Chisq = STAT, |
| 452 | ! |
"Chisq diff" = STAT.delta, |
| 453 |
#"RMSEA" = RMSEA.delta, # if missing, not yet... |
|
| 454 | ! |
"Df diff" = Df.delta, |
| 455 | ! |
"Pr(>Chisq)" = Pvalue.delta, |
| 456 | ! |
row.names = names(mods), |
| 457 | ! |
check.names = FALSE |
| 458 |
) |
|
| 459 |
} |
|
| 460 | ||
| 461 |
# catch Df.delta == 0 cases (reported by Florian Zsok in Zurich) |
|
| 462 |
# but only if there are no inequality constraints! (0.6-1) |
|
| 463 | ! |
idx <- which(val[, "Df diff"] == 0) |
| 464 | ! |
if (length(idx) > 0L) {
|
| 465 |
# remove models with inequality constraints |
|
| 466 | ! |
ineq.idx <- which(sapply(lapply(mods, function(x) |
| 467 | ! |
slot(slot(x, "Model"), "x.cin.idx")), length) > 0L) |
| 468 | ! |
rm.idx <- which(idx %in% ineq.idx) |
| 469 | ! |
if (length(rm.idx) > 0L) {
|
| 470 | ! |
idx <- idx[-rm.idx] |
| 471 |
} |
|
| 472 |
} |
|
| 473 | ! |
if (length(idx) > 0L) {
|
| 474 | ! |
val[idx, "Pr(>Chisq)"] <- as.numeric(NA) |
| 475 | ! |
lav_msg_warn(gettext("some models have the same degrees of freedom"))
|
| 476 |
} |
|
| 477 | ||
| 478 | ! |
if (type == "chisq") {
|
| 479 | ! |
if (scaled) {
|
| 480 | ! |
txt <- paste("The ", dQuote("Chisq"), " column contains standard ",
|
| 481 | ! |
"test statistics, not the robust test that should be ", |
| 482 | ! |
"reported per model. A robust difference test is a ", |
| 483 | ! |
"function of two standard (not robust) statistics.", |
| 484 | ! |
sep = "" |
| 485 |
) |
|
| 486 | ! |
attr(val, "heading") <- |
| 487 | ! |
paste("\nScaled Chi-Squared Difference Test (method = ",
|
| 488 | ! |
dQuote(method), ")\n\n", |
| 489 | ! |
lav_msg(paste("lavaan NOTE:", txt), showheader = TRUE),
|
| 490 | ! |
"\n", |
| 491 | ! |
sep = "" |
| 492 |
) |
|
| 493 | ! |
if (method == "satorra.2000" && scaled.shifted) {
|
| 494 | ! |
attr(val, "scale") <- a.delta |
| 495 | ! |
attr(val, "shift") <- b.delta |
| 496 | ! |
} else if (method %in% c("satorra.bentler.2001","satorra.bentler.2010",
|
| 497 | ! |
"satorra.2000")) {
|
| 498 | ! |
attr(val, "scale") <- c.delta |
| 499 |
} |
|
| 500 |
} else {
|
|
| 501 | ! |
attr(val, "heading") <- "\nChi-Squared Difference Test\n" |
| 502 |
} |
|
| 503 | ! |
} else if (type == "browne.residual.adf") {
|
| 504 | ! |
attr(val, "heading") <- "\nChi-Squared Difference Test based on Browne's residual (ADF) Test\n" |
| 505 | ! |
} else if (type == "browne.residual.nt") {
|
| 506 | ! |
attr(val, "heading") <- "\nChi-Squared Difference Test based on Browne's residual (NT) Test\n" |
| 507 | ! |
} else if (type == "cf") {
|
| 508 | ! |
colnames(val)[c(3, 4)] <- c("Cf", "Cf diff")
|
| 509 | ! |
attr(val, "heading") <- "\nCf Difference Test\n" |
| 510 |
} |
|
| 511 | ! |
class(val) <- c("anova", class(val))
|
| 512 | ||
| 513 | ! |
return(val) |
| 514 |
} |
|
| 515 | ||
| 516 | ||
| 517 |
# anova table for a single model |
|
| 518 |
lav_test_lrt_single_model <- function(object, method = "default", |
|
| 519 |
test = "default", type = "Chisq") {
|
|
| 520 | 40x |
estimator <- object@Options$estimator |
| 521 | ||
| 522 | 40x |
aic <- bic <- c(NA, NA) |
| 523 | 40x |
if (estimator == "ML") {
|
| 524 | 30x |
aic <- c(NA, AIC(object)) |
| 525 | 30x |
bic <- c(NA, BIC(object)) |
| 526 |
} |
|
| 527 | ||
| 528 |
## determine which @test element |
|
| 529 | 40x |
tn <- names(object@test) |
| 530 | 40x |
if (is.null(tn)) {
|
| 531 | ! |
tn <- "standard" # for lavaan <0.6 objects |
| 532 |
} |
|
| 533 | 40x |
if (length(tn) == 1L) {
|
| 534 | 36x |
TEST <- 1L # only choice |
| 535 | ||
| 536 |
## More than 1. Cycle through possible user specifications: |
|
| 537 | 4x |
} else if (method[1] == "standard") {
|
| 538 | ! |
TEST <- 1L |
| 539 | 4x |
} else if (grepl(pattern = "browne", x = type) && type %in% tn) {
|
| 540 | ! |
TEST <- type |
| 541 | 4x |
} else if (test %in% tn) {
|
| 542 | ! |
TEST <- test |
| 543 |
} else {
|
|
| 544 |
## Nothing explicitly (or validly) requested. |
|
| 545 |
## But there is > 1 test, so take the second element (old default) |
|
| 546 | 4x |
TEST <- 2L |
| 547 |
} |
|
| 548 | ||
| 549 |
## anova table |
|
| 550 | 40x |
val <- data.frame( |
| 551 | 40x |
Df = c(0, object@test[[TEST]]$df), |
| 552 | 40x |
AIC = aic, |
| 553 | 40x |
BIC = bic, |
| 554 | 40x |
Chisq = c(0, object@test[[TEST]]$stat), |
| 555 | 40x |
"Chisq diff" = c(NA, object@test[[TEST]]$stat), |
| 556 | 40x |
"Df diff" = c(NA, object@test[[TEST]]$df), |
| 557 | 40x |
"Pr(>Chisq)" = c(NA, object@test[[TEST]]$pvalue), |
| 558 | 40x |
row.names = c("Saturated", "Model"),
|
| 559 | 40x |
check.names = FALSE |
| 560 |
) |
|
| 561 |
## scale/shift attributes |
|
| 562 | 40x |
if (!is.null(object@test[[TEST]]$scaling.factor)) {
|
| 563 | 4x |
attr(val, "scale") <- c(NA, object@test[[TEST]]$scaling.factor) |
| 564 |
} |
|
| 565 | 40x |
if (!is.null(object@test[[TEST]]$shift.parameter)) {
|
| 566 | 2x |
attr(val, "shift") <- c(NA, object@test[[TEST]]$shift.parameter) |
| 567 |
} |
|
| 568 | ||
| 569 |
## heading |
|
| 570 | 40x |
if (grepl(pattern = "browne", x = TEST)) {
|
| 571 | ! |
attr(val, "heading") <- object@test[[TEST]]$label |
| 572 | ||
| 573 | 40x |
} else if (TEST == 1L) {
|
| 574 | 36x |
attr(val, "heading") <- "Chi-Squared Test Statistic (unscaled)\n" |
| 575 | ||
| 576 |
} else {
|
|
| 577 | 4x |
LABEL <- object@test[[TEST]]$label |
| 578 | 4x |
attr(val, "heading") <- paste0("Chi-Squared Test Statistic (scaled",
|
| 579 | 4x |
ifelse(TEST == "scaled.shifted", |
| 580 | 4x |
yes = " and shifted)", no = ")"), |
| 581 | 4x |
ifelse(is.null(LABEL), |
| 582 | 4x |
yes = "\n", no = paste("\n ", LABEL)),
|
| 583 | 4x |
"\n") |
| 584 |
} |
|
| 585 | ||
| 586 | 40x |
class(val) <- c("anova", class(val))
|
| 587 | ||
| 588 | 40x |
val |
| 589 |
} |
| 1 |
# simulate data starting from a user-specified model |
|
| 2 |
# |
|
| 3 |
# initial version: YR 24 jan 2011 |
|
| 4 |
# revision for 0.4-11: YR 21 okt 2011 |
|
| 5 |
# |
|
| 6 |
# |
|
| 7 |
# |
|
| 8 |
lav_data_simulate_old <- function( # user-specified model |
|
| 9 |
model = NULL, |
|
| 10 |
model.type = "sem", |
|
| 11 |
# model modifiers |
|
| 12 |
meanstructure = FALSE, |
|
| 13 |
int.ov.free = TRUE, |
|
| 14 |
int.lv.free = FALSE, |
|
| 15 |
marker.int.zero = FALSE, |
|
| 16 |
conditional.x = FALSE, |
|
| 17 |
composites = TRUE, |
|
| 18 |
fixed.x = FALSE, |
|
| 19 |
orthogonal = FALSE, |
|
| 20 |
std.lv = TRUE, |
|
| 21 |
auto.fix.first = FALSE, |
|
| 22 |
auto.fix.single = FALSE, |
|
| 23 |
auto.var = TRUE, |
|
| 24 |
auto.cov.lv.x = TRUE, |
|
| 25 |
auto.cov.y = TRUE, |
|
| 26 |
..., |
|
| 27 |
# data properties |
|
| 28 |
sample.nobs = 500L, |
|
| 29 |
ov.var = NULL, |
|
| 30 |
group.label = paste("G", 1:ngroups, sep = ""),
|
|
| 31 |
skewness = NULL, |
|
| 32 |
kurtosis = NULL, |
|
| 33 |
# control |
|
| 34 |
seed = NULL, |
|
| 35 |
empirical = FALSE, |
|
| 36 |
return.type = "data.frame", |
|
| 37 |
return.fit = FALSE, |
|
| 38 |
debug = FALSE, |
|
| 39 |
standardized = FALSE) {
|
|
| 40 | ! |
if (!missing(debug)) {
|
| 41 | ! |
current.debug <- lav_debug() |
| 42 | ! |
if (lav_debug(debug)) |
| 43 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 44 |
} |
|
| 45 | ! |
if (!is.null(seed)) set.seed(seed) |
| 46 |
# if(!exists(".Random.seed", envir = .GlobalEnv))
|
|
| 47 |
# runif(1) # initialize the RNG if necessary |
|
| 48 |
# RNGstate <- .Random.seed |
|
| 49 | ||
| 50 |
# lav_model_partable |
|
| 51 | ! |
if (is.list(model)) {
|
| 52 |
# two possibilities: either model is already lavaanified |
|
| 53 |
# or it is something else... |
|
| 54 | ! |
if (!is.null(model$lhs) && !is.null(model$op) && |
| 55 | ! |
!is.null(model$rhs) && !is.null(model$free)) {
|
| 56 | ! |
lav <- model |
| 57 | ||
| 58 |
# until 0.6-5, we only used the 'ustart' column |
|
| 59 |
# but what if 'lav' is a fitted lavaan object -> use 'est' |
|
| 60 | ! |
if (!is.null(lav$est)) {
|
| 61 | ! |
lav$ustart <- lav$est |
| 62 | ! |
lav$se <- NULL |
| 63 | ! |
lav$est <- NULL |
| 64 | ! |
lav$start <- NULL |
| 65 |
} |
|
| 66 | ! |
} else if (is.character(model[[1]])) {
|
| 67 | ! |
lav_msg_stop(gettext("model is a list, but not a parameterTable?"))
|
| 68 |
} |
|
| 69 |
} else {
|
|
| 70 | ! |
lav <- lav_model_partable( |
| 71 | ! |
model = model, |
| 72 | ! |
meanstructure = meanstructure, |
| 73 | ! |
int.ov.free = int.ov.free, |
| 74 | ! |
int.lv.free = int.lv.free, |
| 75 | ! |
marker.int.zero = marker.int.zero, |
| 76 | ! |
composites = composites, |
| 77 | ! |
conditional.x = conditional.x, |
| 78 | ! |
fixed.x = fixed.x, |
| 79 | ! |
orthogonal = orthogonal, |
| 80 | ! |
std.lv = std.lv, |
| 81 | ! |
auto.fix.first = auto.fix.first, |
| 82 | ! |
auto.fix.single = auto.fix.single, |
| 83 | ! |
auto.var = auto.var, |
| 84 | ! |
auto.cov.lv.x = auto.cov.lv.x, |
| 85 | ! |
auto.cov.y = auto.cov.y, |
| 86 | ! |
ngroups = length(sample.nobs) |
| 87 |
) |
|
| 88 |
} |
|
| 89 | ||
| 90 | ! |
group.values <- lav_partable_group_values(lav) |
| 91 | ! |
if (lav_debug()) {
|
| 92 | ! |
cat("initial lav\n")
|
| 93 | ! |
print(as.data.frame(lav)) |
| 94 |
} |
|
| 95 | ||
| 96 |
# fill in any remaining NA values (needed for unstandardize) |
|
| 97 |
# 1 for variances and (unstandardized) factor loadings, 0 otherwise |
|
| 98 | ! |
idx <- which(lav$op == "=~" & is.na(lav$ustart)) |
| 99 | ! |
if (length(idx) > 0L) {
|
| 100 | ! |
if (standardized) {
|
| 101 | ! |
lav$ustart[idx] <- 0.7 |
| 102 |
} else {
|
|
| 103 | ! |
lav$ustart[idx] <- 1.0 |
| 104 |
} |
|
| 105 |
} |
|
| 106 | ||
| 107 | ! |
idx <- which(lav$op == "~~" & is.na(lav$ustart) & lav$lhs == lav$rhs) |
| 108 | ! |
if (length(idx) > 0L) lav$ustart[idx] <- 1.0 |
| 109 | ||
| 110 | ! |
idx <- which(lav$op == "~" & is.na(lav$ustart)) |
| 111 | ! |
if (length(idx) > 0L) {
|
| 112 | ! |
lav_msg_warn(gettext( |
| 113 | ! |
"some regression coefficients are unspecified and will be set to zero")) |
| 114 |
} |
|
| 115 | ||
| 116 | ! |
idx <- which(is.na(lav$ustart)) |
| 117 | ! |
if (length(idx) > 0L) lav$ustart[idx] <- 0.0 |
| 118 | ||
| 119 | ! |
if (lav_debug()) {
|
| 120 | ! |
cat("lav + default values\n")
|
| 121 | ! |
print(as.data.frame(lav)) |
| 122 |
} |
|
| 123 | ||
| 124 |
# set residual variances to enforce a standardized solution |
|
| 125 |
# but only if no *residual* variances have been specified in the syntax |
|
| 126 | ||
| 127 | ! |
if (standardized) {
|
| 128 |
# check if factor loadings are smaller than 1.0 |
|
| 129 | ! |
lambda.idx <- which(lav$op == "=~") |
| 130 | ! |
if (any(lav$ustart[lambda.idx] >= 1.0)) {
|
| 131 | ! |
lav_msg_warn(gettext("standardized=TRUE but factor loadings are >= 1.0"))
|
| 132 |
} |
|
| 133 | ||
| 134 |
# check if regression coefficients are smaller than 1.0 |
|
| 135 | ! |
reg.idx <- which(lav$op == "~") |
| 136 | ! |
if (any(lav$ustart[reg.idx] >= 1.0)) {
|
| 137 | ! |
lav_msg_warn(gettext( |
| 138 | ! |
"standardized=TRUE but regression coefficients are >= 1.0")) |
| 139 |
} |
|
| 140 | ||
| 141 |
# for ordered observed variables, we will get '0.0', but that is ok |
|
| 142 |
# so there is no need to make a distinction between numeric/ordered |
|
| 143 |
# here?? |
|
| 144 | ! |
ngroups <- lav_partable_ngroups(lav) |
| 145 | ! |
ov.names <- lav_partable_vnames(lav, "ov") |
| 146 | ! |
ov.nox <- lav_partable_vnames(lav, "ov.nox") |
| 147 | ! |
lv.names <- lav_partable_vnames(lav, "lv") |
| 148 | ! |
lv.y <- lav_partable_vnames(lav, "lv.y") |
| 149 | ! |
lv.nox <- lav_partable_vnames(lav, "lv.nox") |
| 150 | ! |
ov.var.idx <- which(lav$op == "~~" & lav$lhs %in% ov.nox & |
| 151 | ! |
lav$rhs == lav$lhs) |
| 152 | ! |
lv.var.idx <- which(lav$op == "~~" & lav$lhs %in% lv.nox & |
| 153 | ! |
lav$rhs == lav$lhs) |
| 154 | ! |
if (any(lav$user[c(ov.var.idx, lv.var.idx)] > 0L)) {
|
| 155 | ! |
lav_msg_warn(gettext( |
| 156 | ! |
"if residual variances are specified, please use standardized=FALSE")) |
| 157 |
} |
|
| 158 | ||
| 159 |
# new in 0.6-20: - use lav_lisrel_residual_variances |
|
| 160 |
# - use lav_lisrel_composites_variances |
|
| 161 | ! |
dotdotdot <- list(...) |
| 162 | ! |
dotdotdot$sample.nobs <- sample.nobs |
| 163 | ! |
dotdotdot$fixed.x <- FALSE # for now |
| 164 | ! |
dotdotdot$representation <- "LISREL" |
| 165 | ! |
dotdotdot$composites <- composites |
| 166 | ! |
dotdotdot$correlation <- TRUE # this is the trick |
| 167 | ! |
tmp.fit <- do.call("lavaan", args = c(list(model = lav), dotdotdot))
|
| 168 |
# set/get parameters to invoke lav_lisrel_residual_variances |
|
| 169 | ! |
tmp.lav <- tmp.fit@ParTable |
| 170 | ! |
tmp.x <- lav_model_get_parameters(tmp.fit@Model) |
| 171 | ! |
tmp.model <- lav_model_set_parameters(tmp.fit@Model, x = tmp.x) |
| 172 | ! |
tmp.lav$ustart <- lav_model_get_parameters(tmp.model, type = "user") |
| 173 | ||
| 174 |
# copy residual values to lav (without assuming parameter tables look the |
|
| 175 |
# same) |
|
| 176 | ! |
res.idx <- c(ov.var.idx, lv.var.idx) |
| 177 | ! |
for (i in seq_len(length(res.idx))) {
|
| 178 |
# lookup this parameter in tmp.lav |
|
| 179 | ! |
idx.in.lav <- res.idx[i] |
| 180 | ! |
this.lhs <- lav$lhs[idx.in.lav] |
| 181 | ! |
idx.in.tmp <- which(tmp.lav$op == "~~" & tmp.lav$lhs == this.lhs & |
| 182 | ! |
tmp.lav$rhs == tmp.lav$lhs) |
| 183 | ! |
if (length(idx.in.tmp) == 0L) {
|
| 184 |
# hm, not found? Give a warning? |
|
| 185 |
} else {
|
|
| 186 | ! |
vals <- tmp.lav$ustart[idx.in.tmp] |
| 187 |
# check if we have unfortunate values |
|
| 188 | ! |
bad.idx <- which(!is.finite(vals) | vals < 0) |
| 189 | ! |
vals[bad.idx] <- 1.0 # not pretty, but safe |
| 190 | ! |
lav$ustart[idx.in.lav] <- vals |
| 191 |
} |
|
| 192 |
} |
|
| 193 | ||
| 194 |
# this is what we did <0.6-20 |
|
| 195 |
# fit <- lavaan(model = lav, sample.nobs = sample.nobs, ...) |
|
| 196 |
# Sigma.hat <- lav_model_sigma(lavmodel = fit@Model) |
|
| 197 |
# ETA <- lav_model_veta(lavmodel = fit@Model) |
|
| 198 | ||
| 199 |
# if (lav_debug()) {
|
|
| 200 |
# cat("Sigma.hat:\n")
|
|
| 201 |
# print(Sigma.hat) |
|
| 202 |
# cat("Eta:\n")
|
|
| 203 |
# print(ETA) |
|
| 204 |
# } |
|
| 205 | ||
| 206 |
# # stage 1: standardize LV |
|
| 207 |
# if (length(lv.nox) > 0L) {
|
|
| 208 |
# for (g in 1:ngroups) {
|
|
| 209 |
# var.group <- which(lav$op == "~~" & lav$lhs %in% lv.nox & |
|
| 210 |
# lav$rhs == lav$lhs & |
|
| 211 |
# lav$group == group.values[g]) |
|
| 212 |
# eta.idx <- match(lv.nox, lv.names) |
|
| 213 |
# lav$ustart[var.group] <- 1 - diag(ETA[[g]])[eta.idx] |
|
| 214 |
# } |
|
| 215 |
# } |
|
| 216 |
# # refit |
|
| 217 |
# fit <- lavaan(model = lav, sample.nobs = sample.nobs, ...) |
|
| 218 |
# Sigma.hat <- lav_model_sigma(lavmodel = fit@Model) |
|
| 219 | ||
| 220 |
# if (lav_debug()) {
|
|
| 221 |
# cat("after stage 1:\n")
|
|
| 222 |
# cat("Sigma.hat:\n")
|
|
| 223 |
# print(Sigma.hat) |
|
| 224 |
# } |
|
| 225 | ||
| 226 |
# # stage 2: standardize OV |
|
| 227 |
# for (g in 1:ngroups) {
|
|
| 228 |
# var.group <- which(lav$op == "~~" & lav$lhs %in% ov.nox & |
|
| 229 |
# lav$rhs == lav$lhs & |
|
| 230 |
# lav$group == group.values[g]) |
|
| 231 |
# ov.idx <- match(ov.nox, ov.names) |
|
| 232 |
# lav$ustart[var.group] <- 1 - diag(Sigma.hat[[g]])[ov.idx] |
|
| 233 |
# } |
|
| 234 | ||
| 235 |
# if (lav_debug()) {
|
|
| 236 |
# cat("after standardisation lav\n")
|
|
| 237 |
# print(as.data.frame(lav)) |
|
| 238 |
# } |
|
| 239 |
} |
|
| 240 | ||
| 241 | ||
| 242 |
# unstandardize |
|
| 243 | ! |
if (!is.null(ov.var)) {
|
| 244 |
# FIXME: if ov.var is named, check the order of the elements |
|
| 245 | ||
| 246 |
# 1. unstandardize observed variables |
|
| 247 | ! |
lav$ustart <- lav_unstandardize_ov(partable = lav, ov.var = ov.var) |
| 248 | ||
| 249 |
# 2. unstandardized latent variables |
|
| 250 | ||
| 251 | ! |
if (lav_debug()) {
|
| 252 | ! |
cat("after unstandardisation lav\n")
|
| 253 | ! |
print(as.data.frame(lav)) |
| 254 |
} |
|
| 255 |
} |
|
| 256 | ||
| 257 |
# fit the model without data |
|
| 258 | ! |
fit <- lavaan(model = lav, sample.nobs = sample.nobs, ...) |
| 259 | ||
| 260 |
# the model-implied moments for the population |
|
| 261 | ! |
Sigma.hat <- lav_model_sigma(lavmodel = fit@Model) |
| 262 | ! |
Mu.hat <- lav_model_mu(lavmodel = fit@Model) |
| 263 | ! |
if (fit@Model@categorical) {
|
| 264 | ! |
TH <- lav_model_th(lavmodel = fit@Model) |
| 265 |
} |
|
| 266 | ||
| 267 | ! |
if (lav_debug()) {
|
| 268 | ! |
cat("\nModel-implied moments (before Vale-Maurelli):\n")
|
| 269 | ! |
print(Sigma.hat) |
| 270 | ! |
print(Mu.hat) |
| 271 | ! |
if (exists("TH")) print(TH)
|
| 272 |
} |
|
| 273 | ||
| 274 |
# ngroups |
|
| 275 | ! |
ngroups <- length(sample.nobs) |
| 276 | ||
| 277 |
# prepare |
|
| 278 | ! |
X <- vector("list", length = ngroups)
|
| 279 | ! |
out <- vector("list", length = ngroups)
|
| 280 | ||
| 281 | ! |
for (g in 1:ngroups) {
|
| 282 | ! |
COV <- Sigma.hat[[g]] |
| 283 | ||
| 284 |
# if empirical = TRUE, rescale by N/(N-1), so that estimator=ML |
|
| 285 |
# returns exact results |
|
| 286 | ! |
if (empirical) {
|
| 287 | ! |
COV <- COV * sample.nobs[g] / (sample.nobs[g] - 1) |
| 288 |
} |
|
| 289 | ||
| 290 |
# Using sign-invariant method for cross-machine reproducibility |
|
| 291 | ! |
if (is.null(skewness) && is.null(kurtosis)) {
|
| 292 | ! |
X[[g]] <- lav_mvrnorm( |
| 293 | ! |
n = sample.nobs[g], |
| 294 | ! |
mu = Mu.hat[[g]], |
| 295 | ! |
Sigma = COV, |
| 296 | ! |
empirical = empirical |
| 297 |
) |
|
| 298 |
} else {
|
|
| 299 |
# first generate Z |
|
| 300 | ! |
Z <- lav_data_valemaurelli1983( |
| 301 | ! |
n = sample.nobs[g], |
| 302 | ! |
COR = cov2cor(COV), |
| 303 | ! |
skewness = skewness, # FIXME: per group? |
| 304 | ! |
kurtosis = kurtosis |
| 305 |
) |
|
| 306 |
# rescale |
|
| 307 |
# Note: 'scale()' will first center, and then scale |
|
| 308 |
# but we need to first scale, and then center... |
|
| 309 |
# this was reported by Jordan Brace (9 may 2014) |
|
| 310 |
# X[[g]] <- scale(Z, center = -Mu.hat[[g]], |
|
| 311 |
# scale = 1/sqrt(diag(COV))) |
|
| 312 | ||
| 313 |
# first, we scale |
|
| 314 | ! |
TMP <- scale(Z, |
| 315 | ! |
center = FALSE, |
| 316 | ! |
scale = 1 / sqrt(diag(COV)) |
| 317 | ! |
)[, , drop = FALSE] |
| 318 | ||
| 319 |
# then, we center |
|
| 320 | ! |
X[[g]] <- sweep(TMP, MARGIN = 2, STATS = Mu.hat[[g]], FUN = "+") |
| 321 |
} |
|
| 322 | ||
| 323 |
# any categorical variables? |
|
| 324 | ! |
ov.ord <- lav_partable_vnames(lav, type = "ov.ord", group = group.values[g]) |
| 325 | ! |
if (length(ov.ord) > 0L) {
|
| 326 | ! |
ov.names <- lav_partable_vnames(lav, type = "ov", group = group.values[g]) |
| 327 |
# use thresholds to cut |
|
| 328 | ! |
for (o in ov.ord) {
|
| 329 | ! |
o.idx <- which(o == ov.names) |
| 330 | ! |
th.idx <- which(lav$op == "|" & lav$lhs == o & |
| 331 | ! |
lav$group == group.values[g]) |
| 332 | ! |
th.val <- c(-Inf, sort(lav$ustart[th.idx]), +Inf) |
| 333 | ! |
X[[g]][, o.idx] <- as.integer(cut(X[[g]][, o.idx], th.val)) |
| 334 |
} |
|
| 335 |
} |
|
| 336 | ||
| 337 | ! |
if (return.type == "data.frame") X[[g]] <- as.data.frame(X[[g]]) |
| 338 |
} |
|
| 339 | ||
| 340 | ! |
if (return.type == "matrix") {
|
| 341 | ! |
if (ngroups == 1L) {
|
| 342 | ! |
return(X[[1L]]) |
| 343 |
} else {
|
|
| 344 | ! |
return(X) |
| 345 |
} |
|
| 346 | ! |
} else if (return.type == "data.frame") {
|
| 347 | ! |
Data <- X[[1L]] |
| 348 | ||
| 349 |
# if multiple groups, add group column |
|
| 350 | ! |
if (ngroups > 1L) {
|
| 351 | ! |
for (g in 2:ngroups) {
|
| 352 | ! |
Data <- rbind(Data, X[[g]]) |
| 353 |
} |
|
| 354 | ! |
Data$group <- rep(1:ngroups, times = sample.nobs) |
| 355 |
} |
|
| 356 | ! |
var.names <- lav_partable_vnames(fit@ParTable, type = "ov", group = 1L) |
| 357 | ! |
if (ngroups > 1L) var.names <- c(var.names, "group") |
| 358 | ! |
names(Data) <- var.names |
| 359 | ! |
if (return.fit) {
|
| 360 | ! |
attr(Data, "fit") <- fit |
| 361 |
} |
|
| 362 | ! |
return(Data) |
| 363 | ! |
} else if (return.type == "cov") {
|
| 364 | ! |
if (ngroups == 1L) {
|
| 365 | ! |
return(cov(X[[1L]])) |
| 366 |
} else {
|
|
| 367 | ! |
cov.list <- lapply(X, cov) |
| 368 | ! |
return(cov.list) |
| 369 |
} |
|
| 370 |
} |
|
| 371 |
} |
|
| 372 |
lavSimulateData <- lav_data_simulate_old # synonym #nolint |
|
| 373 | ||
| 374 |
lav_skewness <- function(x., N1 = TRUE) {
|
|
| 375 | ! |
x <- x. |
| 376 | ! |
x <- x[!is.na(x)] |
| 377 | ! |
N <- length(x) |
| 378 | ! |
mean.x <- mean(x) |
| 379 | ! |
xc <- x - mean.x |
| 380 | ! |
var.x <- var(x) |
| 381 | ! |
if (!N1) var.x <- var.x * (N - 1) / N |
| 382 | ! |
sd.x <- sqrt(var.x) |
| 383 | ! |
sk <- sum(xc * xc * xc) / (sd.x * sd.x * sd.x) |
| 384 | ! |
skewness <- N * sk / ((N - 1) * (N - 2)) |
| 385 | ! |
skewness |
| 386 |
} |
|
| 387 | ||
| 388 |
lav_kurtosis <- function(x., N1 = TRUE) {
|
|
| 389 | ! |
x <- x. |
| 390 | ! |
x <- x[!is.na(x)] |
| 391 | ! |
N <- length(x) |
| 392 | ! |
mean.x <- mean(x) |
| 393 | ! |
xc <- x - mean.x |
| 394 | ! |
var.x <- var(x) |
| 395 | ! |
if (!N1) var.x <- var.x * (N - 1) / N |
| 396 | ! |
k <- sum(xc * xc * xc * xc) / (var.x * var.x) |
| 397 | ! |
kurtosis <- N * (N + 1) * k / ((N - 1) * (N - 2) * (N - 3)) - 3 * (N - 1) * (N - 1) / ((N - 2) * (N - 3)) |
| 398 | ! |
kurtosis |
| 399 |
} |
|
| 400 | ||
| 401 | ||
| 402 | ||
| 403 |
lav_data_valemaurelli1983 <- function(n = 100L, COR, skewness, kurtosis) {
|
|
| 404 | ! |
fleishman1978_abcd <- function(skewness, kurtosis) {
|
| 405 | ! |
system.function <- function(x, skewness, kurtosis) {
|
| 406 | ! |
b. <- x[1L] |
| 407 | ! |
c. <- x[2L] |
| 408 | ! |
d. <- x[3L] |
| 409 | ! |
eq1 <- b. * b. + 6 * b. * d. + 2 * c. * c. + 15 * d. * d. - 1 |
| 410 | ! |
eq2 <- 2 * c. * (b. * b. + 24 * b. * d. + 105 * d. * d. + 2) - skewness |
| 411 | ! |
eq3 <- 24 * (b. * d. + c. * c. * (1 + b. * b. + 28 * b. * d.) + |
| 412 | ! |
d. * d. * (12 + 48 * b. * d. + 141 * c. * c. + 225 * d. * d.)) - kurtosis |
| 413 | ! |
eq <- c(eq1, eq2, eq3) |
| 414 | ! |
sum(eq * eq) ## SS |
| 415 |
} |
|
| 416 | ||
| 417 | ! |
out <- nlminb( |
| 418 | ! |
start = c(1, 0, 0), objective = system.function, |
| 419 | ! |
scale = 10, |
| 420 | ! |
control = list(trace = 0), |
| 421 | ! |
skewness = skewness, kurtosis = kurtosis |
| 422 |
) |
|
| 423 | ! |
if (out$convergence != 0 || out$objective > 1e-5) {
|
| 424 | ! |
lav_msg_warn(gettext("lav_data_valemaurelli1983 method did not convergence,
|
| 425 | ! |
or it did not find the roots")) |
| 426 |
} |
|
| 427 | ! |
b. <- out$par[1L] |
| 428 | ! |
c. <- out$par[2L] |
| 429 | ! |
d. <- out$par[3L] |
| 430 | ! |
a. <- -c. |
| 431 | ! |
c(a., b., c., d.) |
| 432 |
} |
|
| 433 | ||
| 434 | ! |
getICOV <- function(b1, c1, d1, b2, c2, d2, R) {
|
| 435 | ! |
objectiveFunction <- function(x, b1, c1, d1, b2, c2, d2, R) {
|
| 436 | ! |
rho <- x[1L] |
| 437 | ! |
eq <- rho * (b1 * b2 + 3 * b1 * d2 + 3 * d1 * b2 + 9 * d1 * d2) + |
| 438 | ! |
rho * rho * (2 * c1 * c2) + rho * rho * rho * (6 * d1 * d2) - R |
| 439 | ! |
eq * eq |
| 440 |
} |
|
| 441 | ||
| 442 |
# gradientFunction <- function(x, bcd1, bcd2, R) {
|
|
| 443 |
# |
|
| 444 |
# } |
|
| 445 | ||
| 446 | ! |
out <- nlminb( |
| 447 | ! |
start = R, objective = objectiveFunction, |
| 448 | ! |
scale = 10, control = list(trace = 0), |
| 449 | ! |
b1 = b1, c1 = c1, d1 = d1, b2 = b2, c2 = c2, d2 = d2, R = R |
| 450 |
) |
|
| 451 | ! |
if (out$convergence != 0 || out$objective > 1e-5) |
| 452 | ! |
lav_msg_warn(gettext("no convergence"))
|
| 453 | ! |
rho <- out$par[1L] |
| 454 | ! |
rho |
| 455 |
} |
|
| 456 | ||
| 457 |
# number of variables |
|
| 458 | ! |
nvar <- ncol(COR) |
| 459 |
# check skewness |
|
| 460 | ! |
if (is.null(skewness)) {
|
| 461 | ! |
SK <- rep(0, nvar) |
| 462 | ! |
} else if (length(skewness) == nvar) {
|
| 463 | ! |
SK <- skewness |
| 464 | ! |
} else if (length(skewness) == 1L) {
|
| 465 | ! |
SK <- rep(skewness, nvar) |
| 466 |
} else {
|
|
| 467 | ! |
lav_msg_stop(gettext("skewness has wrong length"))
|
| 468 |
} |
|
| 469 | ||
| 470 | ! |
if (is.null(kurtosis)) {
|
| 471 | ! |
KU <- rep(0, nvar) |
| 472 | ! |
} else if (length(kurtosis) == nvar) {
|
| 473 | ! |
KU <- kurtosis |
| 474 | ! |
} else if (length(kurtosis) == 1L) {
|
| 475 | ! |
KU <- rep(kurtosis, nvar) |
| 476 |
} else {
|
|
| 477 | ! |
lav_msg_stop(gettext("kurtosis has wrong length"))
|
| 478 |
} |
|
| 479 | ||
| 480 |
# create Fleishman table |
|
| 481 | ! |
FTable <- matrix(0, nvar, 4L) |
| 482 | ! |
for (i in 1:nvar) {
|
| 483 | ! |
FTable[i, ] <- fleishman1978_abcd(skewness = SK[i], kurtosis = KU[i]) |
| 484 |
} |
|
| 485 | ||
| 486 |
# compute intermediate correlations between all pairs |
|
| 487 | ! |
ICOR <- diag(nvar) |
| 488 | ! |
for (j in 1:(nvar - 1L)) {
|
| 489 | ! |
for (i in (j + 1):nvar) {
|
| 490 | ! |
if (COR[i, j] == 0) next |
| 491 | ! |
ICOR[i, j] <- ICOR[j, i] <- |
| 492 | ! |
getICOV(FTable[i, 2], FTable[i, 3], FTable[i, 4], |
| 493 | ! |
FTable[j, 2], FTable[j, 3], FTable[j, 4], |
| 494 | ! |
R = COR[i, j] |
| 495 |
) |
|
| 496 |
} |
|
| 497 |
} |
|
| 498 | ||
| 499 | ! |
if (lav_debug()) {
|
| 500 | ! |
cat("\nOriginal correlations (for Vale-Maurelli):\n")
|
| 501 | ! |
print(COR) |
| 502 | ! |
cat("\nIntermediate correlations (for Vale-Maurelli):\n")
|
| 503 | ! |
print(ICOR) |
| 504 | ! |
cat("\nEigen values ICOR:\n")
|
| 505 | ! |
print(eigen(ICOR)$values) |
| 506 |
} |
|
| 507 | ||
| 508 |
# generate Z (using sign-invariant method for cross-machine reproducibility) |
|
| 509 | ! |
X <- Z <- lav_mvrnorm(n = n, mu = rep(0, nvar), Sigma = ICOR) |
| 510 | ||
| 511 |
# transform Z using Fleishman constants |
|
| 512 | ! |
for (i in 1:nvar) {
|
| 513 | ! |
X[, i] <- FTable[i, 1L] + FTable[i, 2L] * Z[, i] + FTable[i, 3L] * Z[, i] * Z[, i] + |
| 514 | ! |
FTable[i, 4L] * Z[, i] * Z[, i] * Z[, i] |
| 515 |
} |
|
| 516 | ||
| 517 | ! |
X |
| 518 |
} |
| 1 |
# step 1 in SAM: fitting the measurement blocks |
|
| 2 | ||
| 3 |
lav_sam_step1 <- function(cmd = "sem", mm.list = NULL, mm.args = list(), |
|
| 4 |
FIT = FIT, sam.method = "local") {
|
|
| 5 | ! |
lavoptions <- FIT@Options |
| 6 | ! |
lavpta <- FIT@pta |
| 7 | ! |
PT <- FIT@ParTable |
| 8 | ! |
nblocks <- lavpta$nblocks |
| 9 | ! |
ngroups <- lavpta$ngroups |
| 10 | ||
| 11 | ! |
if (lav_verbose()) {
|
| 12 | ! |
cat("Fitting the measurement part:\n")
|
| 13 |
} |
|
| 14 | ||
| 15 |
# local only -> handle missing data |
|
| 16 |
# if (sam.method %in% c("local", "fsr")) {
|
|
| 17 |
# # if missing = "listwise", make data complete, to avoid different |
|
| 18 |
# # datasets per measurement block |
|
| 19 |
# if (lavoptions$missing == "listwise") {
|
|
| 20 |
# # FIXME: make this work for multiple groups!! |
|
| 21 |
# OV <- unique(unlist(FIT@pta$vnames$ov)) |
|
| 22 |
# # add group/cluster/sample.weights variables (if any) |
|
| 23 |
# OV <- c( |
|
| 24 |
# OV, FIT@Data@group, FIT@Data@cluster, |
|
| 25 |
# FIT@Data@sampling.weights |
|
| 26 |
# ) |
|
| 27 |
# data <- na.omit(data[, OV]) |
|
| 28 |
# } |
|
| 29 |
# } |
|
| 30 | ||
| 31 |
# total number of free parameters |
|
| 32 | ! |
if (FIT@Model@ceq.simple.only) {
|
| 33 | ! |
npar <- FIT@Model@nx.unco |
| 34 | ! |
PT.free <- PT$free |
| 35 | ! |
PT.free[PT.free > 0] <- seq_len(npar) |
| 36 |
} else {
|
|
| 37 | ! |
npar <- FIT@Model@nx.free |
| 38 | ! |
PT.free <- PT$free |
| 39 |
} |
|
| 40 | ! |
if (npar < 1L) {
|
| 41 | ! |
lav_msg_stop(gettext("model does not contain any free parameters"))
|
| 42 |
} |
|
| 43 | ||
| 44 |
# do we have at least 1 'regular' (measured) latent variable? |
|
| 45 | ! |
LV.names <- unique(unlist(FIT@pta$vnames$lv.regular)) |
| 46 | ||
| 47 | ! |
eqs.x <- unlist(FIT@pta$vnames$eqs.x) |
| 48 | ! |
eqs.y <- unlist(FIT@pta$vnames$eqs.y) |
| 49 | ||
| 50 |
#if (length(eqs.x) == 0L && length(eqs.y) == 0L) {
|
|
| 51 |
# lav_msg_warn(gettext("the model does seem to contain a structural part
|
|
| 52 |
# (i.e., regressions); consider using sem() instead")) |
|
| 53 |
#} else |
|
| 54 | ! |
if (length(LV.names) == 0L) {
|
| 55 | ! |
lav_msg_warn(gettext("structural model does not contain any (measured)
|
| 56 | ! |
latent variables; consider using sem() instead")) |
| 57 |
} |
|
| 58 | ||
| 59 |
# check for higher-order factors |
|
| 60 |
# 0.6-20: now we do! |
|
| 61 | ! |
LV.IND.names <- unique(unlist(FIT@pta$vnames$lv.ind)) |
| 62 | ! |
lv.higherorder.flag <- FALSE |
| 63 | ! |
if (length(LV.IND.names) > 0L) {
|
| 64 | ! |
lv.higherorder.flag <- TRUE |
| 65 | ! |
LV.names <- LV.names[!LV.names %in% LV.IND.names] |
| 66 |
} |
|
| 67 | ||
| 68 |
# how many measurement models? |
|
| 69 | ! |
if (!is.null(mm.list)) {
|
| 70 | ! |
nMMblocks <- length(mm.list) |
| 71 |
# check each measurement block |
|
| 72 | ! |
for (b in seq_len(nMMblocks)) {
|
| 73 |
# check if we can find all lv names in LV.names |
|
| 74 | ! |
if (!all(unlist(mm.list[[b]]) %in% LV.names)) {
|
| 75 | ! |
tmp <- unlist(mm.list[[b]]) |
| 76 | ! |
lav_msg_stop(gettext("mm.list contains unknown latent variable(s):"),
|
| 77 | ! |
lav_msg_view(tmp[!tmp %in% LV.names], "none")) |
| 78 |
} |
|
| 79 |
# make list per block |
|
| 80 | ! |
if (!is.list(mm.list[[b]])) {
|
| 81 | ! |
mm.list[[b]] <- rep(list(mm.list[[b]]), nblocks) |
| 82 |
} else {
|
|
| 83 | ! |
if (length(mm.list[[b]]) != nblocks) {
|
| 84 | ! |
lav_msg_stop(gettextf( |
| 85 | ! |
"mm.list block %1$s has length %2$s but nblocks = %3$s", |
| 86 | ! |
b, length(mm.list[[b]]), nblocks)) |
| 87 |
} |
|
| 88 |
} |
|
| 89 |
} |
|
| 90 |
} else {
|
|
| 91 | ! |
mm.list.per.block <- lav_sam_get_mmlist(FIT) |
| 92 |
# we get a list PER BLOCK |
|
| 93 |
# for now, we only keep the first block |
|
| 94 | ! |
mm.list <- mm.list.per.block[[1]] |
| 95 | ! |
nMMblocks <- length(mm.list) |
| 96 |
} |
|
| 97 | ||
| 98 |
# adjust options for measurement models |
|
| 99 | ! |
lavoptions.mm <- lavoptions |
| 100 | ! |
lavoptions.mm$optim.bounds <- NULL |
| 101 | ! |
if (lavoptions$se %in% c("none", "bootstrap")) {
|
| 102 | ! |
lavoptions.mm$se <- "none" |
| 103 |
} else {
|
|
| 104 |
# categorical? |
|
| 105 | ! |
if (FIT@Model@categorical) {
|
| 106 | ! |
lavoptions.mm$se <- "robust.sem" |
| 107 | ! |
} else if (lavoptions$estimator.orig == "MLM") {
|
| 108 | ! |
lavoptions.mm$se <- "robust.sem" |
| 109 | ! |
} else if (lavoptions$estimator.orig == "MLR") {
|
| 110 | ! |
lavoptions.mm$se <- "robust.huber.white" |
| 111 | ! |
} else if (lavoptions$estimator.orig == "PML") {
|
| 112 | ! |
lavoptions.mm$se <- "robust.huber.white" |
| 113 |
} else {
|
|
| 114 | ! |
lavoptions.mm$se <- "standard" # may be overriden later |
| 115 |
} |
|
| 116 |
} |
|
| 117 |
# if(sam.method == "global") {
|
|
| 118 |
# lavoptions.mm$test <- "none" |
|
| 119 |
# } |
|
| 120 |
# we need the tests to create summary info about MM |
|
| 121 | ! |
lavoptions.mm$check.post <- FALSE # neg lv variances may be overriden |
| 122 | ! |
lavoptions.mm$check.gradient <- FALSE # too sensitive in large model (global) |
| 123 | ! |
lavoptions.mm$baseline <- FALSE |
| 124 | ! |
lavoptions.mm$bounds <- "wide.zerovar" |
| 125 | ||
| 126 |
# ALWAYS conditional.x = FALSE! |
|
| 127 |
# even if global model uses conditional.x = TRUE |
|
| 128 |
# this should not affect the measurement models (if the covariates act on |
|
| 129 |
# the structural part only) |
|
| 130 | ! |
lavoptions.mm$conditional.x = FALSE |
| 131 | ||
| 132 |
# override with user-specified mm.args |
|
| 133 | ! |
lavoptions.mm <- modifyList(lavoptions.mm, mm.args) |
| 134 | ||
| 135 |
# create MM slotOptions |
|
| 136 | ! |
slotOptions.mm <- lav_options_set(lavoptions.mm) |
| 137 | ||
| 138 |
# we assume the same number/names of lv's per group!!! |
|
| 139 | ! |
MM.FIT <- vector("list", nMMblocks) # fitted object
|
| 140 | ||
| 141 |
# for joint model later |
|
| 142 | ! |
if (!lavoptions$se %in% c("none", "bootstrap")) {
|
| 143 | ! |
Sigma.11 <- matrix(0, npar, npar) |
| 144 | ! |
colnames(Sigma.11) <- rownames(Sigma.11) <- |
| 145 | ! |
lav_partable_labels(FIT@ParTable, type = "free") |
| 146 |
} |
|
| 147 | ! |
step1.free.idx <- integer(0L) |
| 148 | ! |
block.mm.idx <- vector("list", length = nMMblocks)
|
| 149 | ! |
block.ptm.idx <- vector("list", length = nMMblocks)
|
| 150 | ||
| 151 |
# NOTE: we should explicitly add zero-constrained LV covariances |
|
| 152 |
# to PT, and keep them zero in PTM |
|
| 153 | ! |
if (cmd == "lavaan") {
|
| 154 | ! |
add.lv.cov <- FALSE |
| 155 |
} else {
|
|
| 156 | ! |
add.lv.cov <- TRUE |
| 157 |
} |
|
| 158 | ||
| 159 |
# fit mm model for each measurement block |
|
| 160 | ! |
for (mm in seq_len(nMMblocks)) {
|
| 161 | ! |
if (lav_verbose()) {
|
| 162 | ! |
cat( |
| 163 | ! |
" block ", mm, "[", |
| 164 | ! |
paste(mm.list[[mm]], collapse = " "), "]\n" |
| 165 |
) |
|
| 166 |
} |
|
| 167 | ||
| 168 |
# create parameter table for this measurement block only |
|
| 169 | ! |
PTM <- lav_partable_subset_measurement_model( |
| 170 | ! |
PT = PT, |
| 171 | ! |
add.lv.cov = add.lv.cov, |
| 172 | ! |
add.idx = TRUE, |
| 173 | ! |
lv.names = mm.list[[mm]], |
| 174 |
) |
|
| 175 | ! |
mm.idx <- attr(PTM, "idx") |
| 176 | ! |
attr(PTM, "idx") <- NULL |
| 177 | ! |
PTM$est <- NULL |
| 178 | ! |
PTM$se <- NULL |
| 179 | ! |
block.mm.idx[[mm]] <- mm.idx |
| 180 | ||
| 181 |
# check for categorical in PTM in this mm-block |
|
| 182 | ! |
if (!any(PTM$op == "|")) {
|
| 183 | ! |
slotOptions.mm$categorical <- FALSE |
| 184 | ! |
slotOptions.mm$.categorical <- FALSE |
| 185 |
} |
|
| 186 | ||
| 187 |
# update slotData for this measurement block |
|
| 188 | ! |
ov.names.block <- lapply(1:ngroups, function(g) {
|
| 189 | ! |
unique(unlist(lav_partable_vnames(PTM, type = "ov", group = g))) |
| 190 |
}) |
|
| 191 | ! |
slotData.block <- lav_data_update_subset(FIT@Data, |
| 192 | ! |
ov.names = ov.names.block |
| 193 |
) |
|
| 194 |
# get rid of ov.names.x |
|
| 195 | ! |
if (!slotOptions.mm$conditional.x) {
|
| 196 | ! |
slotData.block@ov.names.x <- |
| 197 | ! |
lapply(seq_len(nblocks), function(x) character(0L)) |
| 198 | ! |
slotData.block@eXo <- |
| 199 | ! |
lapply(seq_len(nblocks), function(x) NULL) |
| 200 |
} |
|
| 201 | ||
| 202 |
# if data.type == "moment", (re)create sample.cov and sample.nobs |
|
| 203 | ! |
if (FIT@Data@data.type == "moment") {
|
| 204 | ! |
if (ngroups == 1L) {
|
| 205 | ! |
mm.sample.cov <- lavInspect(FIT, "h1")$cov |
| 206 | ! |
mm.sample.mean <- NULL |
| 207 | ! |
if (FIT@Model@meanstructure) {
|
| 208 | ! |
mm.sample.mean <- lavInspect(FIT, "h1")$mean |
| 209 |
} |
|
| 210 | ! |
mm.sample.nobs <- FIT@SampleStats@nobs[[1L]] |
| 211 |
} else {
|
|
| 212 | ! |
cov.list <- lapply(lavTech(FIT, "h1", add.labels = TRUE), |
| 213 | ! |
"[[", "cov") |
| 214 | ! |
mm.sample.cov <- lapply(seq_len(ngroups), |
| 215 | ! |
function(x) cov.list[[x]][ov.names.block[[x]], ov.names.block[[x]]]) |
| 216 | ! |
mm.sample.mean <- NULL |
| 217 | ! |
if (FIT@Model@meanstructure) {
|
| 218 | ! |
mean.list <- lapply(lavTech(FIT, "h1", add.labels = TRUE), |
| 219 | ! |
"[[", "mean") |
| 220 | ! |
mm.sample.mean <- lapply(seq_len(ngroups), |
| 221 | ! |
function(x) mean.list[[x]][ov.names.block[[x]]]) |
| 222 |
} |
|
| 223 | ! |
mm.sample.nobs <- FIT@SampleStats@nobs |
| 224 |
} |
|
| 225 |
} |
|
| 226 | ||
| 227 | ||
| 228 |
# handle single block 1-factor CFA with (only) two indicators |
|
| 229 | ! |
if (length(unlist(ov.names.block)) == 2L && ngroups == 1L) {
|
| 230 | ! |
lambda.idx <- which(PTM$op == "=~") |
| 231 |
# check if both factor loadings are fixed |
|
| 232 |
# (note: this assumes std.lv = FALSE) |
|
| 233 | ! |
if(any(PTM$free[lambda.idx] != 0)) {
|
| 234 | ! |
PTM$free[ lambda.idx] <- 0L |
| 235 | ! |
PTM$ustart[lambda.idx] <- 1 |
| 236 | ! |
PTM$start[ lambda.idx] <- 1 |
| 237 | ! |
free.idx <- which(as.logical(PTM$free)) |
| 238 |
# adjust free counter |
|
| 239 | ! |
if (length(free.idx) > 0L) {
|
| 240 | ! |
PTM$free[free.idx] <- seq_len(length(free.idx)) |
| 241 |
} |
|
| 242 |
# warn about it (needed?) |
|
| 243 | ! |
lav_msg_warn(gettextf( |
| 244 | ! |
"measurement block [%1$s] (%2$s) contains only two indicators; |
| 245 | ! |
-> fixing both factor loadings to unity", |
| 246 | ! |
mm, lav_msg_view(mm.list[[mm]], "none"))) |
| 247 |
} |
|
| 248 |
} |
|
| 249 | ||
| 250 |
# fit this measurement model only |
|
| 251 |
# (question: can we re-use even more slots?) |
|
| 252 | ! |
if (FIT@Data@data.type == "full") {
|
| 253 | ! |
fit.mm.block <- lavaan( |
| 254 | ! |
model = PTM, slotData = slotData.block, |
| 255 | ! |
slotOptions = slotOptions.mm, debug = FALSE, verbose = FALSE |
| 256 |
) |
|
| 257 | ! |
} else if (FIT@Data@data.type == "moment") {
|
| 258 | ! |
slotOptions.mm$sample.cov.rescale <- FALSE |
| 259 | ! |
fit.mm.block <- lavaan( |
| 260 | ! |
model = PTM, slotData = slotData.block, |
| 261 | ! |
sample.cov = mm.sample.cov, sample.mean = mm.sample.mean, |
| 262 | ! |
sample.nobs = mm.sample.nobs, |
| 263 | ! |
slotOptions = slotOptions.mm, debug = FALSE, verbose = FALSE |
| 264 |
) |
|
| 265 |
} |
|
| 266 | ||
| 267 |
# check convergence |
|
| 268 | ! |
if (!lavInspect(fit.mm.block, "converged")) {
|
| 269 |
# warning for now, but this is not good! |
|
| 270 | ! |
lav_msg_warn(gettextf( |
| 271 | ! |
"measurement model for %s did not converge!", |
| 272 | ! |
lav_msg_view(mm.list[[mm]], "none"))) |
| 273 |
} |
|
| 274 | ||
| 275 |
# store fitted measurement model |
|
| 276 | ! |
MM.FIT[[mm]] <- fit.mm.block |
| 277 | ||
| 278 |
# fill in point estimates measurement block (including slack values) |
|
| 279 | ! |
PTM <- MM.FIT[[mm]]@ParTable |
| 280 |
# pt.idx: the row-numbers in PT that correspond to the rows in PTM |
|
| 281 |
# pt.idx <- lav_partable_map_id_p1_in_p2(p1 = PTM, p2 = PT, |
|
| 282 |
# stopifnotfound = TRUE, exclude.nonpar = FALSE) |
|
| 283 |
# pt.idx == mm.idx |
|
| 284 | ! |
ptm.idx <- which((PTM$free > 0L | PTM$op %in% c(":=", "<", ">")) &
|
| 285 | ! |
PTM$user != 3L) |
| 286 | ! |
block.ptm.idx[[mm]] <- ptm.idx |
| 287 | ! |
PT$est[mm.idx[ptm.idx]] <- PTM$est[ptm.idx] |
| 288 | ||
| 289 |
# if categorical, add non-free residual variances |
|
| 290 | ! |
if (fit.mm.block@Model@categorical || fit.mm.block@Model@correlation) {
|
| 291 | ! |
extra.idx <- which(PTM$op %in% c("~~", "~*~") &
|
| 292 | ! |
PTM$lhs == PTM$rhs & |
| 293 | ! |
PTM$user == 0L & |
| 294 | ! |
PTM$free == 0L & |
| 295 | ! |
PTM$ustart == 1) |
| 296 | ! |
if (length(extra.idx) > 0L) {
|
| 297 | ! |
PT$est[mm.idx[extra.idx]] <- PTM$est[extra.idx] |
| 298 |
} |
|
| 299 |
} |
|
| 300 |
# if EFA, add user=7 values (but do not add to ptm.idx) |
|
| 301 | ! |
user7.idx <- which(PTM$user == 7L) |
| 302 | ! |
if (length(user7.idx)) {
|
| 303 | ! |
PT$est[mm.idx[user7.idx]] <- PTM$est[user7.idx] |
| 304 |
} |
|
| 305 | ||
| 306 |
# add step1.free.idx |
|
| 307 | ! |
par.idx <- PT.free[mm.idx[ptm.idx]] |
| 308 |
# store (ordered) indices in step1.free.idx |
|
| 309 | ! |
this.mm.idx <- sort.int(par.idx) |
| 310 | ! |
step1.free.idx <- c(step1.free.idx, this.mm.idx) # all combined |
| 311 | ||
| 312 | ||
| 313 |
# fill in standard errors measurement block |
|
| 314 | ! |
if (!lavoptions$se %in% c("none", "bootstrap")) {
|
| 315 | ! |
if (fit.mm.block@Model@ceq.simple.only) {
|
| 316 | ! |
PTM.free <- PTM$free |
| 317 | ! |
PTM.free[PTM.free > 0] <- seq_len(fit.mm.block@Model@nx.unco) |
| 318 |
} else {
|
|
| 319 | ! |
PTM.free <- PTM$free |
| 320 |
} |
|
| 321 | ||
| 322 | ! |
ptm.se.idx <- which((PTM$free > 0L) & PTM$user != 3L) # no :=, <, > |
| 323 |
# PT$se[ seq_len(length(PT$lhs)) %in% mm.idx & PT$free > 0L ] <- |
|
| 324 |
# PTM$se[ PTM$free > 0L & PTM$user != 3L] |
|
| 325 | ! |
PT$se[mm.idx[ptm.se.idx]] <- PTM$se[ptm.se.idx] |
| 326 | ||
| 327 |
# compute variance matrix for this measurement block |
|
| 328 | ! |
sigma.11 <- MM.FIT[[mm]]@vcov$vcov |
| 329 | ||
| 330 |
# fill in variance matrix |
|
| 331 | ! |
keep.idx <- PTM.free[ptm.idx] |
| 332 |
# par.idx <- PT.free[ seq_len(length(PT$lhs)) %in% mm.idx & |
|
| 333 |
# PT$free > 0L ] |
|
| 334 |
# keep.idx <- PTM.free[ PTM$free > 0 & PTM$user != 3L ] |
|
| 335 | ! |
Sigma.11[par.idx, par.idx] <- |
| 336 | ! |
sigma.11[keep.idx, keep.idx, drop = FALSE] |
| 337 |
} |
|
| 338 |
} # measurement block |
|
| 339 | ||
| 340 |
# only keep 'measurement part' parameters in Sigma.11 |
|
| 341 | ! |
if (!lavoptions$se %in% c("none", "bootstrap")) {
|
| 342 | ! |
Sigma.11 <- Sigma.11[step1.free.idx, step1.free.idx, drop = FALSE] |
| 343 |
} else {
|
|
| 344 | ! |
Sigma.11 <- NULL |
| 345 |
} |
|
| 346 | ||
| 347 |
# create STEP1 list |
|
| 348 | ! |
STEP1 <- list( |
| 349 | ! |
MM.FIT = MM.FIT, Sigma.11 = Sigma.11, |
| 350 | ! |
step1.free.idx = step1.free.idx, |
| 351 | ! |
block.mm.idx = block.mm.idx, |
| 352 | ! |
block.ptm.idx = block.ptm.idx, |
| 353 | ! |
PT.free = PT.free, |
| 354 | ! |
mm.list = mm.list, PT = PT |
| 355 |
) |
|
| 356 | ||
| 357 | ! |
STEP1 |
| 358 |
} |
|
| 359 |
| 1 |
# collect information about the model that we can use |
|
| 2 |
# (eg. is theta diagonal or not, is the structurual model recursive or not, |
|
| 3 |
# is the model just a regression model, etc) |
|
| 4 |
# |
|
| 5 |
# initial version: YR 15 March 2021 |
|
| 6 |
# - YR 05 Oct 2021: use det(I - B) to check if B is acyclic |
|
| 7 |
# - YR 11 Nov 2021: if no latents, and conditional.x = TRUE, we may have no |
|
| 8 |
# beta matrix |
|
| 9 | ||
| 10 | ||
| 11 |
# note: there is no 'lavmodel' yet, because we call this in lav_model.R |
|
| 12 |
lav_model_properties <- function(GLIST, lavpartable = NULL, |
|
| 13 |
nmat = NULL, m.free.idx = NULL) {
|
|
| 14 | 144x |
lavpta <- lav_partable_attributes(lavpartable) |
| 15 | 144x |
nblocks <- lavpta$nblocks |
| 16 | ||
| 17 |
# is the model a univariate/multivariate linear multiple regression |
|
| 18 |
# model (per block)? |
|
| 19 | 144x |
uvreg <- logical(nblocks) |
| 20 | 144x |
uvord <- logical(nblocks) |
| 21 | 144x |
mvreg <- logical(nblocks) |
| 22 | 144x |
acyclic <- rep(as.logical(NA), nblocks) |
| 23 | 144x |
bowfree <- rep(as.logical(NA), nblocks) |
| 24 | 144x |
nexo <- integer(nblocks) |
| 25 | ||
| 26 | 144x |
for (g in seq_len(nblocks)) {
|
| 27 |
# at least 1 regression |
|
| 28 | 161x |
if (length(lavpta$vnames$eqs.y[[g]]) == 0L) {
|
| 29 | 111x |
next |
| 30 |
} |
|
| 31 | ||
| 32 |
# find beta index for this block |
|
| 33 | 50x |
mm.in.block <- 1:nmat[g] + cumsum(c(0L, nmat))[g] |
| 34 | 50x |
MLIST <- GLIST[mm.in.block] |
| 35 | 50x |
beta.idx <- which(names(MLIST) == "beta") + cumsum(c(0L, nmat))[g] |
| 36 | 50x |
psi.idx <- which(names(MLIST) == "psi") + cumsum(c(0L, nmat))[g] |
| 37 | ||
| 38 | 50x |
if (length(beta.idx) > 0L) {
|
| 39 |
# 1. acyclic? |
|
| 40 | 48x |
B <- GLIST[[beta.idx]] |
| 41 |
# keep fixed values (if any); fill in 1 in all 'free' positions |
|
| 42 | 48x |
B[m.free.idx[[beta.idx]]] <- 1 |
| 43 | 48x |
IminB <- diag(nrow(B)) - B |
| 44 |
# if B is acyclic, we should be able to permute the rows/cols of B |
|
| 45 |
# so that B is upper/lower triangular, and so det(I-B) = 1 |
|
| 46 | 48x |
if (det(IminB) == 1) {
|
| 47 | 48x |
acyclic[g] <- TRUE |
| 48 |
} else {
|
|
| 49 | ! |
acyclic[g] <- FALSE |
| 50 |
} |
|
| 51 | ||
| 52 |
# 2. bow-free? |
|
| 53 | 48x |
B.one <- as.integer(B != 0) |
| 54 | 48x |
Psi <- GLIST[[psi.idx]] |
| 55 |
# keep fixed values (if any); fill in 1 in all 'free' positions |
|
| 56 | 48x |
Psi[m.free.idx[[psi.idx]]] <- 1 |
| 57 | 48x |
Psi.one <- as.integer(Psi != 0) |
| 58 | 48x |
Both.one <- B.one + Psi.one |
| 59 | 48x |
if (any(Both.one > 1)) {
|
| 60 | ! |
bowfree[g] <- FALSE |
| 61 |
} else {
|
|
| 62 | 48x |
bowfree[g] <- TRUE |
| 63 |
} |
|
| 64 |
} else {
|
|
| 65 |
# perhaps conditional.x = TRUE? |
|
| 66 |
# if there is no BETA, then we only have Gamma, and the |
|
| 67 |
# system must be acyclic |
|
| 68 | 2x |
acyclic[g] <- TRUE |
| 69 |
# and also bowfree |
|
| 70 | 2x |
bowfree[g] <- TRUE |
| 71 |
} |
|
| 72 | ||
| 73 | ||
| 74 |
# no latent variables, at least 1 dependent variable |
|
| 75 | 50x |
if (lavpta$nfac[[g]] > 0L) {
|
| 76 | 16x |
next |
| 77 |
} |
|
| 78 | ||
| 79 |
# no mediators |
|
| 80 | 34x |
if (length(lavpta$vnames$eqs.y[[g]]) != |
| 81 | 34x |
length(lavpta$vnames$ov.y[[g]])) {
|
| 82 | 6x |
next |
| 83 |
} |
|
| 84 | ||
| 85 |
# categorical y? |
|
| 86 | 28x |
if (length(lavpta$vnames$ov.ord[[g]]) > 0L) {
|
| 87 |
# we only flag the univariate version |
|
| 88 | 2x |
if (length(lavpta$vnames$ov.ord[[g]]) == 1L && |
| 89 | 2x |
length(lavpta$vnames$ov.y[[g]]) == 1L && |
| 90 | 2x |
lavpta$vnames$ov.ord[[g]][1] == lavpta$vnames$ov.y[[g]][1]) {
|
| 91 | ! |
uvord[g] <- TRUE |
| 92 |
} |
|
| 93 | ||
| 94 |
# mvreg? |
|
| 95 |
} else {
|
|
| 96 | 26x |
if (length(lavpta$vnames$ov.y[[g]]) > 1L) {
|
| 97 | ! |
mvreg[g] <- TRUE |
| 98 |
} else {
|
|
| 99 | 26x |
uvreg[g] <- TRUE |
| 100 |
} |
|
| 101 |
} |
|
| 102 | ||
| 103 | 28x |
nexo[g] <- length(lavpta$vnames$eqs.x[[g]]) |
| 104 |
} # g |
|
| 105 | ||
| 106 | 144x |
modprop <- list( |
| 107 | 144x |
uvreg = uvreg, uvord = uvord, mvreg = mvreg, |
| 108 | 144x |
nexo = nexo, acyclic = acyclic, bowfree = bowfree |
| 109 |
) |
|
| 110 | ||
| 111 | 144x |
modprop |
| 112 |
} |
| 1 |
# classic Wald test |
|
| 2 |
# |
|
| 3 |
# NOTE: does not handle redundant constraints yet! |
|
| 4 |
# |
|
| 5 | ||
| 6 |
lavTestWald <- function(object, constraints = NULL, verbose = FALSE) {
|
|
| 7 |
# check object |
|
| 8 | ! |
object <- lav_object_check_version(object) |
| 9 | ||
| 10 | ! |
if (!missing(verbose)) {
|
| 11 | ! |
current.verbose <- lav_verbose() |
| 12 | ! |
if (lav_verbose(verbose)) |
| 13 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 14 |
} |
|
| 15 | ! |
if (object@optim$npar > 0L && !object@optim$converged) {
|
| 16 | ! |
lav_msg_stop(gettext("model did not converge"))
|
| 17 |
} |
|
| 18 | ||
| 19 | ! |
if (is.null(constraints) || all(nchar(constraints) == 0L)) {
|
| 20 | ! |
lav_msg_stop(gettext("constraints are empty"))
|
| 21 |
} |
|
| 22 | ||
| 23 |
# extract slots |
|
| 24 | ! |
lavoptions <- object@Options |
| 25 | ! |
lavmodel <- object@Model |
| 26 | ! |
lavpartable <- data.frame(object@ParTable) |
| 27 | ||
| 28 |
# remove == constraints from parTable |
|
| 29 | ! |
eq.idx <- which(lavpartable$op == "==") |
| 30 | ! |
if (length(eq.idx) > 0L) {
|
| 31 | ! |
lavpartable <- lavpartable[-eq.idx, ] |
| 32 |
} |
|
| 33 | ! |
partable <- as.list(lavpartable) |
| 34 | ||
| 35 |
# parse constraints |
|
| 36 | ! |
FLAT <- lavParseModelString(constraints, parser = lavoptions$parser) |
| 37 | ! |
CON <- attr(FLAT, "constraints") |
| 38 | ! |
LIST <- list() |
| 39 | ! |
if (length(CON) > 0L) {
|
| 40 | ! |
lhs <- unlist(lapply(CON, "[[", "lhs")) |
| 41 | ! |
op <- unlist(lapply(CON, "[[", "op")) |
| 42 | ! |
rhs <- unlist(lapply(CON, "[[", "rhs")) |
| 43 | ! |
LIST$lhs <- c(LIST$lhs, lhs) |
| 44 | ! |
LIST$op <- c(LIST$op, op) |
| 45 | ! |
LIST$rhs <- c(LIST$rhs, rhs) |
| 46 |
} else {
|
|
| 47 | ! |
lav_msg_stop(gettext( |
| 48 | ! |
"no equality constraints found in constraints argument")) |
| 49 |
} |
|
| 50 | ||
| 51 |
# theta = free parameters only |
|
| 52 | ! |
theta <- lav_model_get_parameters(lavmodel) |
| 53 | ||
| 54 |
# build constraint function |
|
| 55 | ! |
ceq.function <- lav_partable_constraints_ceq( |
| 56 | ! |
partable = partable, |
| 57 | ! |
con = LIST, debug = FALSE |
| 58 |
) |
|
| 59 |
# compute jacobian restrictions |
|
| 60 | ! |
JAC <- try(lav_func_jacobian_complex(func = ceq.function, x = theta), |
| 61 | ! |
silent = TRUE |
| 62 |
) |
|
| 63 | ! |
if (inherits(JAC, "try-error")) { # eg. pnorm()
|
| 64 | ! |
JAC <- lav_func_jacobian_simple(func = ceq.function, x = theta) |
| 65 |
} |
|
| 66 | ||
| 67 |
# check for linear redundant rows in JAC |
|
| 68 | ! |
out <- lav_matrix_rref(t(JAC)) |
| 69 | ! |
ranK <- length(out$pivot) |
| 70 | ! |
if (ranK < nrow(JAC)) {
|
| 71 | ! |
lav_msg_warn(gettext("Jacobian of constraints is rank deficient. Some constraints may be redundant, and have been removed."))
|
| 72 |
} |
|
| 73 | ! |
JAC <- JAC[out$pivot, , drop = FALSE] |
| 74 | ||
| 75 | ! |
if (lav_verbose()) {
|
| 76 | ! |
cat("Restriction matrix (jacobian):\n")
|
| 77 | ! |
print(JAC) |
| 78 | ! |
cat("\n")
|
| 79 |
} |
|
| 80 | ||
| 81 |
# linear restriction |
|
| 82 | ! |
theta.r <- ceq.function(theta) |
| 83 | ! |
theta.r <- theta.r[out$pivot] |
| 84 | ||
| 85 | ! |
if (lav_verbose()) {
|
| 86 | ! |
cat("Restricted theta values:\n")
|
| 87 | ! |
print(theta.r) |
| 88 | ! |
cat("\n")
|
| 89 |
} |
|
| 90 | ||
| 91 |
# get VCOV |
|
| 92 |
# VCOV <- vcov(object, labels = FALSE) |
|
| 93 |
# avoid S4 dispatch |
|
| 94 | ! |
VCOV <- lav_object_inspect_vcov(object, |
| 95 | ! |
standardized = FALSE, |
| 96 | ! |
free.only = TRUE, |
| 97 | ! |
add.labels = FALSE, |
| 98 | ! |
add.class = FALSE, |
| 99 | ! |
remove.duplicated = FALSE |
| 100 |
) |
|
| 101 | ||
| 102 |
# restricted vcov |
|
| 103 | ! |
VCOV.r <- JAC %*% VCOV %*% t(JAC) |
| 104 | ||
| 105 |
# fixme: what if VCOV.r is singular? |
|
| 106 |
# Wald test statistic |
|
| 107 | ! |
Wald <- as.numeric(t(theta.r) %*% solve(VCOV.r) %*% theta.r) |
| 108 | ||
| 109 |
# df |
|
| 110 | ! |
Wald.df <- ranK |
| 111 | ||
| 112 |
# p-value based on chisq |
|
| 113 | ! |
Wald.pvalue <- 1 - pchisq(Wald, df = Wald.df) |
| 114 | ||
| 115 |
# prepare output |
|
| 116 | ! |
out <- list( |
| 117 | ! |
stat = Wald, df = Wald.df, p.value = Wald.pvalue, |
| 118 | ! |
se = lavoptions$se |
| 119 |
) |
|
| 120 | ||
| 121 | ! |
out |
| 122 |
} |
| 1 |
# the weighted bivariate ordinal model |
|
| 2 |
# YR 19 Feb 2020 (replacing the old lav_polychor.R routines) |
|
| 3 |
# |
|
| 4 |
# - polychoric (and tetrachoric) correlations |
|
| 5 |
# - bivariate ordinal regression |
|
| 6 |
# - using sampling weights wt |
|
| 7 | ||
| 8 |
# two-way frequency table |
|
| 9 |
# only works if Y = 1,2,3,... |
|
| 10 |
lav_bvord_freq <- function(Y1, Y2, wt = NULL) {
|
|
| 11 | 6x |
max.y1 <- max(Y1, na.rm = TRUE) |
| 12 | 6x |
max.y2 <- max(Y2, na.rm = TRUE) |
| 13 | ||
| 14 | 6x |
bin <- Y1 - 1L |
| 15 | 6x |
bin <- bin + max.y1 * (Y2 - 1L) |
| 16 | 6x |
bin <- bin + 1L |
| 17 | ||
| 18 | 6x |
if (is.null(wt)) {
|
| 19 | 6x |
bin <- bin[!is.na(bin)] |
| 20 | 6x |
out <- array(tabulate(bin, nbins = max.y1 * max.y2), |
| 21 | 6x |
dim = c(max.y1, max.y2) |
| 22 |
) |
|
| 23 |
} else {
|
|
| 24 | ! |
if (anyNA(Y1) || anyNA(Y2)) {
|
| 25 | ! |
wt[is.na(Y1) | is.na(Y2)] <- 0 |
| 26 | ! |
bin[is.na(bin)] <- 0 |
| 27 |
} |
|
| 28 | ! |
y.ncat <- max.y1 * max.y2 |
| 29 | ! |
y.freq <- numeric(y.ncat) |
| 30 | ! |
for (cat in seq_len(y.ncat)) {
|
| 31 | ! |
y.freq[cat] <- sum(wt[bin == cat]) |
| 32 |
} |
|
| 33 | ! |
out <- array(y.freq, dim = c(max.y1, max.y2)) |
| 34 |
} |
|
| 35 | ||
| 36 | 6x |
out |
| 37 |
} |
|
| 38 | ||
| 39 |
# polychoric correlation |
|
| 40 |
# |
|
| 41 |
# zero.add is a vector: first element is for 2x2 tables only, second element |
|
| 42 |
# for general tables |
|
| 43 |
# zero.keep.margins is only used for 2x2 tables |
|
| 44 |
# |
|
| 45 |
lav_bvord_cor_twostep_fit <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 46 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 47 |
freq = NULL, |
|
| 48 |
zero.add = c(0.5, 0.0), |
|
| 49 |
zero.keep.margins = TRUE, |
|
| 50 |
zero.cell.warn = FALSE, |
|
| 51 |
zero.cell.flag = FALSE, |
|
| 52 |
optim.method = "nlminb2", |
|
| 53 |
optim.scale = 1.0, |
|
| 54 |
init.theta = NULL, |
|
| 55 |
control = list(step.min = 0.1), # 0.6-7 |
|
| 56 |
Y1.name = NULL, Y2.name = NULL) {
|
|
| 57 | 12x |
if (is.null(fit.y1)) {
|
| 58 | ! |
fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt) |
| 59 |
} |
|
| 60 | 12x |
if (is.null(fit.y2)) {
|
| 61 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 62 |
} |
|
| 63 | ||
| 64 |
# create cache environment |
|
| 65 | 12x |
cache <- lav_bvord_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt) |
| 66 | ||
| 67 |
# empty cells or not |
|
| 68 | 12x |
empty.cells <- FALSE |
| 69 | ||
| 70 |
# check for zero cells (if not exo), and catch some special cases |
|
| 71 | 12x |
if (cache$nexo == 0L) {
|
| 72 | ! |
freq <- cache$freq |
| 73 | ! |
nr <- nrow(freq) |
| 74 | ! |
nc <- ncol(freq) |
| 75 | ||
| 76 |
# check for empty cells |
|
| 77 | ! |
if (any(freq == 0L)) {
|
| 78 | ! |
empty.cells <- TRUE |
| 79 | ! |
if (zero.cell.warn) {
|
| 80 | ! |
if (!is.null(Y1.name) && !is.null(Y2.name)) {
|
| 81 | ! |
lav_msg_warn(gettextf( |
| 82 | ! |
"empty cell(s) in bivariate table of %1$s x %2$s", |
| 83 | ! |
Y1.name, Y2.name)) |
| 84 |
} else {
|
|
| 85 | ! |
lav_msg_warn(gettext("empty cell(s) in bivariate table"))
|
| 86 |
} |
|
| 87 |
} |
|
| 88 |
} |
|
| 89 | ||
| 90 |
# treat 2x2 tables |
|
| 91 | ! |
if (nr == 2L && nc == 2L) {
|
| 92 | ! |
idx <- which(freq == 0L) |
| 93 |
# catch 2 empty cells: perfect correlation! |
|
| 94 | ! |
if (length(idx) == 2L) {
|
| 95 | ! |
lav_msg_warn(gettext("two empty cells in 2x2 table"))
|
| 96 | ! |
if (freq[1, 1] > 0L) {
|
| 97 | ! |
rho <- 1.0 |
| 98 | ! |
if (zero.cell.flag) {
|
| 99 | ! |
attr(rho, "zero.cell.flag") <- empty.cells |
| 100 |
} |
|
| 101 | ! |
return(rho) |
| 102 |
} else {
|
|
| 103 | ! |
rho <- -1.0 |
| 104 | ! |
if (zero.cell.flag) {
|
| 105 | ! |
attr(rho, "zero.cell.flag") <- empty.cells |
| 106 |
} |
|
| 107 | ! |
return(rho) |
| 108 |
} |
|
| 109 | ! |
} else if (length(idx) == 1L && zero.add[1] > 0.0) {
|
| 110 | ! |
if (zero.keep.margins) {
|
| 111 |
# add + compensate to preserve margins |
|
| 112 | ! |
if (idx == 1L || idx == 4L) { # main diagonal
|
| 113 | ! |
freq[1, 1] <- freq[1, 1] + zero.add[1] |
| 114 | ! |
freq[2, 2] <- freq[2, 2] + zero.add[1] |
| 115 | ! |
freq[2, 1] <- freq[2, 1] - zero.add[1] |
| 116 | ! |
freq[1, 2] <- freq[1, 2] - zero.add[1] |
| 117 |
} else {
|
|
| 118 | ! |
freq[1, 1] <- freq[1, 1] - zero.add[1] |
| 119 | ! |
freq[2, 2] <- freq[2, 2] - zero.add[1] |
| 120 | ! |
freq[2, 1] <- freq[2, 1] + zero.add[1] |
| 121 | ! |
freq[1, 2] <- freq[1, 2] + zero.add[1] |
| 122 |
} |
|
| 123 |
} else {
|
|
| 124 | ! |
freq[idx] <- freq[idx] + zero.add[1] |
| 125 |
} |
|
| 126 |
} |
|
| 127 |
# general table |
|
| 128 |
} else {
|
|
| 129 | ! |
if (any(freq == 0L) && zero.add[2] > 0.0) {
|
| 130 |
# general table: just add zero.add to the empty cell(s) |
|
| 131 | ! |
freq[freq == 0] <- zero.add[2] |
| 132 |
} |
|
| 133 |
} |
|
| 134 | ||
| 135 |
# update (possibly change) freq table |
|
| 136 | ! |
cache$freq <- freq |
| 137 | ||
| 138 |
# catch special cases for 2x2 tables |
|
| 139 | ! |
if (nr == 2L && nc == 2L) {
|
| 140 |
# 1. a*d == c*d |
|
| 141 | ! |
storage.mode(freq) <- "numeric" # to avoid integer overflow |
| 142 | ! |
if (freq[1, 1] * freq[2, 2] == freq[1, 2] * freq[2, 1]) {
|
| 143 | ! |
rho <- 0.0 |
| 144 | ! |
if (zero.cell.flag) {
|
| 145 | ! |
attr(rho, "zero.cell.flag") <- empty.cells |
| 146 |
} |
|
| 147 | ! |
return(rho) |
| 148 |
} |
|
| 149 |
# 2. equal margins (th1 = th2 = 0) |
|
| 150 | ! |
if (cache$th.y1[1] == 0 && cache$th.y2[1] == 0) {
|
| 151 |
# see eg Brown & Benedetti 1977 eq 2 |
|
| 152 | ! |
rho <- -cos(2 * pi * freq[1, 1] / sum(freq)) |
| 153 | ! |
if (zero.cell.flag) {
|
| 154 | ! |
attr(rho, "zero.cell.flag") <- empty.cells |
| 155 |
} |
|
| 156 | ! |
return(rho) |
| 157 |
} |
|
| 158 |
} |
|
| 159 |
} # non-exo |
|
| 160 | ||
| 161 |
# optim.method |
|
| 162 | 12x |
minObjective <- lav_bvord_min_objective |
| 163 | 12x |
minGradient <- lav_bvord_min_gradient |
| 164 | 12x |
minHessian <- lav_bvord_min_hessian |
| 165 | 12x |
if (optim.method == "nlminb" || optim.method == "nlminb2") {
|
| 166 |
# nothing to do |
|
| 167 | ! |
} else if (optim.method == "nlminb0") {
|
| 168 | ! |
minGradient <- minHessian <- NULL |
| 169 | ! |
} else if (optim.method == "nlminb1") {
|
| 170 | ! |
minHessian <- NULL |
| 171 |
} |
|
| 172 | ||
| 173 |
# optimize |
|
| 174 | 12x |
if (is.null(control$trace)) {
|
| 175 | 12x |
control$trace <- ifelse(lav_verbose(), 1, 0) |
| 176 |
} |
|
| 177 | ||
| 178 |
# init theta? |
|
| 179 | 12x |
if (!is.null(init.theta)) {
|
| 180 | ! |
start.x <- init.theta |
| 181 |
} else {
|
|
| 182 | 12x |
start.x <- cache$theta |
| 183 |
} |
|
| 184 | ||
| 185 |
# try 1 |
|
| 186 | 12x |
optim <- nlminb( |
| 187 | 12x |
start = start.x, objective = minObjective, |
| 188 | 12x |
gradient = minGradient, hessian = minHessian, |
| 189 | 12x |
control = control, |
| 190 | 12x |
scale = optim.scale, lower = -0.999, upper = +0.999, |
| 191 | 12x |
cache = cache |
| 192 |
) |
|
| 193 | ||
| 194 |
# try 2 |
|
| 195 | 12x |
if (optim$convergence != 0L) {
|
| 196 |
# try again, with different starting value |
|
| 197 | ! |
optim <- nlminb( |
| 198 | ! |
start = 0, objective = minObjective, |
| 199 | ! |
gradient = NULL, hessian = NULL, |
| 200 | ! |
control = control, |
| 201 | ! |
scale = optim.scale, lower = -0.995, upper = +0.995, |
| 202 | ! |
cache = cache |
| 203 |
) |
|
| 204 |
} |
|
| 205 | ||
| 206 |
# check convergence |
|
| 207 | 12x |
if (optim$convergence != 0L) {
|
| 208 | ! |
if (!is.null(Y1.name) && !is.null(Y2.name)) {
|
| 209 | ! |
lav_msg_warn(gettextf( |
| 210 | ! |
"estimation polychoric correlation did not converge for |
| 211 | ! |
variables %1$s and %2$s", Y1.name, Y2.name)) |
| 212 |
} else {
|
|
| 213 | ! |
lav_msg_warn(gettext( |
| 214 | ! |
"estimation polychoric correlation(s) did not always converge")) |
| 215 |
} |
|
| 216 | ! |
rho <- start.x |
| 217 |
} else {
|
|
| 218 | 12x |
rho <- optim$par |
| 219 |
} |
|
| 220 | ||
| 221 |
# zero.cell.flag |
|
| 222 | 12x |
if (zero.cell.flag) {
|
| 223 | 12x |
attr(rho, "zero.cell.flag") <- empty.cells |
| 224 |
} |
|
| 225 | ||
| 226 | 12x |
rho |
| 227 |
} |
|
| 228 | ||
| 229 | ||
| 230 |
# prepare cache environment |
|
| 231 |
lav_bvord_init_cache <- function(fit.y1 = NULL, |
|
| 232 |
fit.y2 = NULL, |
|
| 233 |
wt = NULL, |
|
| 234 |
scores = FALSE, |
|
| 235 |
parent = parent.frame()) {
|
|
| 236 |
# data |
|
| 237 | 24x |
Y1 <- fit.y1$y |
| 238 | 24x |
Y2 <- fit.y2$y |
| 239 | 24x |
eXo <- fit.y1$X |
| 240 | ||
| 241 |
# exo? |
|
| 242 | 24x |
if (is.null(eXo)) {
|
| 243 | ! |
nexo <- 0L |
| 244 | ! |
freq <- lav_bvord_freq(Y1 = Y1, Y2 = Y2, wt = wt) |
| 245 | ! |
th.y1 <- fit.y1$theta[fit.y1$th.idx] |
| 246 | ! |
th.y2 <- fit.y2$theta[fit.y2$th.idx] |
| 247 | ! |
nth.y1 <- length(th.y1) |
| 248 | ! |
nth.y2 <- length(th.y2) |
| 249 | ! |
pth.y1 <- pnorm(th.y1) |
| 250 | ! |
pth.y2 <- pnorm(th.y2) |
| 251 | ! |
upper.y <- rep(th.y2, times = rep.int(nth.y1, nth.y2)) |
| 252 | ! |
upper.x <- rep(th.y1, times = ceiling(length(upper.y)) / nth.y1) |
| 253 |
} else {
|
|
| 254 | 24x |
nexo <- ncol(eXo) |
| 255 | 24x |
freq <- NULL |
| 256 | 24x |
fit.y1.z1 <- fit.y1$z1 |
| 257 | 24x |
fit.y2.z1 <- fit.y2$z1 |
| 258 | 24x |
fit.y1.z2 <- fit.y1$z2 |
| 259 | 24x |
fit.y2.z2 <- fit.y2$z2 |
| 260 | ||
| 261 |
# take care of missing values |
|
| 262 | 24x |
if (length(fit.y1$missing.idx) > 0L || length(fit.y2$missing.idx) > 0L) {
|
| 263 | 12x |
missing.idx <- unique(c(fit.y1$missing.idx, fit.y2$missing.idx)) |
| 264 | 12x |
fit.y1.z1[missing.idx] <- 0 |
| 265 | 12x |
fit.y2.z1[missing.idx] <- 0 |
| 266 | 12x |
fit.y1.z2[missing.idx] <- 0 |
| 267 | 12x |
fit.y2.z2[missing.idx] <- 0 |
| 268 |
} else {
|
|
| 269 | 12x |
missing.idx <- integer(0L) |
| 270 |
} |
|
| 271 |
} |
|
| 272 | ||
| 273 |
# nobs |
|
| 274 | 24x |
if (is.null(wt)) {
|
| 275 | 24x |
N <- length(Y1) |
| 276 |
} else {
|
|
| 277 | ! |
N <- sum(wt) |
| 278 |
} |
|
| 279 | ||
| 280 |
# starting value (for both exo and not-exo) |
|
| 281 |
# if(is.null(wt)) {
|
|
| 282 | 24x |
if(sd(Y1, na.rm = TRUE) == 0 || sd(Y2, na.rm = TRUE) == 0) {
|
| 283 | ! |
rho.init <- 0.0 |
| 284 |
} else {
|
|
| 285 | 24x |
rho.init <- cor(Y1, Y2, use = "pairwise.complete.obs") |
| 286 |
} |
|
| 287 |
# } |
|
| 288 |
# cov.wt does not handle missing values... |
|
| 289 |
# rho.init <- cov.wt(cbind(Y1, Y2), wt = wt, cor = TRUE)$cor[2,1] |
|
| 290 | 24x |
if (is.na(rho.init) || abs(rho.init) >= 1.0) {
|
| 291 | ! |
rho.init <- 0.0 |
| 292 |
} |
|
| 293 | ||
| 294 |
# parameter vector |
|
| 295 | 24x |
theta <- rho.init # only, for now |
| 296 | ||
| 297 |
# different cache if exo or not |
|
| 298 | 24x |
if (nexo == 0L) {
|
| 299 | ! |
if (scores) {
|
| 300 | ! |
out <- list2env( |
| 301 | ! |
list( |
| 302 | ! |
nexo = nexo, theta = theta, N = N, |
| 303 | ! |
fit.y1.z1 = fit.y1$z1, fit.y1.z2 = fit.y1$z2, |
| 304 | ! |
fit.y2.z1 = fit.y2$z1, fit.y2.z2 = fit.y2$z2, |
| 305 | ! |
y1.Y1 = fit.y1$Y1, y1.Y2 = fit.y1$Y2, |
| 306 | ! |
y2.Y1 = fit.y2$Y1, y2.Y2 = fit.y2$Y2, |
| 307 | ! |
Y1 = Y1, Y2 = Y2, freq = freq, |
| 308 | ! |
th.y1 = th.y1, th.y2 = th.y2, |
| 309 | ! |
nth.y1 = nth.y1, nth.y2 = nth.y2, |
| 310 | ! |
pth.y1 = pth.y1, pth.y2 = pth.y2, |
| 311 | ! |
upper.y = upper.y, upper.x = upper.x |
| 312 |
), |
|
| 313 | ! |
parent = parent |
| 314 |
) |
|
| 315 |
} else {
|
|
| 316 | ! |
out <- list2env( |
| 317 | ! |
list( |
| 318 | ! |
nexo = nexo, theta = theta, N = N, |
| 319 | ! |
Y1 = Y1, Y2 = Y2, freq = freq, |
| 320 | ! |
th.y1 = th.y1, th.y2 = th.y2, |
| 321 | ! |
nth.y1 = nth.y1, nth.y2 = nth.y2, |
| 322 | ! |
pth.y1 = pth.y1, pth.y2 = pth.y2, |
| 323 | ! |
upper.y = upper.y, upper.x = upper.x |
| 324 |
), |
|
| 325 | ! |
parent = parent |
| 326 |
) |
|
| 327 |
} |
|
| 328 |
} else {
|
|
| 329 | 24x |
if (scores) {
|
| 330 | 12x |
out <- list2env( |
| 331 | 12x |
list( |
| 332 | 12x |
nexo = nexo, theta = theta, wt = wt, N = N, |
| 333 | 12x |
eXo = eXo, |
| 334 | 12x |
y1.Y1 = fit.y1$Y1, y1.Y2 = fit.y1$Y2, |
| 335 | 12x |
y2.Y1 = fit.y2$Y1, y2.Y2 = fit.y2$Y2, |
| 336 | 12x |
fit.y1.z1 = fit.y1.z1, fit.y1.z2 = fit.y1.z2, |
| 337 | 12x |
fit.y2.z1 = fit.y2.z1, fit.y2.z2 = fit.y2.z2, |
| 338 | 12x |
missing.idx = missing.idx |
| 339 |
), |
|
| 340 | 12x |
parent = parent |
| 341 |
) |
|
| 342 |
} else {
|
|
| 343 | 12x |
out <- list2env( |
| 344 | 12x |
list( |
| 345 | 12x |
nexo = nexo, theta = theta, wt = wt, N = N, |
| 346 | 12x |
fit.y1.z1 = fit.y1.z1, fit.y1.z2 = fit.y1.z2, |
| 347 | 12x |
fit.y2.z1 = fit.y2.z1, fit.y2.z2 = fit.y2.z2, |
| 348 | 12x |
missing.idx = missing.idx |
| 349 |
), |
|
| 350 | 12x |
parent = parent |
| 351 |
) |
|
| 352 |
} |
|
| 353 |
} |
|
| 354 | ||
| 355 | 24x |
out |
| 356 |
} |
|
| 357 | ||
| 358 |
# probabilities for each cell, given rho, th.y1 and th.y2 |
|
| 359 |
lav_bvord_noexo_pi_cache <- function(cache = NULL) {
|
|
| 360 | ! |
with(cache, {
|
| 361 | ! |
rho <- theta[1L] |
| 362 | ||
| 363 |
# catch special case: rho = 0.0 |
|
| 364 | ! |
if (rho == 0.0) {
|
| 365 | ! |
rowPI <- base::diff(c(0, pth.y1, 1)) |
| 366 | ! |
colPI <- base::diff(c(0, pth.y2, 1)) |
| 367 | ! |
PI.ij <- base::outer(rowPI, colPI) |
| 368 | ! |
return(PI.ij) |
| 369 |
} |
|
| 370 | ||
| 371 | ! |
BI <- pbivnorm::pbivnorm(x = upper.x, y = upper.y, rho = rho) |
| 372 | ! |
dim(BI) <- c(nth.y1, nth.y2) |
| 373 | ! |
BI <- rbind(0, BI, pth.y2, deparse.level = 0L) |
| 374 | ! |
BI <- cbind(0, BI, c(0, pth.y1, 1), deparse.level = 0L) |
| 375 | ||
| 376 |
# get probabilities |
|
| 377 | ! |
nr <- nrow(BI) |
| 378 | ! |
nc <- ncol(BI) |
| 379 | ! |
PI <- BI[-1L, -1L] - BI[-1L, -nc] - BI[-nr, -1L] + BI[-nr, -nc] |
| 380 | ||
| 381 |
# all elements should be strictly positive |
|
| 382 | ! |
PI[PI < sqrt(.Machine$double.eps)] <- sqrt(.Machine$double.eps) |
| 383 | ||
| 384 | ! |
return(PI) |
| 385 |
}) |
|
| 386 |
} |
|
| 387 | ||
| 388 |
# partial derivative of CDF(th.y1, th.y2, rho) with respect to rho |
|
| 389 |
lav_bvord_noexo_phi_cache <- function(cache = NULL) {
|
|
| 390 | ! |
with(cache, {
|
| 391 | ! |
rho <- theta[1L] |
| 392 | ||
| 393 |
# compute lav_dbinorm for all possible combinations |
|
| 394 | ! |
t1 <- rep(th.y1, times = nth.y2) |
| 395 | ! |
t2 <- rep(th.y2, each = nth.y1) |
| 396 | ! |
dbiNorm <- matrix(lav_dbinorm(t1, t2, rho), |
| 397 | ! |
nrow = nth.y1, ncol = nth.y2 |
| 398 |
) |
|
| 399 | ||
| 400 | ! |
p1 <- p2 <- p3 <- p4 <- matrix(0, nth.y1 + 1L, nth.y2 + 1L) |
| 401 | ! |
t1.idx <- seq_len(nth.y1) |
| 402 | ! |
t2.idx <- seq_len(nth.y2) |
| 403 | ||
| 404 |
# p1 is left-upper corner |
|
| 405 | ! |
p1[t1.idx, t2.idx] <- dbiNorm |
| 406 |
# p2 is left-lower corner |
|
| 407 | ! |
p2[t1.idx + 1L, t2.idx] <- dbiNorm |
| 408 |
# p3 is right-upper corner |
|
| 409 | ! |
p3[t1.idx, t2.idx + 1L] <- dbiNorm |
| 410 |
# p3 is right-lower corner |
|
| 411 | ! |
p4[t1.idx + 1L, t2.idx + 1L] <- dbiNorm |
| 412 | ||
| 413 | ! |
phi <- p1 - p2 - p3 + p4 |
| 414 | ! |
return(phi) |
| 415 |
}) |
|
| 416 |
} |
|
| 417 | ||
| 418 |
# Olsson 1979 A2 |
|
| 419 |
lav_bvord_noexo_gnorm_cache <- function(cache = NULL) {
|
|
| 420 | ! |
with(cache, {
|
| 421 | ! |
rho <- theta[1L] |
| 422 | ||
| 423 |
# note: Olsson 1979 A2 contains an error!! |
|
| 424 |
# derivative of phi_2(y1,y2;rho) wrt to rho equals |
|
| 425 |
# phi_2(y1,y2;rho) * guv(y1,y2;rho), where guv() is defined below: |
|
| 426 | ! |
guv <- function(u, v, rho) {
|
| 427 | ! |
R <- (1 - rho * rho) |
| 428 | ! |
(u * v * R - rho * ((u * u) - 2 * rho * u * v + (v * v)) + rho * R) / (R * R) |
| 429 |
} |
|
| 430 | ||
| 431 |
# compute gnorm for all possible combinations |
|
| 432 | ! |
Gnorm <- dbiNorm * matrix(guv(t1, t2, rho), nth.y1, nth.y2) |
| 433 | ||
| 434 | ! |
p1 <- p2 <- p3 <- p4 <- matrix(0, nth.y1 + 1L, nth.y2 + 1L) |
| 435 | ! |
t1.idx <- seq_len(nth.y1) |
| 436 | ! |
t2.idx <- seq_len(nth.y2) |
| 437 | ||
| 438 |
# p1 is left-upper corner |
|
| 439 | ! |
p1[t1.idx, t2.idx] <- Gnorm |
| 440 |
# p2 is left-lower corner |
|
| 441 | ! |
p2[t1.idx + 1L, t2.idx] <- Gnorm |
| 442 |
# p3 is right-upper corner |
|
| 443 | ! |
p3[t1.idx, t2.idx + 1L] <- Gnorm |
| 444 |
# p3 is right-lower corner |
|
| 445 | ! |
p4[t1.idx + 1L, t2.idx + 1L] <- Gnorm |
| 446 | ||
| 447 | ! |
gnorm <- p1 - p2 - p3 + p4 |
| 448 | ! |
return(gnorm) |
| 449 |
}) |
|
| 450 |
} |
|
| 451 | ||
| 452 | ||
| 453 |
# casewise likelihoods, unweighted! |
|
| 454 |
lav_bvord_lik_cache <- function(cache = NULL) {
|
|
| 455 | 96x |
with(cache, {
|
| 456 | 96x |
rho <- theta[1L] |
| 457 | ||
| 458 |
# no exo |
|
| 459 | 96x |
if (nexo == 0L) {
|
| 460 | ! |
PI <- lav_bvord_noexo_pi_cache(cache) |
| 461 | ! |
lik <- PI[cbind(Y1, Y2)] |
| 462 | ||
| 463 |
# exo |
|
| 464 |
} else {
|
|
| 465 | 96x |
lik <- pbinorm( |
| 466 | 96x |
upper.x = fit.y1.z1, upper.y = fit.y2.z1, |
| 467 | 96x |
lower.x = fit.y1.z2, lower.y = fit.y2.z2, rho = rho |
| 468 |
) |
|
| 469 | 96x |
if (length(missing.idx) > 0L) {
|
| 470 | 50x |
lik[missing.idx] <- NA |
| 471 |
} |
|
| 472 |
# catch very small values |
|
| 473 | 96x |
lik.toosmall.idx <- which(lik < sqrt(.Machine$double.eps)) |
| 474 | 96x |
lik[lik.toosmall.idx] <- as.numeric(NA) |
| 475 |
} |
|
| 476 | ||
| 477 | 96x |
return(lik) |
| 478 |
}) |
|
| 479 |
} |
|
| 480 | ||
| 481 |
lav_bvord_logl_cache <- function(cache = NULL) {
|
|
| 482 | 84x |
with(cache, {
|
| 483 | 84x |
rho <- theta[1L] |
| 484 | ||
| 485 |
# no exo |
|
| 486 | 84x |
if (nexo == 0L) {
|
| 487 | ! |
PI <- lav_bvord_noexo_pi_cache(cache) |
| 488 | ! |
logl <- sum(freq * log(PI), na.rm = TRUE) |
| 489 | ||
| 490 |
# exo |
|
| 491 |
} else {
|
|
| 492 | 84x |
lik <- lav_bvord_lik_cache(cache) # unweighted! |
| 493 | 84x |
if (!is.null(wt)) {
|
| 494 | ! |
logl <- sum(wt * log(lik), na.rm = TRUE) |
| 495 |
} else {
|
|
| 496 | 84x |
logl <- sum(log(lik), na.rm = TRUE) |
| 497 |
} |
|
| 498 |
} |
|
| 499 | ||
| 500 | 84x |
return(logl) |
| 501 |
}) |
|
| 502 |
} |
|
| 503 | ||
| 504 |
lav_bvord_gradient_cache <- function(cache = NULL) {
|
|
| 505 | 62x |
with(cache, {
|
| 506 | 62x |
rho <- theta[1L] |
| 507 | ||
| 508 |
# no exo |
|
| 509 | 62x |
if (nexo == 0L) {
|
| 510 | ! |
phi <- lav_bvord_noexo_phi_cache(cache) |
| 511 | ! |
bad.idx <- which(PI <= sqrt(.Machine$double.eps)) |
| 512 | ! |
if (length(bad.idx) > 0L) {
|
| 513 | ! |
PI[bad.idx] <- as.numeric(NA) |
| 514 |
} |
|
| 515 | ! |
dx.rho <- sum((freq * phi) / PI, na.rm = TRUE) |
| 516 | ||
| 517 |
# exo |
|
| 518 |
} else {
|
|
| 519 | 62x |
d1 <- lav_dbinorm(fit.y1.z1, fit.y2.z1, rho) |
| 520 | 62x |
d2 <- lav_dbinorm(fit.y1.z2, fit.y2.z1, rho) |
| 521 | 62x |
d3 <- lav_dbinorm(fit.y1.z1, fit.y2.z2, rho) |
| 522 | 62x |
d4 <- lav_dbinorm(fit.y1.z2, fit.y2.z2, rho) |
| 523 | 62x |
phi <- (d1 - d2 - d3 + d4) |
| 524 | ||
| 525 |
# avoid dividing by very tine numbers (new in 0.6-6) |
|
| 526 |
# -> done automatically: lik == NA in this case |
|
| 527 |
# bad.idx <- which(lik <= sqrt(.Machine$double.eps)) |
|
| 528 |
# if(length(bad.idx) > 0L) {
|
|
| 529 |
# lik[bad.idx] <- as.numeric(NA) |
|
| 530 |
# } |
|
| 531 | ||
| 532 | 62x |
dx2 <- phi / lik |
| 533 | ||
| 534 | 62x |
if (is.null(wt)) {
|
| 535 | 62x |
dx.rho <- sum(dx2, na.rm = TRUE) |
| 536 |
} else {
|
|
| 537 | ! |
dx.rho <- sum(wt * dx2, na.rm = TRUE) |
| 538 |
} |
|
| 539 |
} |
|
| 540 | ||
| 541 | 62x |
return(dx.rho) |
| 542 |
}) |
|
| 543 |
} |
|
| 544 | ||
| 545 |
lav_bvord_hessian_cache <- function(cache = NULL) {
|
|
| 546 | 62x |
with(cache, {
|
| 547 | 62x |
rho <- theta[1L] |
| 548 | ||
| 549 |
# no exo |
|
| 550 | 62x |
if (nexo == 0L) {
|
| 551 | ! |
bad.idx <- which(PI <= sqrt(.Machine$double.eps)) |
| 552 | ! |
if (length(bad.idx) > 0L) {
|
| 553 | ! |
PI[bad.idx] <- as.numeric(NA) |
| 554 |
} |
|
| 555 | ! |
gnorm <- lav_bvord_noexo_gnorm_cache(cache) |
| 556 |
# H <- sum( freq * (gnorm/PI - (phi*phi)/(PI*PI)), na.rm = TRUE) |
|
| 557 | ! |
H <- (sum((freq * gnorm) / PI, na.rm = TRUE) - |
| 558 | ! |
sum((freq * phi * phi) / (PI * PI), na.rm = TRUE)) |
| 559 | ! |
dim(H) <- c(1L, 1L) |
| 560 | ||
| 561 |
# exo |
|
| 562 |
} else {
|
|
| 563 | 62x |
guv <- function(u, v, rho) {
|
| 564 | 248x |
R <- (1 - rho * rho) |
| 565 | 248x |
(u * v * R - rho * ((u * u) - 2 * rho * u * v + (v * v)) + rho * R) / (R * R) |
| 566 |
} |
|
| 567 | ||
| 568 | 62x |
gnorm <- ((d1 * guv(fit.y1.z1, fit.y2.z1, rho)) - |
| 569 | 62x |
(d2 * guv(fit.y1.z2, fit.y2.z1, rho)) - |
| 570 | 62x |
(d3 * guv(fit.y1.z1, fit.y2.z2, rho)) + |
| 571 | 62x |
(d4 * guv(fit.y1.z2, fit.y2.z2, rho))) |
| 572 | ||
| 573 | 62x |
if (is.null(wt)) {
|
| 574 | 62x |
H <- sum(gnorm / lik - (phi * phi) / (lik * lik), na.rm = TRUE) |
| 575 |
} else {
|
|
| 576 | ! |
H <- sum(wt * (gnorm / lik - (phi * phi) / (lik * lik)), na.rm = TRUE) |
| 577 |
} |
|
| 578 | ||
| 579 | 62x |
dim(H) <- c(1L, 1L) |
| 580 |
} |
|
| 581 | ||
| 582 | 62x |
return(H) |
| 583 |
}) |
|
| 584 |
} |
|
| 585 | ||
| 586 | ||
| 587 | ||
| 588 |
# compute total (log)likelihood, for specific 'x' (nlminb) |
|
| 589 |
lav_bvord_min_objective <- function(x, cache = NULL) {
|
|
| 590 | 84x |
cache$theta <- x |
| 591 | 84x |
-1 * lav_bvord_logl_cache(cache = cache) / cache$N |
| 592 |
} |
|
| 593 | ||
| 594 |
# compute gradient, for specific 'x' (nlminb) |
|
| 595 |
lav_bvord_min_gradient <- function(x, cache = NULL) {
|
|
| 596 |
# check if x has changed |
|
| 597 | 62x |
if (!all(x == cache$theta)) {
|
| 598 | ! |
cache$theta <- x |
| 599 | ! |
tmp <- lav_bvord_logl_cache(cache = cache) |
| 600 |
} |
|
| 601 | 62x |
-1 * lav_bvord_gradient_cache(cache = cache) / cache$N |
| 602 |
} |
|
| 603 | ||
| 604 |
# compute hessian, for specific 'x' (nlminb) |
|
| 605 |
lav_bvord_min_hessian <- function(x, cache = NULL) {
|
|
| 606 |
# check if x has changed |
|
| 607 | 62x |
if (!all(x == cache$theta)) {
|
| 608 | ! |
cache$theta <- x |
| 609 | ! |
tmp <- lav_bvord_logl_cache(cache = cache) |
| 610 | ! |
tmp <- lav_bvord_gradient_cache(cache = cache) |
| 611 |
} |
|
| 612 | 62x |
-1 * lav_bvord_hessian_cache(cache = cache) / cache$N |
| 613 |
} |
|
| 614 | ||
| 615 | ||
| 616 | ||
| 617 | ||
| 618 |
# casewise scores |
|
| 619 |
lav_bvord_cor_scores_cache <- function(cache = NULL, na.zero = FALSE, |
|
| 620 |
use.weights = TRUE) {
|
|
| 621 | 12x |
with(cache, {
|
| 622 | 12x |
rho <- theta[1L] |
| 623 | 12x |
R <- sqrt(1 - rho * rho) |
| 624 | ||
| 625 |
# lik |
|
| 626 | 12x |
lik <- lav_bvord_lik_cache(cache = cache) |
| 627 | 12x |
bad.idx <- which(lik <= sqrt(.Machine$double.eps)) |
| 628 | 12x |
if (length(bad.idx) > 0L) {
|
| 629 | ! |
lik[bad.idx] <- as.numeric(NA) |
| 630 |
} |
|
| 631 | ||
| 632 | 12x |
d.y1.z1 <- dnorm(fit.y1.z1) |
| 633 | 12x |
d.y1.z2 <- dnorm(fit.y1.z2) |
| 634 | 12x |
d.y2.z1 <- dnorm(fit.y2.z1) |
| 635 | 12x |
d.y2.z2 <- dnorm(fit.y2.z2) |
| 636 | ||
| 637 |
# th.y1 |
|
| 638 | 12x |
if (identical(R, 0.0)) {
|
| 639 | ! |
y1.Z1 <- d.y1.z1 * 0.5 |
| 640 | ! |
y1.Z2 <- d.y1.z2 * 0.5 |
| 641 |
} else {
|
|
| 642 | 12x |
y1.Z1 <- (d.y1.z1 * pnorm((fit.y2.z1 - rho * fit.y1.z1) / R) - |
| 643 | 12x |
d.y1.z1 * pnorm((fit.y2.z2 - rho * fit.y1.z1) / R)) |
| 644 | 12x |
y1.Z2 <- (d.y1.z2 * pnorm((fit.y2.z1 - rho * fit.y1.z2) / R) - |
| 645 | 12x |
d.y1.z2 * pnorm((fit.y2.z2 - rho * fit.y1.z2) / R)) |
| 646 |
} |
|
| 647 | 12x |
dx.th.y1 <- (y1.Y1 * y1.Z1 - y1.Y2 * y1.Z2) / lik |
| 648 | 12x |
if (na.zero) {
|
| 649 | ! |
dx.th.y1[is.na(dx.th.y1)] <- 0 |
| 650 |
} |
|
| 651 | ||
| 652 |
# th.y2 |
|
| 653 | 12x |
if (identical(R, 0.0)) {
|
| 654 | ! |
y2.Z1 <- d.y2.z1 * 0.5 |
| 655 | ! |
y2.Z2 <- d.y2.z2 * 0.5 |
| 656 |
} else {
|
|
| 657 | 12x |
y2.Z1 <- (d.y2.z1 * pnorm((fit.y1.z1 - rho * fit.y2.z1) / R) - |
| 658 | 12x |
d.y2.z1 * pnorm((fit.y1.z2 - rho * fit.y2.z1) / R)) |
| 659 | 12x |
y2.Z2 <- (d.y2.z2 * pnorm((fit.y1.z1 - rho * fit.y2.z2) / R) - |
| 660 | 12x |
d.y2.z2 * pnorm((fit.y1.z2 - rho * fit.y2.z2) / R)) |
| 661 |
} |
|
| 662 | 12x |
dx.th.y2 <- (y2.Y1 * y2.Z1 - y2.Y2 * y2.Z2) / lik |
| 663 | 12x |
if (na.zero) {
|
| 664 | ! |
dx.th.y2[is.na(dx.th.y2)] <- 0 |
| 665 |
} |
|
| 666 | ||
| 667 |
# slopes |
|
| 668 | 12x |
dx.sl.y1 <- dx.sl.y2 <- NULL |
| 669 | 12x |
if (nexo > 0L) {
|
| 670 |
# sl.y1 |
|
| 671 | 12x |
dx.sl.y1 <- (y1.Z2 - y1.Z1) * eXo / lik |
| 672 | 12x |
if (na.zero) {
|
| 673 | ! |
dx.sl.y1[is.na(dx.sl.y1)] <- 0 |
| 674 |
} |
|
| 675 | ||
| 676 |
# sl.y2 |
|
| 677 | 12x |
dx.sl.y2 <- (y2.Z2 - y2.Z1) * eXo / lik |
| 678 | 12x |
if (na.zero) {
|
| 679 | ! |
dx.sl.y2[is.na(dx.sl.y2)] <- 0 |
| 680 |
} |
|
| 681 |
} |
|
| 682 | ||
| 683 |
# rho |
|
| 684 | 12x |
if (nexo == 0L) {
|
| 685 | ! |
phi <- lav_bvord_noexo_phi_cache(cache) |
| 686 | ! |
dx <- phi[cbind(Y1, Y2)] |
| 687 |
} else {
|
|
| 688 | 12x |
dx <- (lav_dbinorm(fit.y1.z1, fit.y2.z1, rho) - |
| 689 | 12x |
lav_dbinorm(fit.y1.z2, fit.y2.z1, rho) - |
| 690 | 12x |
lav_dbinorm(fit.y1.z1, fit.y2.z2, rho) + |
| 691 | 12x |
lav_dbinorm(fit.y1.z2, fit.y2.z2, rho)) |
| 692 |
} |
|
| 693 | 12x |
dx.rho <- dx / lik |
| 694 | 12x |
if (na.zero) {
|
| 695 | ! |
dx.rho[is.na(dx.rho)] <- 0 |
| 696 |
} |
|
| 697 | ||
| 698 | 12x |
if (!is.null(wt) && use.weights) {
|
| 699 | ! |
dx.th.y1 <- dx.th.y1 * wt |
| 700 | ! |
dx.th.y2 <- dx.th.y2 * wt |
| 701 | ! |
if (nexo > 0L) {
|
| 702 | ! |
dx.sl.y1 <- dx.sl.y1 * wt |
| 703 | ! |
dx.sl.y2 <- dx.sl.y2 * wt |
| 704 |
} |
|
| 705 | ! |
dx.rho <- dx.rho * wt |
| 706 |
} |
|
| 707 | ||
| 708 | 12x |
out <- list( |
| 709 | 12x |
dx.th.y1 = dx.th.y1, dx.th.y2 = dx.th.y2, |
| 710 | 12x |
dx.sl.y1 = dx.sl.y1, dx.sl.y2 = dx.sl.y2, dx.rho = dx.rho |
| 711 |
) |
|
| 712 | 12x |
return(out) |
| 713 |
}) |
|
| 714 |
} |
|
| 715 | ||
| 716 | ||
| 717 |
# casewise scores - no cache |
|
| 718 |
lav_bvord_cor_scores <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 719 |
rho = NULL, |
|
| 720 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 721 |
th.y1 = NULL, th.y2 = NULL, |
|
| 722 |
sl.y1 = NULL, sl.y2 = NULL, |
|
| 723 |
na.zero = FALSE, use.weights = TRUE) {
|
|
| 724 | 12x |
if (is.null(fit.y1)) {
|
| 725 | ! |
fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt) |
| 726 |
} |
|
| 727 | 12x |
if (is.null(fit.y2)) {
|
| 728 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 729 |
} |
|
| 730 | ||
| 731 |
# update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R) |
|
| 732 | 12x |
fit.y1 <- lav_uvord_update_fit( |
| 733 | 12x |
fit.y = fit.y1, |
| 734 | 12x |
th.new = th.y1, sl.new = sl.y1 |
| 735 |
) |
|
| 736 | 12x |
fit.y2 <- lav_uvord_update_fit( |
| 737 | 12x |
fit.y = fit.y2, |
| 738 | 12x |
th.new = th.y2, sl.new = sl.y2 |
| 739 |
) |
|
| 740 | ||
| 741 |
# create cache environment |
|
| 742 | 12x |
cache <- lav_bvord_init_cache( |
| 743 | 12x |
fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt, |
| 744 | 12x |
scores = TRUE |
| 745 |
) |
|
| 746 | 12x |
cache$theta <- rho |
| 747 | ||
| 748 | 12x |
SC <- lav_bvord_cor_scores_cache( |
| 749 | 12x |
cache = cache, na.zero = na.zero, |
| 750 | 12x |
use.weights = use.weights |
| 751 |
) |
|
| 752 | ||
| 753 | 12x |
SC |
| 754 |
} |
|
| 755 | ||
| 756 |
# logl - no cache |
|
| 757 |
lav_bvord_logl <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 758 |
rho = NULL, |
|
| 759 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 760 |
th.y1 = NULL, th.y2 = NULL, |
|
| 761 |
sl.y1 = NULL, sl.y2 = NULL) {
|
|
| 762 | ! |
if (is.null(fit.y1)) {
|
| 763 | ! |
fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt) |
| 764 |
} |
|
| 765 | ! |
if (is.null(fit.y2)) {
|
| 766 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 767 |
} |
|
| 768 | ||
| 769 |
# update z1/z2 if needed (used in lav_pml_dploglik_dimplied() in lav_model_gradient_pml.R) |
|
| 770 | ! |
fit.y1 <- lav_uvord_update_fit( |
| 771 | ! |
fit.y = fit.y1, |
| 772 | ! |
th.new = th.y1, sl.new = sl.y1 |
| 773 |
) |
|
| 774 | ! |
fit.y2 <- lav_uvord_update_fit( |
| 775 | ! |
fit.y = fit.y2, |
| 776 | ! |
th.new = th.y2, sl.new = sl.y2 |
| 777 |
) |
|
| 778 | ||
| 779 |
# create cache environment |
|
| 780 | ! |
cache <- lav_bvord_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt) |
| 781 | ! |
cache$theta <- rho |
| 782 | ||
| 783 | ! |
lav_bvord_logl_cache(cache = cache) |
| 784 |
} |
|
| 785 | ||
| 786 |
# lik - no cache |
|
| 787 |
lav_bvord_lik <- function(Y1, Y2, eXo = NULL, wt = NULL, |
|
| 788 |
rho = NULL, |
|
| 789 |
fit.y1 = NULL, fit.y2 = NULL, |
|
| 790 |
th.y1 = NULL, th.y2 = NULL, |
|
| 791 |
sl.y1 = NULL, sl.y2 = NULL, |
|
| 792 |
.log = FALSE) {
|
|
| 793 | ! |
if (is.null(fit.y1)) {
|
| 794 | ! |
fit.y1 <- lav_uvord_fit(y = Y1, X = eXo, wt = wt) |
| 795 |
} |
|
| 796 | ! |
if (is.null(fit.y2)) {
|
| 797 | ! |
fit.y2 <- lav_uvord_fit(y = Y2, X = eXo, wt = wt) |
| 798 |
} |
|
| 799 | ||
| 800 |
# update fit.y1/fit.y2 |
|
| 801 | ! |
fit.y1 <- lav_uvord_update_fit( |
| 802 | ! |
fit.y = fit.y1, |
| 803 | ! |
th.new = th.y1, sl.new = sl.y1 |
| 804 |
) |
|
| 805 | ! |
fit.y2 <- lav_uvord_update_fit( |
| 806 | ! |
fit.y = fit.y2, |
| 807 | ! |
th.new = th.y2, sl.new = sl.y2 |
| 808 |
) |
|
| 809 | ||
| 810 |
# create cache environment |
|
| 811 | ! |
cache <- lav_bvord_init_cache(fit.y1 = fit.y1, fit.y2 = fit.y2, wt = wt) |
| 812 | ! |
cache$theta <- rho |
| 813 | ||
| 814 | ! |
lik <- lav_bvord_lik_cache(cache = cache) # unweighted |
| 815 | ! |
if (.log) {
|
| 816 | ! |
lik <- log(lik) |
| 817 |
} |
|
| 818 | ||
| 819 | ! |
if (!is.null(wt)) {
|
| 820 | ! |
if (.log) {
|
| 821 | ! |
lik <- wt * lik |
| 822 |
} else {
|
|
| 823 | ! |
tmp <- wt * log(lik) |
| 824 | ! |
lik <- exp(tmp) |
| 825 |
} |
|
| 826 |
} |
|
| 827 | ||
| 828 | ! |
lik |
| 829 |
} |
|
| 830 | ||
| 831 |
# noexo_pi - for backwards compatibility |
|
| 832 |
lav_bvord_noexo_pi <- function(rho = NULL, th.y1 = NULL, th.y2 = NULL) {
|
|
| 833 | 6x |
nth.y1 <- length(th.y1) |
| 834 | 6x |
nth.y2 <- length(th.y2) |
| 835 | 6x |
pth.y1 <- pnorm(th.y1) |
| 836 | 6x |
pth.y2 <- pnorm(th.y2) |
| 837 | ||
| 838 |
# catch special case: rho = 0.0 |
|
| 839 | 6x |
if (rho == 0.0) {
|
| 840 | ! |
rowPI <- base::diff(c(0, pth.y1, 1)) |
| 841 | ! |
colPI <- base::diff(c(0, pth.y2, 1)) |
| 842 | ! |
PI.ij <- base::outer(rowPI, colPI) |
| 843 | ! |
return(PI.ij) |
| 844 |
} |
|
| 845 | ||
| 846 |
# prepare for a single call to pbinorm |
|
| 847 | 6x |
upper.y <- rep(th.y2, times = rep.int(nth.y1, nth.y2)) |
| 848 | 6x |
upper.x <- rep(th.y1, times = ceiling(length(upper.y)) / nth.y1) |
| 849 |
# rho <- rep(rho, length(upper.x)) # only one rho here |
|
| 850 | ||
| 851 | 6x |
BI <- pbivnorm::pbivnorm(x = upper.x, y = upper.y, rho = rho) |
| 852 | 6x |
dim(BI) <- c(nth.y1, nth.y2) |
| 853 | 6x |
BI <- rbind(0, BI, pth.y2, deparse.level = 0L) |
| 854 | 6x |
BI <- cbind(0, BI, c(0, pth.y1, 1), deparse.level = 0L) |
| 855 | ||
| 856 |
# get probabilities |
|
| 857 | 6x |
nr <- nrow(BI) |
| 858 | 6x |
nc <- ncol(BI) |
| 859 | 6x |
PI <- BI[-1L, -1L] - BI[-1L, -nc] - BI[-nr, -1L] + BI[-nr, -nc] |
| 860 | ||
| 861 |
# all elements should be strictly positive |
|
| 862 | 6x |
PI[PI < sqrt(.Machine$double.eps)] <- sqrt(.Machine$double.eps) |
| 863 | 6x |
PI |
| 864 |
} |
| 1 |
lav_samplestats_step1 <- function(Y, |
|
| 2 |
wt = NULL, # new in 0.6-6 |
|
| 3 |
ov.names = NULL, |
|
| 4 |
ov.types = NULL, |
|
| 5 |
ov.levels = NULL, |
|
| 6 |
ov.names.x = character(0L), |
|
| 7 |
eXo = NULL, |
|
| 8 |
scores.flag = TRUE, # scores? |
|
| 9 |
allow.empty.cell = TRUE, # allow empty categories? |
|
| 10 |
group = 1L) { # for error message
|
|
| 11 | ||
| 12 | ||
| 13 |
# just in case Y is a vector |
|
| 14 | 2x |
Y <- as.matrix(Y) |
| 15 | ||
| 16 | 2x |
nvar <- NCOL(Y) |
| 17 | 2x |
N <- NROW(Y) |
| 18 | 2x |
nTH <- ov.levels - 1L |
| 19 | 2x |
nTH[nTH == -1L] <- 1L |
| 20 | 2x |
nth <- sum(nTH) |
| 21 | 2x |
th.end.idx <- cumsum(nTH) |
| 22 | 2x |
th.start.idx <- th.end.idx - (nTH - 1L) |
| 23 | ||
| 24 |
# variable types; default = numeric |
|
| 25 | 2x |
nexo <- length(ov.names.x) |
| 26 | 2x |
if (nexo > 0L) stopifnot(NCOL(eXo) == nexo) |
| 27 | ||
| 28 |
# means/thresholds/intercepts, slopes, variances |
|
| 29 | 2x |
TH <- vector("list", length = nvar)
|
| 30 | 2x |
TH.NOX <- vector("list", length = nvar)
|
| 31 | 2x |
TH.NAMES <- vector("list", length = nvar)
|
| 32 | 2x |
TH.IDX <- vector("list", length = nvar)
|
| 33 | 2x |
SLOPES <- matrix(as.numeric(NA), nrow = nvar, ncol = nexo) # if conditional.x |
| 34 | 2x |
VAR <- numeric(length = nvar) # continuous variables only |
| 35 | ||
| 36 |
# SCORES |
|
| 37 | 2x |
SC.VAR <- matrix(0, N, nvar) |
| 38 | 2x |
SC.SL <- matrix(0, N, nvar * nexo) |
| 39 | 2x |
SC.TH <- matrix(0, N, nth) |
| 40 | ||
| 41 |
# fitted objects |
|
| 42 | 2x |
FIT <- vector("list", length = nvar)
|
| 43 | ||
| 44 |
# stage one - TH/SLOPES/VAR only |
|
| 45 | 2x |
for (i in 1:nvar) {
|
| 46 | 28x |
th.idx <- th.start.idx[i]:th.end.idx[i] |
| 47 | 28x |
sl.idx <- seq(i, by = nvar, length.out = nexo) |
| 48 | 28x |
if (ov.types[i] == "numeric") {
|
| 49 | 20x |
fit <- lav_uvreg_fit(y = Y[, i], X = eXo, wt = wt) |
| 50 | 20x |
if (any(is.na(fit$theta))) {
|
| 51 | ! |
lav_msg_stop(gettextf( |
| 52 | ! |
"linear regression failed for %1$s; |
| 53 | ! |
X may not be of full rank in group %2$s", ov.names[i], group)) |
| 54 |
} |
|
| 55 | 20x |
FIT[[i]] <- fit |
| 56 |
# compute mean and variance |
|
| 57 | 20x |
TH[[i]] <- TH.NOX[[i]] <- fit$theta[1L] |
| 58 | 20x |
VAR[i] <- fit$theta[fit$var.idx] |
| 59 | 20x |
TH.NAMES[[i]] <- ov.names[i] |
| 60 | 20x |
TH.IDX[[i]] <- 0L |
| 61 | 20x |
if (scores.flag) {
|
| 62 | 20x |
scores <- lav_uvreg_scores(y = Y[, i], X = eXo, wt = wt) |
| 63 | 20x |
SC.TH[, th.idx] <- scores[, 1L] |
| 64 | 20x |
SC.VAR[, i] <- scores[, fit$var.idx] |
| 65 |
} |
|
| 66 | 20x |
if (nexo > 0L) {
|
| 67 | 20x |
SLOPES[i, ] <- fit$theta[-c(1L, fit$var.idx)] |
| 68 | 20x |
if (scores.flag) {
|
| 69 | 20x |
SC.SL[, sl.idx] <- scores[, -c(1L, fit$var.idx), drop = FALSE] |
| 70 |
} |
|
| 71 | 20x |
TH.NOX[[i]] <- mean(Y[, i], na.rm = TRUE) |
| 72 |
} |
|
| 73 | 8x |
} else if (ov.types[i] == "ordered") {
|
| 74 |
# check if we have enough categories in this group |
|
| 75 |
# FIXME: should we more tolerant here??? |
|
| 76 | 8x |
y.freq <- tabulate(Y[, i], nbins = ov.levels[i]) |
| 77 | 8x |
if (length(y.freq) != ov.levels[i] & !allow.empty.cell) {
|
| 78 | ! |
lav_msg_stop(gettextf( |
| 79 | ! |
"variable %1$s has fewer categories (%2$s) than |
| 80 | ! |
expected (%3$s) in group %4$s", ov.names[i], |
| 81 | ! |
length(y.freq), ov.levels[i], group)) |
| 82 |
} |
|
| 83 | 8x |
if (any(y.freq == 0L) & !allow.empty.cell) {
|
| 84 | ! |
lav_msg_stop(gettextf( |
| 85 | ! |
"some categories of variable `%1$s' are empty in group %2$s; |
| 86 | ! |
frequencies are [%3$s]", ov.names[i], group, |
| 87 | ! |
lav_msg_view(y.freq, "none"))) |
| 88 |
} |
|
| 89 | 8x |
fit <- lav_uvord_fit(y = Y[, i], X = eXo, wt = wt) |
| 90 | 8x |
if (any(is.na(fit$theta))) {
|
| 91 | ! |
lav_msg_stop(gettextf( |
| 92 | ! |
"probit regression failed for %1$s; X may not be of full rank |
| 93 | ! |
in group %2$s", ov.names[i], group)) |
| 94 |
} |
|
| 95 | 8x |
FIT[[i]] <- fit |
| 96 | 8x |
TH[[i]] <- fit$theta[fit$th.idx] |
| 97 | 8x |
fit.nox <- lav_uvord_th(y = Y[, i], wt = wt) |
| 98 | 8x |
TH.NOX[[i]] <- fit.nox |
| 99 | 8x |
if (scores.flag) {
|
| 100 | 8x |
scores <- lav_uvord_scores(y = Y[, i], X = eXo, wt = wt) |
| 101 |
} |
|
| 102 | ||
| 103 | 8x |
if (allow.empty.cell) {
|
| 104 | ! |
if (any(y.freq == 0L)) {
|
| 105 |
## lav_uvord_fit drops thresholds if extreme categories are missing, but not otherwise |
|
| 106 | ! |
exidx <- rep(TRUE, (ov.levels[i] - 1)) |
| 107 | ! |
misidx <- !exidx |
| 108 | ! |
zidx <- y.freq == 0L |
| 109 | ! |
dz <- diff(zidx) == 1L |
| 110 | ! |
if (y.freq[ov.levels[i]] == 0L) {
|
| 111 | ! |
wdz <- which(dz) |
| 112 | ! |
nhi <- ov.levels[i] - wdz[length(wdz)] |
| 113 | ! |
exidx[(ov.levels[i] - nhi) : (ov.levels[i] - 1)] <- FALSE |
| 114 | ! |
misidx[(ov.levels[i] - nhi) : (ov.levels[i] - 1)] <- TRUE |
| 115 |
} |
|
| 116 | ! |
if (any(dz[-length(dz)])) {
|
| 117 | ! |
wdz <- which(dz[-length(dz)]) |
| 118 | ! |
exidx[wdz + 1] <- FALSE |
| 119 | ! |
misidx[wdz + 1] <- TRUE |
| 120 |
} |
|
| 121 | ! |
if (y.freq[1] == 0L) {
|
| 122 | ! |
nlow <- which( diff(zidx) == -1 )[1] |
| 123 | ! |
exidx[1:nlow] <- FALSE |
| 124 | ! |
misidx[1:nlow] <- TRUE |
| 125 |
} |
|
| 126 | ! |
TH[[i]] <- TH.NOX[[i]] <- rep(0, ov.levels[i] - 1) |
| 127 | ! |
TH[[i]][exidx] <- fit$theta[fit$th.idx] |
| 128 | ! |
TH.NOX[[i]][exidx] <- fit.nox[exidx] |
| 129 | ! |
for (k in which(misidx)) {
|
| 130 | ! |
if (k == 1) {
|
| 131 | ! |
TH[[i]][k] <- -4 |
| 132 | ! |
TH.NOX[[i]][k] <- -4 |
| 133 | ! |
} else if (k == (ov.levels[i] - 1)) {
|
| 134 | ! |
TH[[i]][k] <- 4 |
| 135 | ! |
TH.NOX[[i]][k] <- 4 |
| 136 |
} else {
|
|
| 137 | ! |
TH[[i]][k] <- TH[[i]][(k - 1)] + .01 |
| 138 | ! |
TH.NOX[[i]][k] <- TH.NOX[[i]][(k - 1)] + .01 |
| 139 |
} |
|
| 140 |
} |
|
| 141 | ! |
if (scores.flag) SC.TH[, th.idx[!misidx]] <- scores[, fit$th.idx, drop = FALSE] |
| 142 | ! |
} else if (length(y.freq) != ov.levels[i]) {
|
| 143 | ! |
nz <- ov.levels[i] - length(y.freq) |
| 144 | ! |
TH[[i]] <- c(TH[[i]], TH[[i]][length(y.freq)] + (1:nz) * .01) |
| 145 | ! |
if (scores.flag) SC.TH[, th.idx[1:length(y.freq)]] <- scores[, fit$th.idx, drop = FALSE] |
| 146 |
} |
|
| 147 | ! |
fit$th.idx <- 1:nTH[i] |
| 148 |
} else {
|
|
| 149 | 8x |
if (scores.flag) SC.TH[, th.idx] <- scores[, fit$th.idx, drop = FALSE] |
| 150 |
} |
|
| 151 | 8x |
SLOPES[i, ] <- fit$theta[fit$slope.idx] |
| 152 | 8x |
if (scores.flag) {
|
| 153 | 8x |
SC.SL[, sl.idx] <- scores[, fit$slope.idx, drop = FALSE] |
| 154 |
} |
|
| 155 | 8x |
VAR[i] <- 1.0 |
| 156 | 8x |
TH.NAMES[[i]] <- paste(ov.names[i], "|t", 1:length(TH[[i]]), |
| 157 | 8x |
sep = "" |
| 158 |
) |
|
| 159 | 8x |
TH.IDX[[i]] <- rep(i, length(TH[[i]])) |
| 160 |
} else {
|
|
| 161 | ! |
lav_msg_stop(gettext("unknown ov.types:"), ov.types[i])
|
| 162 |
} |
|
| 163 |
} |
|
| 164 | ||
| 165 | 2x |
list( |
| 166 | 2x |
FIT = FIT, VAR = VAR, SLOPES = SLOPES, |
| 167 | 2x |
TH = TH, TH.NOX = TH.NOX, TH.IDX = TH.IDX, TH.NAMES = TH.NAMES, |
| 168 | 2x |
SC.TH = SC.TH, SC.VAR = SC.VAR, SC.SL = SC.SL, |
| 169 | 2x |
th.start.idx = th.start.idx, th.end.idx = th.end.idx |
| 170 |
) |
|
| 171 |
} |
| 1 |
# compute logl for the unrestricted (h1) model -- per group |
|
| 2 |
lav_h1_logl <- function(lavdata = NULL, |
|
| 3 |
lavsamplestats = NULL, |
|
| 4 |
h1.implied = NULL, |
|
| 5 |
lavoptions = NULL) {
|
|
| 6 |
# number of groups |
|
| 7 | 75x |
ngroups <- lavdata@ngroups |
| 8 | ||
| 9 | 75x |
logl.group <- rep(as.numeric(NA), ngroups) |
| 10 | ||
| 11 |
# should compute logl, or return NA? |
|
| 12 | 75x |
logl.ok <- FALSE |
| 13 | 75x |
if (lavoptions$estimator %in% c("ML", "MML")) {
|
| 14 |
# check if everything is numeric, OR if we have exogenous |
|
| 15 |
# factor with 2 levels only |
|
| 16 | 65x |
if (all(lavdata@ov$type == "numeric")) {
|
| 17 | 65x |
logl.ok <- TRUE |
| 18 |
} else {
|
|
| 19 | ! |
not.idx <- which(lavdata@ov$type != "numeric") |
| 20 | ! |
for (i in not.idx) {
|
| 21 | ! |
if (lavdata@ov$type[i] == "factor" && |
| 22 | ! |
lavdata@ov$exo[i] == 1L && |
| 23 | ! |
lavdata@ov$nlev[i] == 2L) {
|
| 24 | ! |
logl.ok <- TRUE |
| 25 |
} else {
|
|
| 26 | ! |
logl.ok <- FALSE |
| 27 | ! |
break |
| 28 |
} |
|
| 29 |
} |
|
| 30 |
} |
|
| 31 |
} |
|
| 32 | ||
| 33 |
# lavsamplestats filled in? (not if no data, or samplestats = FALSE) |
|
| 34 | 75x |
if (length(lavsamplestats@ntotal) == 0L || |
| 35 | 75x |
(!is.null(lavoptions$samplestats) && !lavoptions$samplestats)) {
|
| 36 | ! |
logl.ok <- FALSE |
| 37 |
} |
|
| 38 | ||
| 39 |
# new in 0.6-9 (so SAM can handle N<P) |
|
| 40 | 75x |
if (!is.null(lavoptions$sample.icov) && !lavoptions$sample.icov) {
|
| 41 | ! |
logl.ok <- FALSE |
| 42 |
} |
|
| 43 | ||
| 44 | 75x |
if (logl.ok) {
|
| 45 | 65x |
for (g in seq_len(ngroups)) {
|
| 46 | 67x |
if (lavdata@nlevels > 1L) {
|
| 47 | ! |
current.verbose <- lav_verbose() |
| 48 | ! |
if (lav_verbose(FALSE)) |
| 49 | ! |
on.exit(lav_verbose(current.verbose), TRUE) |
| 50 | ! |
OUT <- lav_mvnorm_cluster_em_sat( |
| 51 | ! |
YLp = lavsamplestats@YLp[[g]], |
| 52 | ! |
Lp = lavdata@Lp[[g]], |
| 53 | ! |
tol = 1e-04, # option? |
| 54 | ! |
min.variance = 1e-05, # option? |
| 55 | ! |
max.iter = 5000L |
| 56 | ! |
) # option? |
| 57 | ! |
lav_verbose(current.verbose) |
| 58 |
# store logl per group |
|
| 59 | ! |
logl.group[g] <- OUT$logl |
| 60 | 67x |
} else if (lavsamplestats@missing.flag) {
|
| 61 | 8x |
logl.group[g] <- |
| 62 | 8x |
lav_mvnorm_missing_loglik_samplestats( |
| 63 | 8x |
Yp = lavsamplestats@missing[[g]], |
| 64 |
#Mu = lavsamplestats@missing.h1[[g]]$mu, |
|
| 65 | 8x |
Mu = h1.implied$mean[[g]], |
| 66 |
#Sigma = lavsamplestats@missing.h1[[g]]$sigma, |
|
| 67 | 8x |
Sigma = h1.implied$cov[[g]], |
| 68 | 8x |
x.idx = lavsamplestats@x.idx[[g]], |
| 69 | 8x |
x.mean = lavsamplestats@mean.x[[g]], |
| 70 | 8x |
x.cov = lavsamplestats@cov.x[[g]] |
| 71 |
) |
|
| 72 |
} else { # single-level, complete data
|
|
| 73 |
# all we need is: logdet of covariance matrix, nobs and nvar |
|
| 74 | 59x |
if (lavoptions$conditional.x) {
|
| 75 | ! |
logl.group[g] <- |
| 76 | ! |
lav_mvnorm_h1_loglik_samplestats( |
| 77 | ! |
sample.cov.logdet = |
| 78 | ! |
lavsamplestats@res.cov.log.det[[g]], |
| 79 | ! |
sample.nvar = |
| 80 | ! |
NCOL(lavsamplestats@res.cov[[g]]), |
| 81 | ! |
sample.nobs = lavsamplestats@nobs[[g]] |
| 82 |
) |
|
| 83 |
} else {
|
|
| 84 | 59x |
logl.group[g] <- |
| 85 | 59x |
lav_mvnorm_h1_loglik_samplestats( |
| 86 | 59x |
sample.cov.logdet = lavsamplestats@cov.log.det[[g]], |
| 87 | 59x |
sample.nvar = NCOL(lavsamplestats@cov[[g]]), |
| 88 | 59x |
sample.nobs = lavsamplestats@nobs[[g]], |
| 89 | 59x |
x.idx = lavsamplestats@x.idx[[g]], |
| 90 | 59x |
x.cov = lavsamplestats@cov.x[[g]] |
| 91 |
) |
|
| 92 |
} |
|
| 93 |
} # complete |
|
| 94 |
} # g |
|
| 95 |
} # logl.ok is TRUE |
|
| 96 | ||
| 97 | 75x |
out <- list( |
| 98 | 75x |
loglik = sum(logl.group), |
| 99 | 75x |
loglik.group = logl.group |
| 100 |
) |
|
| 101 | ||
| 102 | 75x |
out |
| 103 |
} |
| 1 |
lav_constraints_parse <- function(partable = NULL, constraints = NULL, |
|
| 2 |
theta = NULL, |
|
| 3 |
debug = FALSE) {
|
|
| 4 | 144x |
if (!missing(debug)) {
|
| 5 | ! |
current.debug <- lav_debug() |
| 6 | ! |
if (lav_debug(debug)) |
| 7 | ! |
on.exit(lav_debug(current.debug), TRUE) |
| 8 |
} |
|
| 9 |
# just in case we do not have a $free column in partable |
|
| 10 | 144x |
if (is.null(partable$free)) {
|
| 11 | ! |
partable$free <- seq_len(length(partable$lhs)) |
| 12 |
} |
|
| 13 | ||
| 14 |
# from the partable: free parameters |
|
| 15 | 144x |
if (!is.null(theta)) {
|
| 16 |
# nothing to do |
|
| 17 | 144x |
} else if (!is.null(partable$est)) {
|
| 18 | 36x |
theta <- partable$est[partable$free > 0L] |
| 19 | 108x |
} else if (!is.null(partable$start)) {
|
| 20 | 108x |
theta <- partable$start[partable$free > 0L] |
| 21 |
} else {
|
|
| 22 | ! |
theta <- rep(0, length(partable$lhs)) |
| 23 |
} |
|
| 24 | ||
| 25 |
# number of free (but possibliy constrained) parameters |
|
| 26 | 144x |
npar <- length(theta) |
| 27 | ||
| 28 |
# parse the constraints |
|
| 29 | 144x |
if (is.null(constraints)) {
|
| 30 | 144x |
LIST <- NULL |
| 31 | ! |
} else if (!is.character(constraints)) {
|
| 32 | ! |
lav_msg_stop(gettext("constraints should be a string"))
|
| 33 |
} else {
|
|
| 34 | ! |
FLAT <- lavParseModelString(constraints) |
| 35 | ! |
CON <- attr(FLAT, "constraints") |
| 36 | ! |
LIST <- list() |
| 37 | ! |
if (length(CON) > 0L) {
|
| 38 | ! |
lhs <- unlist(lapply(CON, "[[", "lhs")) |
| 39 | ! |
op <- unlist(lapply(CON, "[[", "op")) |
| 40 | ! |
rhs <- unlist(lapply(CON, "[[", "rhs")) |
| 41 | ! |
LIST$lhs <- c(LIST$lhs, lhs) |
| 42 | ! |
LIST$op <- c(LIST$op, op) |
| 43 | ! |
LIST$rhs <- c(LIST$rhs, rhs) |
| 44 |
} else {
|
|
| 45 | ! |
lav_msg_stop(gettext("no constraints found in constraints argument"))
|
| 46 |
} |
|
| 47 |
} |
|
| 48 | ||
| 49 |
# simple equality constraints? |
|
| 50 | 144x |
ceq.simple <- FALSE |
| 51 | 144x |
if (!is.null(partable$unco)) {
|
| 52 | ! |
ceq.simple <- TRUE |
| 53 |
} |
|
| 54 | ||
| 55 |
# simple inequality constraints? |
|
| 56 | 144x |
cin.simple <- TRUE |
| 57 | 144x |
if (any(partable$op %in% c(">", "<"))) {
|
| 58 | 2x |
cin.simple <- FALSE |
| 59 |
} |
|
| 60 | 144x |
if (!is.null(LIST) && any(LIST$op %in% c(">", "<"))) {
|
| 61 | ! |
cin.simple <- FALSE |
| 62 |
} |
|
| 63 | 144x |
if (is.null(partable$upper) && is.null(partable$lower)) {
|
| 64 | 61x |
cin.simple <- FALSE |
| 65 |
} else {
|
|
| 66 |
# only check free parameters! |
|
| 67 | 83x |
free.idx <- which(partable$free > 0L) |
| 68 | 83x |
if (all(partable$lower[free.idx] == -Inf) && |
| 69 | 83x |
all(partable$upper[free.idx] == +Inf)) {
|
| 70 | ! |
cin.simple <- FALSE |
| 71 |
} |
|
| 72 |
} |
|
| 73 | ||
| 74 |
# variable definitions |
|
| 75 | 144x |
def.function <- lav_partable_constraints_def(partable, |
| 76 | 144x |
con = LIST, |
| 77 | 144x |
debug = debug |
| 78 |
) |
|
| 79 | ||
| 80 |
# construct ceq/ciq functions |
|
| 81 | 144x |
ceq.function <- lav_partable_constraints_ceq(partable, |
| 82 | 144x |
con = LIST, |
| 83 | 144x |
debug = debug |
| 84 |
) |
|
| 85 |
# linear or nonlinear? |
|
| 86 | 144x |
ceq.linear.idx <- lav_constraints_linear_idx( |
| 87 | 144x |
func = ceq.function, |
| 88 | 144x |
npar = npar |
| 89 |
) |
|
| 90 | 144x |
ceq.nonlinear.idx <- lav_constraints_nonlinear_idx( |
| 91 | 144x |
func = ceq.function, |
| 92 | 144x |
npar = npar |
| 93 |
) |
|
| 94 | ||
| 95 |
# inequalities |
|
| 96 | 144x |
cin.function <- lav_partable_constraints_ciq(partable, |
| 97 | 144x |
con = LIST, |
| 98 | 144x |
debug = debug |
| 99 |
) |
|
| 100 | ||
| 101 |
# linear or nonlinear? |
|
| 102 | 144x |
cin.linear.idx <- lav_constraints_linear_idx( |
| 103 | 144x |
func = cin.function, |
| 104 | 144x |
npar = npar |
| 105 |
) |
|
| 106 | 144x |
cin.nonlinear.idx <- lav_constraints_nonlinear_idx( |
| 107 | 144x |
func = cin.function, |
| 108 | 144x |
npar = npar |
| 109 |
) |
|
| 110 | ||
| 111 |
# Jacobians |
|
| 112 | 144x |
if (!is.null(body(ceq.function))) {
|
| 113 | 10x |
ceq.JAC <- try(lav_func_jacobian_complex( |
| 114 | 10x |
func = ceq.function, |
| 115 | 10x |
x = theta |
| 116 | 10x |
), silent = TRUE) |
| 117 | 10x |
if (inherits(ceq.JAC, "try-error")) { # eg. pnorm()
|
| 118 | ! |
ceq.JAC <- lav_func_jacobian_simple(func = ceq.function, x = theta) |
| 119 |
} |
|
| 120 | ||
| 121 |
# constants |
|
| 122 |
# do we have a non-zero 'rhs' elements? FIXME!!! is this reliable?? |
|
| 123 | 10x |
ceq.rhs <- -1 * ceq.function(numeric(npar)) |
| 124 | ||
| 125 |
# evaluate constraints |
|
| 126 | 10x |
ceq.theta <- ceq.function(theta) |
| 127 |
} else {
|
|
| 128 | 134x |
ceq.JAC <- matrix(0, nrow = 0L, ncol = npar) |
| 129 | 134x |
ceq.rhs <- numeric(0L) |
| 130 | 134x |
ceq.theta <- numeric(0L) |
| 131 |
} |
|
| 132 | ||
| 133 | 144x |
if (!is.null(body(cin.function))) {
|
| 134 | 85x |
cin.JAC <- try(lav_func_jacobian_complex( |
| 135 | 85x |
func = cin.function, |
| 136 | 85x |
x = theta |
| 137 | 85x |
), silent = TRUE) |
| 138 | 85x |
if (inherits(cin.JAC, "try-error")) { # eg. pnorm()
|
| 139 | ! |
cin.JAC <- lav_func_jacobian_simple(func = cin.function, x = theta) |
| 140 |
} |
|
| 141 | ||
| 142 |
# constants |
|
| 143 |
# do we have a non-zero 'rhs' elements? FIXME!!! is this reliable?? |
|
| 144 | 85x |
cin.rhs <- -1 * cin.function(numeric(npar)) |
| 145 | ||
| 146 |
# evaluate constraints |
|
| 147 | 85x |
cin.theta <- cin.function(theta) |
| 148 |
} else {
|
|
| 149 | 59x |
cin.JAC <- matrix(0, nrow = 0L, ncol = npar) |
| 150 | 59x |
cin.rhs <- numeric(0L) |
| 151 | 59x |
cin.theta <- numeric(0L) |
| 152 |
} |
|
| 153 | ||
| 154 |
# check for empty/unused constraints (new in 0.6-22) |
|
| 155 | 144x |
if(nrow(ceq.JAC) > 0L) {
|
| 156 | 10x |
if (all(ceq.JAC == 0)) {
|
| 157 | ! |
ceq.JAC <- matrix(0, nrow = 0L, ncol = npar) |
| 158 | ! |
ceq.rhs <- numeric(0L) |
| 159 | ! |
ceq.theta <- numeric(0L) |
| 160 | ! |
ceq.linear.idx <- integer(0L) |
| 161 | ! |
ceq.nonlinear.idx <- integer(0L) |
| 162 |
} else {
|
|
| 163 | 10x |
zero.idx <- which(apply(ceq.JAC, 1, function(x) all(x == 0))) |
| 164 | 10x |
if (length(zero.idx) > 0L) {
|
| 165 | ! |
ceq.JAC <- ceq.JAC[-zero.idx, , drop = FALSE] |
| 166 | ! |
ceq.rhs <- ceq.rhs[-zero.idx] |
| 167 | ! |
ceq.theta <- ceq.theta[-zero.idx] |
| 168 |
# hm, how to hande these? indices no longer match rows of ceq.JAC! |
|
| 169 | ! |
ceq.linear.idx <- ceq.linear.idx[!ceq.linear.idx %in% zero.idx] |
| 170 | ! |
ceq.nonlinear.idx <- ceq.nonlinear.idx[!ceq.nonlinear.idx %in% zero.idx] |
| 171 |
} |
|
| 172 |
} |
|
| 173 |
} |
|
| 174 | 144x |
if(nrow(cin.JAC) > 0L) {
|
| 175 | 85x |
if (all(cin.JAC == 0)) {
|
| 176 | ! |
cin.JAC <- matrix(0, nrow = 0L, ncol = npar) |
| 177 | ! |
cin.rhs <- numeric(0L) |
| 178 | ! |
cin.theta <- numeric(0L) |
| 179 | ! |
cin.linear.idx <- integer(0L) |
| 180 | ! |
cin.nonlinear.idx <- integer(0L) |
| 181 |
} else {
|
|
| 182 | 85x |
zero.idx <- which(apply(cin.JAC, 1, function(x) all(x == 0))) |
| 183 | 85x |
if (length(zero.idx) > 0L) {
|
| 184 | ! |
cin.JAC <- cin.JAC[-zero.idx, , drop = FALSE] |
| 185 | ! |
cin.rhs <- cin.rhs[-zero.idx] |
| 186 | ! |
cin.theta <- cin.theta[-zero.idx] |
| 187 |
# hm, how to hande these? indices no longer match rows of cin.JAC! |
|
| 188 | ! |
cin.linear.idx <- cin.linear.idx[!cin.linear.idx %in% zero.idx] |
| 189 | ! |
cin.nonlinear.idx <- cin.nonlinear.idx[!cin.nonlinear.idx %in% zero.idx] |
| 190 |
} |
|
| 191 |
} |
|
| 192 |
} |
|
| 193 | ||
| 194 |
# shortcut flags |
|
| 195 | 144x |
ceq.linear.flag <- length(ceq.linear.idx) > 0L |
| 196 | 144x |
ceq.nonlinear.flag <- length(ceq.nonlinear.idx) > 0L |
| 197 | 144x |
ceq.flag <- ceq.linear.flag || ceq.nonlinear.flag |
| 198 | ||
| 199 | 144x |
cin.linear.flag <- length(cin.linear.idx) > 0L |
| 200 | 144x |
cin.nonlinear.flag <- length(cin.nonlinear.idx) > 0L |
| 201 | 144x |
cin.flag <- cin.linear.flag || cin.nonlinear.flag |
| 202 | 144x |
if (cin.simple) {
|
| 203 | 83x |
cin.flag <- FALSE |
| 204 |
} |
|
| 205 | ||
| 206 | 144x |
ceq.only.flag <- ceq.flag && !cin.flag |
| 207 | 144x |
cin.only.flag <- cin.flag && !ceq.flag |
| 208 | ||
| 209 | 144x |
ceq.linear.only.flag <- (ceq.linear.flag && |
| 210 | 144x |
!ceq.nonlinear.flag && |
| 211 | 144x |
!cin.flag && !cin.simple) |
| 212 | ||
| 213 | 144x |
ceq.simple.only <- ceq.simple && !ceq.flag && !cin.flag |
| 214 | 144x |
cin.simple.only <- cin.simple && !ceq.linear.flag |
| 215 | ||
| 216 |
# additional info if ceq.linear.flag |
|
| 217 | 144x |
if (ceq.linear.only.flag) {
|
| 218 |
## NEW: 18 nov 2014: handle general *linear* constraints |
|
| 219 |
## |
|
| 220 |
## see Nocedal & Wright (2006) 15.3 |
|
| 221 |
## - from x to x.red: |
|
| 222 |
## x.red <- MASS::ginv(Q2) %*% (x - Q1 %*% solve(t(R)) %*% b) |
|
| 223 |
## or |
|
| 224 |
## x.red <- as.numeric((x - b %*% qr.coef(QR,diag(npar))) %*% Q2) |
|
| 225 |
## |
|
| 226 |
## - from x.red to x |
|
| 227 |
## x <- as.numeric(Q1 %*% solve(t(R)) %*% b + Q2 %*% x.red) |
|
| 228 |
## or |
|
| 229 |
## x <- as.numeric(b %*% qr.coef(QR, diag(npar))) + |
|
| 230 |
## as.numeric(Q2 %*% x.red) |
|
| 231 |
## |
|
| 232 |
## we write eq.constraints.K = Q2 |
|
| 233 |
## eq.constraints.k0 = b %*% qr.coef(QR, diag(npar))) |
|
| 234 | ||
| 235 |
# compute range+null space of the jacobion (JAC) of the constraint |
|
| 236 |
# matrix |
|
| 237 |
# JAC <- lav_func_jacobian_complex(func = ceq.function, |
|
| 238 |
# x = lavpartable$start[lavpartable$free > 0L] |
|
| 239 | 10x |
QR <- qr(t(ceq.JAC)) |
| 240 | 10x |
ranK <- QR$rank |
| 241 | 10x |
Q <- qr.Q(QR, complete = TRUE) |
| 242 |
# Q1 <- Q[,1:ranK, drop = FALSE] # range space |
|
| 243 |
# Q2 <- Q[,-seq_len(ranK), drop = FALSE] # null space |
|
| 244 |
# R <- qr.R(QR) |
|
| 245 | 10x |
ceq.JAC.NULL <- Q[, -seq_len(ranK), drop = FALSE] |
| 246 | ||
| 247 | 10x |
if (all(ceq.rhs == 0)) {
|
| 248 | 10x |
ceq.rhs.NULL <- numeric(npar) |
| 249 |
} else {
|
|
| 250 | ! |
tmp <- qr.coef(QR, diag(npar)) |
| 251 | ! |
NA.idx <- which(is.na(rowSums(tmp))) # catch NAs |
| 252 | ! |
if (length(NA.idx) > 0L) {
|
| 253 | ! |
tmp[NA.idx, ] <- 0 |
| 254 |
} |
|
| 255 | ! |
ceq.rhs.NULL <- as.numeric(ceq.rhs %*% tmp) |
| 256 |
} |
|
| 257 |
} else {
|
|
| 258 | 134x |
ceq.JAC.NULL <- matrix(0, 0L, 0L) |
| 259 | 134x |
ceq.rhs.NULL <- numeric(0L) |
| 260 |
} |
|
| 261 | ||
| 262 |
# if simple equalities only, create 'K' matrix |
|
| 263 | 144x |
ceq.simple.K <- matrix(0, 0, 0) |
| 264 | 144x |
if (ceq.simple.only) {
|
| 265 | ! |
n.unco <- max(partable$unco) |
| 266 | ! |
n.free <- max(partable$free) |
| 267 | ! |
ceq.simple.K <- matrix(0, nrow = n.unco, ncol = n.free) |
| 268 |
##### |
|
| 269 |
##### FIXME ! |
|
| 270 |
##### |
|
| 271 | ! |
idx.free <- partable$free[partable$free > 0] |
| 272 | ! |
for (k in 1:n.unco) {
|
| 273 | ! |
c <- idx.free[k] |
| 274 | ! |
ceq.simple.K[k, c] <- 1 |
| 275 |
} |
|
| 276 |
} |
|
| 277 | ||
| 278 |
# dummy jacobian 'function' |
|
| 279 | 144x |
ceq.jacobian <- function() NULL |
| 280 | 144x |
cin.jacobian <- function() NULL |
| 281 | ||
| 282 | ||
| 283 | 144x |
OUT <- list( |
| 284 | 144x |
def.function = def.function, |
| 285 | 144x |
ceq.function = ceq.function, |
| 286 | 144x |
ceq.JAC = ceq.JAC, |
| 287 | 144x |
ceq.jacobian = ceq.jacobian, |
| 288 | 144x |
ceq.rhs = ceq.rhs, |
| 289 | 144x |
ceq.theta = ceq.theta, |
| 290 | 144x |
ceq.linear.idx = ceq.linear.idx, |
| 291 | 144x |
ceq.nonlinear.idx = ceq.nonlinear.idx, |
| 292 | 144x |
ceq.linear.flag = ceq.linear.flag, |
| 293 | 144x |
ceq.nonlinear.flag = ceq.nonlinear.flag, |
| 294 | 144x |
ceq.flag = ceq.flag, |
| 295 | 144x |
ceq.linear.only.flag = ceq.linear.only.flag, |
| 296 | 144x |
ceq.JAC.NULL = ceq.JAC.NULL, |
| 297 | 144x |
ceq.rhs.NULL = ceq.rhs.NULL, |
| 298 | 144x |
ceq.simple.only = ceq.simple.only, |
| 299 | 144x |
ceq.simple.K = ceq.simple.K, |
| 300 | 144x |
cin.function = cin.function, |
| 301 | 144x |
cin.JAC = cin.JAC, |
| 302 | 144x |
cin.jacobian = cin.jacobian, |
| 303 | 144x |
cin.rhs = cin.rhs, |
| 304 | 144x |
cin.theta = cin.theta, |
| 305 | 144x |
cin.linear.idx = cin.linear.idx, |
| 306 | 144x |
cin.nonlinear.idx = cin.nonlinear.idx, |
| 307 | 144x |
cin.linear.flag = cin.linear.flag, |
| 308 | 144x |
cin.nonlinear.flag = cin.nonlinear.flag, |
| 309 | 144x |
cin.flag = cin.flag, |
| 310 | 144x |
cin.only.flag = cin.only.flag, |
| 311 | 144x |
cin.simple.only = cin.simple.only |
| 312 |
) |
|
| 313 | ||
| 314 | 144x |
OUT |
| 315 |
} |
|
| 316 | ||
| 317 |
lav_constraints_linear_idx <- function(func = NULL, npar = NULL) {
|
|
| 318 | 288x |
if (is.null(func) || is.null(body(func))) {
|
| 319 | 193x |
return(integer(0L)) |
| 320 |
} |
|
| 321 | ||
| 322 |
# seed 1: rnorm |
|
| 323 | 95x |
A0 <- lav_func_jacobian_complex(func = func, x = rnorm(npar)) |
| 324 | ||
| 325 |
# seed 2: rnorm |
|
| 326 | 95x |
A1 <- lav_func_jacobian_complex(func = func, x = rnorm(npar)) |
| 327 | ||
| 328 | 95x |
A0minA1 <- A0 - A1 |
| 329 | 95x |
linear <- apply(A0minA1, 1, function(x) all(x == 0)) |
| 330 | 95x |
which(linear) |
| 331 |
} |
|
| 332 | ||
| 333 |
lav_constraints_nonlinear_idx <- function(func = NULL, npar = NULL) {
|
|
| 334 | 288x |
if (is.null(func) || is.null(body(func))) {
|
| 335 | 193x |
return(integer(0L)) |
| 336 |
} |
|
| 337 | ||
| 338 |
# seed 1: rnorm |
|
| 339 | 95x |
A0 <- lav_func_jacobian_complex(func = func, x = rnorm(npar)) |
| 340 | ||
| 341 |
# seed 2: rnorm |
|
| 342 | 95x |
A1 <- lav_func_jacobian_complex(func = func, x = rnorm(npar)) |
| 343 | ||
| 344 | 95x |
A0minA1 <- A0 - A1 |
| 345 | 95x |
linear <- apply(A0minA1, 1, function(x) all(x == 0)) |
| 346 | 95x |
which(!linear) |
| 347 |
} |
|
| 348 | ||
| 349 | ||
| 350 |
# FIXME: is there a more elegant/robust way to do this?? |
|
| 351 |
lav_constraints_check_linear <- function(model) {
|
|
| 352 |
# seed 1: rnorm |
|
| 353 | ! |
A.ceq <- A.cin <- matrix(0, model@nx.free, 0) |
| 354 | ! |
if (!is.null(body(model@ceq.function))) {
|
| 355 | ! |
A.ceq <- t(lav_func_jacobian_complex(func = model@ceq.function, x = rnorm(model@nx.free))) |
| 356 |
} |
|
| 357 | ! |
if (!is.null(body(model@cin.function))) {
|
| 358 | ! |
A.cin <- t(lav_func_jacobian_complex(func = model@cin.function, x = rnorm(model@nx.free))) |
| 359 |
} |
|
| 360 | ! |
A0 <- cbind(A.ceq, A.cin) |
| 361 | ||
| 362 |
# seed 2: rnorm |
|
| 363 | ! |
A.ceq <- A.cin <- matrix(0, model@nx.free, 0) |
| 364 | ! |
if (!is.null(body(model@ceq.function))) {
|
| 365 | ! |
A.ceq <- t(lav_func_jacobian_complex(func = model@ceq.function, x = rnorm(model@nx.free))) |
| 366 |
} |
|
| 367 | ! |
if (!is.null(body(model@cin.function))) {
|
| 368 | ! |
A.cin <- t(lav_func_jacobian_complex(func = model@cin.function, x = rnorm(model@nx.free))) |
| 369 |
} |
|
| 370 | ! |
A1 <- cbind(A.ceq, A.cin) |
| 371 | ||
| 372 | ! |
A0minA1 <- all.equal(A0, A1) |
| 373 | ! |
if (is.logical(A0minA1) && A0minA1 == TRUE) {
|
| 374 | ! |
return(TRUE) |
| 375 |
} else {
|
|
| 376 | ! |
return(FALSE) |
| 377 |
} |
|
| 378 |
} |
|
| 379 | ||
| 380 |
# check if the equality constraints are 'simple' (a == b) |
|
| 381 |
lav_constraints_check_simple <- function(lavmodel = NULL) {
|
|
| 382 | 1x |
ones <- (lavmodel@ceq.JAC == 1 | lavmodel@ceq.JAC == -1) |
| 383 | 1x |
simple <- all(lavmodel@ceq.rhs == 0) && |
| 384 | 1x |
all(apply(lavmodel@ceq.JAC != 0, 1, sum) == 2) && |
| 385 | 1x |
all(apply(ones, 1, sum) == 2) && |
| 386 | 1x |
length(lavmodel@ceq.nonlinear.idx) == 0 |
| 387 | ||
| 388 |
# TRUE or FALSE |
|
| 389 | 1x |
simple |
| 390 |
} |
|
| 391 | ||
| 392 |
lav_constraints_R2K <- function(lavmodel = NULL, R = NULL) {
|
|
| 393 |
# constraint matrix |
|
| 394 | 1x |
if (!is.null(lavmodel)) {
|
| 395 | 1x |
R <- lavmodel@ceq.JAC |
| 396 |
} |
|
| 397 | 1x |
stopifnot(!is.null(R)) |
| 398 | ||
| 399 | 1x |
npar.full <- NCOL(R) |
| 400 | 1x |
npar.red <- npar.full - NROW(R) |
| 401 | ||
| 402 | 1x |
K <- diag(npar.full) |
| 403 | 1x |
for (i in 1:NROW(R)) {
|
| 404 | 40x |
idx1 <- which(R[i, ] == 1) |
| 405 | 40x |
idx2 <- which(R[i, ] == -1) |
| 406 | 40x |
K[idx2, idx1] <- 1 |
| 407 |
} |
|
| 408 | ||
| 409 |
# remove redundant columns |
|
| 410 | 1x |
neg.idx <- which(colSums(R) < 0) |
| 411 | 1x |
K <- K[, -neg.idx] |
| 412 | ||
| 413 | 1x |
K |
| 414 |
} |
|
| 415 | ||
| 416 |
lav_constraints_lambda_pre <- function(lavobject = NULL, method = "Don") {
|
|
| 417 |
# compute factor 'pre' so that pre %*% g = lambda |
|
| 418 | 1x |
method <- tolower(method) |
| 419 | ||
| 420 | 1x |
R <- lavobject@Model@con.jac[, ] |
| 421 | 1x |
if (is.null(R) || length(R) == 0L) {
|
| 422 | ! |
return(numeric(0L)) |
| 423 |
} |
|
| 424 | ||
| 425 | 1x |
INFO <- lavTech(lavobject, "information.first.order") |
| 426 | 1x |
npar <- nrow(INFO) |
| 427 | ||
| 428 |
# Don 1985 |
|
| 429 | 1x |
if (method == "don") {
|
| 430 | 1x |
R.plus <- MASS::ginv(R) |
| 431 | ||
| 432 |
# construct augmented matrix |
|
| 433 | 1x |
Z <- rbind( |
| 434 | 1x |
cbind(INFO, t(R)), |
| 435 | 1x |
cbind(R, matrix(0, nrow = nrow(R), ncol = nrow(R))) |
| 436 |
) |
|
| 437 | 1x |
Z.plus <- MASS::ginv(Z) |
| 438 | 1x |
P.star <- Z.plus[1:npar, 1:npar] |
| 439 | 1x |
PRE <- t(R.plus) %*% (diag(npar) - INFO %*% P.star) |
| 440 | ||
| 441 |
# Bentler EQS manual |
|
| 442 | ! |
} else if (method == "bentler") {
|
| 443 | ! |
INFO.inv <- solve(INFO) |
| 444 | ! |
PRE <- solve(R %*% INFO.inv %*% t(R)) %*% R %*% INFO.inv |
| 445 |
} |
|
| 446 | ||
| 447 | 1x |
PRE |
| 448 |
} |
| 1 |
lav_lavaan_step16_rotation <- function(lavoptions = NULL, |
|
| 2 |
lavmodel = NULL, |
|
| 3 |
lavpartable = NULL, |
|
| 4 |
lavh1 = NULL, |
|
| 5 |
lavdata = NULL, |
|
| 6 |
x = NULL, |
|
| 7 |
lavvcov = NULL, |
|
| 8 |
VCOV = NULL, # nolint |
|
| 9 |
lavcache = NULL, |
|
| 10 |
lavimplied = NULL, |
|
| 11 |
lavsamplestats = NULL) {
|
|
| 12 |
# # # # # # # # # # # |
|
| 13 |
# # 16. rotation # # |
|
| 14 |
# # # # # # # # # # # |
|
| 15 | ||
| 16 |
# if lavmodel@nefa > 0L and lavoptions$rotation not "none" |
|
| 17 |
# store unrotated solution in partable (column est.unrotated) |
|
| 18 |
# rotate lavmodel via lav_model_efa_rotate and overwrite column est |
|
| 19 |
# in partable |
|
| 20 |
# if lavoptions$se not in none, bootstrap, external, twostep |
|
| 21 |
# if lavoptions$rotation.se == "delta" |
|
| 22 |
# re-compute vcov with delta rule (*) |
|
| 23 |
# re-compute SE and store them in lavpartable (*) |
|
| 24 |
# else if lavoptions$rotation.se == "bordered" |
|
| 25 |
# create 'new' partable where the user = 7/77 parameters are free (*) |
|
| 26 |
# |
|
| 27 |
# (*) code too complicated to summarize here |
|
| 28 | ||
| 29 | 140x |
if (lavmodel@nefa > 0L && |
| 30 | 140x |
(lavoptions$rotation != "none")) {
|
| 31 |
# store unrotated solution in partable |
|
| 32 | 4x |
lavpartable$est.unrotated <- lavpartable$est |
| 33 | 4x |
lavpartable$se.unrotated <- lavpartable$se |
| 34 | ||
| 35 |
# rotate, and create new lavmodel |
|
| 36 | 4x |
if (lav_verbose()) {
|
| 37 | ! |
cat( |
| 38 | ! |
"rotating EFA factors using rotation method =", |
| 39 | ! |
toupper(lavoptions$rotation), "..." |
| 40 |
) |
|
| 41 |
} |
|
| 42 | 4x |
x.unrotated <- as.numeric(x) |
| 43 | 4x |
lavmodel.unrot <- lavmodel |
| 44 | 4x |
efa.out <- lav_model_efa_rotate( |
| 45 | 4x |
lavmodel = lavmodel, |
| 46 | 4x |
lavoptions = lavoptions |
| 47 |
) |
|
| 48 | ||
| 49 |
# adapt partable: |
|
| 50 |
# - change 'free' column to reflect that user = 7/77 parameters are free |
|
| 51 |
# - save unrotated free column in free.unrotated |
|
| 52 | 4x |
lavpartable$free.unrotated <- lavpartable$free |
| 53 | 4x |
user7.idx <- which((lavpartable$user == 7L | lavpartable$user == 77L) & |
| 54 | 4x |
lavpartable$free == 0L) |
| 55 | 4x |
lavpartable$free[user7.idx] <- 1L |
| 56 | 4x |
lavpartable$free[lavpartable$free > 0L] <- |
| 57 | 4x |
seq_len(sum(lavpartable$free > 0L)) |
| 58 |
# avoid cin.simple entries for these user=7 parameters |
|
| 59 | 4x |
if (!is.null(lavpartable$lower)) {
|
| 60 | 4x |
lavpartable$lower[user7.idx] <- -Inf |
| 61 |
} |
|
| 62 | 4x |
if (!is.null(lavpartable$upper)) {
|
| 63 | 4x |
lavpartable$upper[user7.idx] <- +Inf |
| 64 |
} |
|
| 65 | ||
| 66 |
# create 'rotated' lavmodel, reflecting the 'new' free parameters |
|
| 67 | 4x |
lavmodel <- lav_model( |
| 68 | 4x |
lavpartable = lavpartable, |
| 69 | 4x |
lavoptions = lavoptions, |
| 70 | 4x |
th.idx = lavmodel@th.idx |
| 71 |
) |
|
| 72 | ||
| 73 |
# add rotated information |
|
| 74 | 4x |
lavmodel@H <- efa.out$H |
| 75 | 4x |
lavmodel@lv.order <- efa.out$lv.order |
| 76 | 4x |
lavmodel@GLIST <- efa.out$GLIST |
| 77 | ||
| 78 |
# add con.jac information (if any) |
|
| 79 | 4x |
lavmodel@con.lambda <- lavmodel.unrot@con.lambda |
| 80 | 4x |
if (nrow(lavmodel.unrot@con.jac) > 0L) {
|
| 81 | 4x |
con.jac <- rbind(lavmodel@ceq.JAC, lavmodel@cin.JAC) |
| 82 | 4x |
attr(con.jac, "inactive.idx") <- |
| 83 | 4x |
attr(lavmodel.unrot@con.jac, "inactive.idx") |
| 84 | 4x |
attr(con.jac, "cin.idx") <- attr(lavmodel.unrot@con.jac, "cin.idx") |
| 85 | 4x |
attr(con.jac, "ceq.idx") <- attr(lavmodel.unrot@con.jac, "ceq.idx") |
| 86 | 4x |
lavmodel@con.jac <- con.jac |
| 87 |
} |
|
| 88 | ||
| 89 |
# overwrite parameters in @ParTable$est |
|
| 90 | 4x |
lavpartable$est <- lav_model_get_parameters( |
| 91 | 4x |
lavmodel = lavmodel, |
| 92 | 4x |
type = "user", extra = TRUE |
| 93 |
) |
|
| 94 | 4x |
if (lav_verbose()) {
|
| 95 | ! |
cat(" done.\n")
|
| 96 |
} |
|
| 97 | ||
| 98 |
# VCOV rotated parameters |
|
| 99 | 4x |
if (!lavoptions$se %in% c("none", "bootstrap", "external", "two.step")) {
|
| 100 | 4x |
if (lav_verbose()) {
|
| 101 | ! |
cat( |
| 102 | ! |
"computing VCOV for se =", lavoptions$se, |
| 103 | ! |
"and rotation.se =", lavoptions$rotation.se, "..." |
| 104 |
) |
|
| 105 |
} |
|
| 106 | ||
| 107 |
# use delta rule to recompute vcov |
|
| 108 | 4x |
if (lavoptions$rotation.se == "delta") {
|
| 109 |
# Jacobian |
|
| 110 | ! |
JAC <- numDeriv::jacobian( # nolint |
| 111 | ! |
func = lav_model_efa_rotate_x, |
| 112 | ! |
x = x.unrotated, lavmodel = lavmodel.unrot, |
| 113 | ! |
init.rot = lavmodel@H, lavoptions = lavoptions, |
| 114 | ! |
type = "user", extra = FALSE, |
| 115 | ! |
method.args = list(eps = 0.0050), |
| 116 | ! |
method = "simple" |
| 117 | ! |
) # important! |
| 118 | ||
| 119 |
# force VCOV to be pd, before we transform (not very elegant) |
|
| 120 | ! |
VCOV.in <- lav_matrix_symmetric_force_pd(lavvcov$vcov, # nolint |
| 121 | ! |
tol = 1e-10 |
| 122 |
) |
|
| 123 |
# apply Delta rule |
|
| 124 | ! |
VCOV.user <- JAC %*% VCOV.in %*% t(JAC) # nolint |
| 125 | ||
| 126 |
# re-compute SE and store them in lavpartable |
|
| 127 | ! |
tmp <- diag(VCOV.user) |
| 128 | ! |
min.idx <- which(tmp < 0) |
| 129 | ! |
if (length(min.idx) > 0L) {
|
| 130 | ! |
tmp[min.idx] <- as.numeric(NA) |
| 131 |
} |
|
| 132 | ! |
tmp <- sqrt(tmp) |
| 133 |
# catch near-zero SEs (was ^(1/2) < 0.6) |
|
| 134 | ! |
zero.idx <- which(tmp < .Machine$double.eps^(1 / 3)) |
| 135 | ! |
if (length(zero.idx) > 0L) {
|
| 136 | ! |
tmp[zero.idx] <- 0.0 |
| 137 |
} |
|
| 138 | ! |
lavpartable$se <- tmp |
| 139 | ||
| 140 |
# store rotated VCOV |
|
| 141 |
# lavvcov$vcov.unrotated <- lavvcov$vcov |
|
| 142 | ! |
if (lavmodel@ceq.simple.only) {
|
| 143 | ! |
free.idx <- which(lavpartable$free > 0L && |
| 144 | ! |
!duplicated(lavpartable$free)) |
| 145 |
} else {
|
|
| 146 | ! |
free.idx <- which(lavpartable$free > 0L) |
| 147 |
} |
|
| 148 | ! |
lavvcov$vcov <- VCOV.user[free.idx, free.idx, drop = FALSE] |
| 149 | ||
| 150 |
# rotation.se = "bordered" is the default |
|
| 151 | 4x |
} else if (lavoptions$rotation.se == "bordered") {
|
| 152 |
# create 'border' for augmented information matrix |
|
| 153 | 4x |
x.rot <- lav_model_get_parameters(lavmodel) |
| 154 | 4x |
JAC <- numDeriv::jacobian( # nolint |
| 155 | 4x |
func = lav_model_efa_rotate_border_x, |
| 156 | 4x |
x = x.rot, lavmodel = lavmodel, |
| 157 | 4x |
lavoptions = lavoptions, |
| 158 | 4x |
lavpartable = lavpartable, |
| 159 |
# method.args = list(eps = 0.0005), |
|
| 160 |
# method = "simple") |
|
| 161 | 4x |
method = "Richardson" |
| 162 |
) |
|
| 163 |
# store JAC |
|
| 164 | 4x |
lavmodel@ceq.efa.JAC <- JAC |
| 165 | ||
| 166 |
# no other constraints |
|
| 167 | 4x |
if (nrow(lavmodel@con.jac) == 0L) {
|
| 168 | ! |
lavmodel@con.jac <- JAC |
| 169 | ! |
attr(lavmodel@con.jac, "inactive.idx") <- integer(0L) |
| 170 | ! |
attr(lavmodel@con.jac, "ceq.idx") <- seq_len(nrow(JAC)) |
| 171 | ! |
attr(lavmodel@con.jac, "cin.idx") <- integer(0L) |
| 172 | ! |
lavmodel@con.lambda <- rep(0, nrow(JAC)) |
| 173 | ||
| 174 |
# other constraints |
|
| 175 |
} else {
|
|
| 176 | 4x |
inactive.idx <- attr(lavmodel@con.jac, "inactive.idx") |
| 177 | 4x |
ceq.idx <- attr(lavmodel@con.jac, "ceq.idx") |
| 178 | 4x |
cin.idx <- attr(lavmodel@con.jac, "cin.idx") |
| 179 | 4x |
lambda <- lavmodel@con.lambda |
| 180 | 4x |
nbord <- nrow(JAC) |
| 181 | ||
| 182 |
# reconstruct con.jac |
|
| 183 | 4x |
CON.JAC <- rbind(JAC, lavmodel@ceq.JAC, lavmodel@cin.JAC) # nolint |
| 184 | 4x |
attr(CON.JAC, "cin.idx") <- cin.idx + nbord # nolint |
| 185 | 4x |
attr(CON.JAC, "ceq.idx") <- c(1:nbord, ceq.idx + nbord) # nolint |
| 186 | 4x |
attr(CON.JAC, "inactive.idx") <- inactive.idx + nbord # nolint |
| 187 | ||
| 188 | 4x |
lavmodel@con.jac <- CON.JAC |
| 189 | 4x |
lavmodel@con.lambda <- c(rep(0, nbord), lambda) |
| 190 |
} |
|
| 191 | ||
| 192 |
# compute VCOV, taking 'rotation constraints' into account |
|
| 193 | 4x |
VCOV <- lav_model_vcov( # nolint |
| 194 | 4x |
lavmodel = lavmodel, |
| 195 | 4x |
lavsamplestats = lavsamplestats, |
| 196 | 4x |
lavoptions = lavoptions, |
| 197 | 4x |
lavdata = lavdata, |
| 198 | 4x |
lavpartable = lavpartable, |
| 199 | 4x |
lavcache = lavcache, |
| 200 | 4x |
lavimplied = lavimplied, |
| 201 | 4x |
lavh1 = lavh1 |
| 202 |
) |
|
| 203 | ||
| 204 |
# compute SE and store them in lavpartable |
|
| 205 | 4x |
tmp <- lav_model_vcov_se( |
| 206 | 4x |
lavmodel = lavmodel, |
| 207 | 4x |
lavpartable = lavpartable, VCOV = VCOV |
| 208 |
) |
|
| 209 | 4x |
lavpartable$se <- tmp |
| 210 | ||
| 211 |
# store rotated VCOV in lavvcov |
|
| 212 | 4x |
tmp.attr <- attributes(VCOV) |
| 213 | 4x |
VCOV1 <- VCOV # nolint |
| 214 | 4x |
attributes(VCOV1) <- tmp.attr["dim"] # nolint |
| 215 |
# lavvcov$vcov.unrotated <- lavvcov$vcov |
|
| 216 | 4x |
lavvcov$vcov <- VCOV1 |
| 217 |
} # bordered |
|
| 218 | ||
| 219 | 4x |
if (lav_verbose()) {
|
| 220 | ! |
cat(" done.\n")
|
| 221 |
} |
|
| 222 |
} # vcov |
|
| 223 |
} # efa |
|
| 224 | ||
| 225 | 140x |
list( |
| 226 | 140x |
lavpartable = lavpartable, |
| 227 | 140x |
lavmodel = lavmodel, |
| 228 | 140x |
lavvcov = lavvcov |
| 229 |
) |
|
| 230 |
} |
| 1 |
# export go BUGS syntax |
|
| 2 | ||
| 3 |
# we assume that N1, N2, ... are in data |
|
| 4 |
lav_export_bugs <- function(partable, as.function. = FALSE) {
|
|
| 5 |
# get parameter table attributes |
|
| 6 | ! |
pta <- lav_partable_attributes(partable = partable) |
| 7 | ! |
vnames <- pta$vnames |
| 8 | ! |
nblocks <- pta$nblocks |
| 9 | ! |
nvar <- pta$nvar |
| 10 | ! |
nfac <- pta$nfac |
| 11 | ||
| 12 |
# sanity check |
|
| 13 | ! |
partable <- lav_export_check(partable) |
| 14 | ||
| 15 |
# tabs |
|
| 16 | ! |
t1 <- paste(rep(" ", 2L), collapse = "")
|
| 17 | ! |
t2 <- paste(rep(" ", 4L), collapse = "")
|
| 18 | ! |
t3 <- paste(rep(" ", 6L), collapse = "")
|
| 19 | ! |
t4 <- paste(rep(" ", 8L), collapse = "")
|
| 20 | ||
| 21 |
# TXT header |
|
| 22 | ! |
if (as.function.) {
|
| 23 | ! |
TXT <- paste("{\n", sep = "")
|
| 24 |
} else {
|
|
| 25 | ! |
TXT <- paste("model {\n", sep = "")
|
| 26 |
} |
|
| 27 | ||
| 28 |
# model for every i |
|
| 29 | ! |
for (g in 1:nblocks) {
|
| 30 | ! |
ov.names <- vnames$ov[[g]] |
| 31 | ! |
lv.names <- vnames$lv[[g]] |
| 32 | ! |
yname <- paste("y", g, sep = "")
|
| 33 | ! |
if (nblocks > 1L) {
|
| 34 | ! |
TXT <- paste(TXT, t1, |
| 35 | ! |
"# block ", g, "\n", |
| 36 | ! |
sep = "" |
| 37 |
) |
|
| 38 |
} else {
|
|
| 39 | ! |
TXT <- paste(TXT, "\n") |
| 40 |
} |
|
| 41 | ! |
TXT <- paste(TXT, t1, |
| 42 | ! |
"for(i in 1:N", g, ") {\n",
|
| 43 | ! |
sep = "" |
| 44 |
) |
|
| 45 | ||
| 46 |
# ov.nox - all observed variables (except exogenous ones) |
|
| 47 | ! |
ov.names.nox <- vnames$ov.nox[[g]] |
| 48 | ! |
nov <- length(ov.names.nox) |
| 49 | ! |
TXT <- paste(TXT, "\n", t2, |
| 50 | ! |
"# ov.nox", |
| 51 | ! |
sep = "" |
| 52 |
) |
|
| 53 | ! |
for (i in 1:nov) {
|
| 54 | ! |
ov.idx <- match(ov.names.nox[i], ov.names) |
| 55 | ! |
theta.free.idx <- which(partable$block == g & |
| 56 | ! |
partable$op == "~~" & |
| 57 | ! |
partable$lhs == partable$rhs & |
| 58 | ! |
partable$lhs == ov.names.nox[i]) |
| 59 | ! |
if (length(theta.free.idx) != 1L) {
|
| 60 | ! |
lav_msg_stop(gettextf( |
| 61 | ! |
"parameter for residual variance %s not found", |
| 62 | ! |
ov.names.nox[i]) |
| 63 |
) |
|
| 64 |
} else {
|
|
| 65 | ! |
theta.idx <- partable$free[theta.free.idx] |
| 66 |
} |
|
| 67 | ! |
TXT <- paste(TXT, "\n", t2, |
| 68 | ! |
yname, "[i,", ov.idx, "] ~ dnorm(mu", g, "[i,", ov.idx, |
| 69 | ! |
"], itheta[", theta.idx, "])", |
| 70 | ! |
sep = "" |
| 71 |
) |
|
| 72 |
} |
|
| 73 | ||
| 74 | ! |
TXT <- paste(TXT, "\n", t2, sep = "") |
| 75 | ! |
for (i in 1:nov) {
|
| 76 | ! |
ov.idx <- match(ov.names.nox[i], ov.names) |
| 77 | ! |
TXT <- paste(TXT, "\n", t2, |
| 78 | ! |
"mu", g, "[i,", ov.idx, "] <- ", |
| 79 | ! |
sep = "" |
| 80 |
) |
|
| 81 | ||
| 82 |
# find rhs for this observed variable |
|
| 83 | ||
| 84 |
# 1. intercept? |
|
| 85 | ! |
int.idx <- which(partable$block == g & |
| 86 | ! |
partable$op == "~1" & |
| 87 | ! |
partable$lhs == ov.names.nox[i]) |
| 88 | ! |
if (length(int.idx) == 1L) {
|
| 89 |
# fixed or free? |
|
| 90 | ! |
if (partable$free[int.idx] == 0L) {
|
| 91 | ! |
TXT <- paste(TXT, |
| 92 | ! |
partable$ustart[int.idx], |
| 93 | ! |
sep = "" |
| 94 |
) |
|
| 95 |
} else {
|
|
| 96 | ! |
TXT <- paste(TXT, |
| 97 | ! |
"theta[", partable$free[int.idx], "]", |
| 98 | ! |
sep = "" |
| 99 |
) |
|
| 100 |
} |
|
| 101 |
} else { # no intercept, say '0', so we always have rhs
|
|
| 102 | ! |
TXT <- paste(TXT, "0", sep = "") |
| 103 |
} |
|
| 104 | ||
| 105 |
# 2. factor loading? |
|
| 106 | ! |
lam.idx <- which(partable$block == g & |
| 107 | ! |
partable$op == "=~" & |
| 108 | ! |
partable$rhs == ov.names.nox[i]) |
| 109 | ! |
for (j in lam.idx) {
|
| 110 |
# fixed or free? |
|
| 111 | ! |
if (partable$free[j] == 0L) {
|
| 112 | ! |
TXT <- paste(TXT, " + ", |
| 113 | ! |
partable$ustart[j], "*eta", g, "[i,", |
| 114 | ! |
match(partable$lhs[j], lv.names), |
| 115 |
"]", |
|
| 116 | ! |
sep = "" |
| 117 |
) |
|
| 118 |
} else {
|
|
| 119 | ! |
TXT <- paste(TXT, " + ", |
| 120 | ! |
"theta[", partable$free[j], "]*eta", g, "[i,", |
| 121 | ! |
match(partable$lhs[j], lv.names), |
| 122 |
"]", |
|
| 123 | ! |
sep = "" |
| 124 |
) |
|
| 125 |
} |
|
| 126 |
} |
|
| 127 | ||
| 128 |
# 3. regression? |
|
| 129 | ! |
r.idx <- which(partable$block == g & |
| 130 | ! |
partable$op == "~" & |
| 131 | ! |
partable$lhs == ov.names.nox[i]) |
| 132 | ! |
for (j in r.idx) {
|
| 133 |
# what is the rhs? |
|
| 134 | ! |
rhs <- partable$rhs[j] |
| 135 | ! |
if (rhs %in% lv.names) {
|
| 136 | ! |
RHS <- paste("eta", g, "[i,",
|
| 137 | ! |
match(rhs, lv.names), "]", |
| 138 | ! |
sep = "" |
| 139 |
) |
|
| 140 | ! |
} else if (rhs %in% vnames$ov[[g]]) {
|
| 141 | ! |
RHS <- paste("y", g, "[i,",
|
| 142 | ! |
match(rhs, ov.names), "]", |
| 143 | ! |
sep = "" |
| 144 |
) |
|
| 145 |
} |
|
| 146 | ||
| 147 |
# fixed or free? |
|
| 148 | ! |
if (partable$free[j] == 0L) {
|
| 149 | ! |
TXT <- paste(TXT, " + ", |
| 150 | ! |
partable$ustart[j], "*", RHS, |
| 151 | ! |
sep = "" |
| 152 |
) |
|
| 153 |
} else {
|
|
| 154 | ! |
TXT <- paste(TXT, " + ", |
| 155 | ! |
"theta[", partable$free[j], "]*", RHS, |
| 156 | ! |
sep = "" |
| 157 |
) |
|
| 158 |
} |
|
| 159 |
} |
|
| 160 |
} |
|
| 161 | ||
| 162 | ||
| 163 |
# lv.y |
|
| 164 |
# var(lv.y) = PSI (lisrel style) |
|
| 165 | ! |
lv.y <- vnames$lv.y[[g]] |
| 166 | ! |
if (length(lv.y) > 0L) {
|
| 167 | ! |
TXT <- paste(TXT, "\n\n", t2, |
| 168 | ! |
"# lv.y", |
| 169 | ! |
sep = "" |
| 170 |
) |
|
| 171 | ! |
lv.y.idx <- match(lv.y, lv.names) |
| 172 | ! |
ny <- length(lv.y.idx) |
| 173 | ! |
for (j in 1:ny) {
|
| 174 | ! |
theta.free.idx <- which(partable$block == g & |
| 175 | ! |
partable$op == "~~" & |
| 176 | ! |
partable$lhs == partable$rhs & |
| 177 | ! |
partable$lhs == lv.y[j]) |
| 178 | ! |
if (length(theta.free.idx) != 1L) {
|
| 179 | ! |
lav_msg_stop(gettextf( |
| 180 | ! |
"parameter for residual variance %s not found", |
| 181 | ! |
lv.y[j]) |
| 182 |
) |
|
| 183 |
} else {
|
|
| 184 | ! |
theta.idx <- partable$free[theta.free.idx] |
| 185 |
} |
|
| 186 | ! |
TXT <- paste(TXT, "\n", t2, |
| 187 |
# dnorm for now |
|
| 188 | ! |
"eta", g, "[i,", lv.y.idx[j], "] ~ dnorm(mu.eta", g, "[i,", |
| 189 | ! |
lv.y.idx[j], "], itheta[", theta.idx, "])", |
| 190 | ! |
sep = "" |
| 191 |
) |
|
| 192 |
} |
|
| 193 | ! |
for (j in 1:ny) {
|
| 194 | ! |
TXT <- paste(TXT, "\n", t2, |
| 195 |
# dnorm for now |
|
| 196 | ! |
"mu.eta", g, "[i,", lv.y.idx[j], "] <- ", |
| 197 | ! |
sep = "" |
| 198 |
) |
|
| 199 | ||
| 200 |
# lhs elements regression |
|
| 201 |
# 1. intercept? |
|
| 202 | ! |
int.idx <- which(partable$block == g & |
| 203 | ! |
partable$op == "~1" & |
| 204 | ! |
partable$lhs == lv.y[j]) |
| 205 | ! |
if (length(int.idx) == 1L) {
|
| 206 |
# fixed or free? |
|
| 207 | ! |
if (partable$free[int.idx] == 0L) {
|
| 208 | ! |
TXT <- paste(TXT, |
| 209 | ! |
partable$ustart[int.idx], |
| 210 | ! |
sep = "" |
| 211 |
) |
|
| 212 |
} else {
|
|
| 213 | ! |
TXT <- paste(TXT, |
| 214 | ! |
"theta[", partable$free[int.idx], "]", |
| 215 | ! |
sep = "" |
| 216 |
) |
|
| 217 |
} |
|
| 218 |
} else { # no intercept, say '0', so we always have rhs
|
|
| 219 | ! |
TXT <- paste(TXT, "0", sep = "") |
| 220 |
} |
|
| 221 | ||
| 222 | ! |
rhs.idx <- which(partable$block == g & |
| 223 | ! |
partable$op == "~" & |
| 224 | ! |
partable$lhs == lv.y[j]) |
| 225 | ! |
np <- length(rhs.idx) |
| 226 | ! |
for (p in 1:np) {
|
| 227 | ! |
TXT <- paste(TXT, " + ", |
| 228 | ! |
"theta[", partable$free[rhs.idx[p]], |
| 229 | ! |
"]*eta", g, "[i,", |
| 230 | ! |
match(partable$rhs[rhs.idx[p]], lv.names), |
| 231 |
"]", |
|
| 232 | ! |
sep = "" |
| 233 |
) |
|
| 234 |
} |
|
| 235 |
} |
|
| 236 |
} |
|
| 237 | ||
| 238 |
# exogenous lv -- FIXME: we assume the lv.x array is continous |
|
| 239 |
# (eg 3,4,5, but NOT 3,5,6) |
|
| 240 |
# var(lv.x) = PHI (lisrel style) |
|
| 241 | ! |
lv.x <- vnames$lv.x[[g]] |
| 242 | ! |
if (length(lv.x) > 0L) {
|
| 243 | ! |
TXT <- paste(TXT, "\n\n", t2, |
| 244 | ! |
"# lv.x", |
| 245 | ! |
sep = "" |
| 246 |
) |
|
| 247 | ! |
lv.x.idx <- match(lv.x, lv.names) |
| 248 | ! |
nx <- length(lv.x.idx) |
| 249 | ! |
TXT <- paste(TXT, "\n", t2, |
| 250 |
# dmnorm for now |
|
| 251 | ! |
"eta", g, "[i,", min(lv.x.idx), ":", max(lv.x.idx), |
| 252 | ! |
"] ~ dmnorm(mu.eta", g, "[i,", min(lv.x.idx), ":", |
| 253 | ! |
max(lv.x.idx), "], iphi", g, "[1:", nx, ",1:", nx, "])", |
| 254 | ! |
sep = "" |
| 255 |
) |
|
| 256 | ! |
for (j in 1:nx) {
|
| 257 | ! |
TXT <- paste(TXT, "\n", t2, |
| 258 | ! |
"mu.eta", g, "[i,", lv.x.idx[j], "] <- 0", |
| 259 | ! |
sep = "" |
| 260 |
) |
|
| 261 |
} |
|
| 262 |
} |
|
| 263 | ||
| 264 | ||
| 265 |
# exogenous ov ??? (what to do here?) |
|
| 266 | ||
| 267 |
# end of this block |
|
| 268 | ! |
TXT <- paste(TXT, "\n\n", t1, |
| 269 | ! |
"} # end of block ", g, "\n", |
| 270 | ! |
sep = "" |
| 271 |
) |
|
| 272 |
} |
|
| 273 | ||
| 274 |
# priors (both fixed and free) |
|
| 275 | ! |
TXT <- paste(TXT, "\n", t1, |
| 276 | ! |
"# Priors free parameters (univariate):", |
| 277 | ! |
sep = "" |
| 278 |
) |
|
| 279 | ! |
npt <- length(partable$lhs) |
| 280 | ! |
for (i in seq_len(npt)) {
|
| 281 | ! |
if (partable$free[i] == 0L) next # skip non-free parameters |
| 282 | ! |
lhs <- partable$lhs[i] |
| 283 | ! |
op <- partable$op[i] |
| 284 | ! |
rhs <- partable$rhs[i] |
| 285 | ! |
free.idx <- partable$free[i] |
| 286 | ! |
g <- partable$block[i] |
| 287 | ! |
if (op == "=~") {
|
| 288 |
# factor loading |
|
| 289 | ! |
TXT <- paste(TXT, "\n", t1, |
| 290 | ! |
"theta[", free.idx, "] ~ dnorm(0.8, 1)", |
| 291 | ! |
sep = "" |
| 292 |
) |
|
| 293 | ! |
} else if (op == "~") {
|
| 294 |
# regression |
|
| 295 | ! |
TXT <- paste(TXT, "\n", t1, |
| 296 | ! |
"theta[", free.idx, "] ~ dnorm(0, 1)", |
| 297 | ! |
sep = "" |
| 298 |
) |
|
| 299 | ! |
} else if (op == "~~" && lhs == rhs) {
|
| 300 |
# variance |
|
| 301 |
# 1. lv.x + lv.x (skip -> multivariate) |
|
| 302 |
# 2. lv.y + lv.y |
|
| 303 |
# 3. observed + observed |
|
| 304 |
# 4. else -> fix (upgrade to latent?) |
|
| 305 | ! |
if (lhs %in% vnames$lv.x[[g]] && rhs %in% vnames$lv.x[[g]]) {
|
| 306 |
# lv.x: move to multivariate... (dwish) |
|
| 307 | ! |
next |
| 308 | ! |
} else if (lhs %in% vnames$lv.y[[g]] && rhs %in% vnames$lv.y[[g]]) {
|
| 309 |
# lv.y |
|
| 310 | ! |
TXT <- paste(TXT, "\n", t1, |
| 311 | ! |
"itheta[", free.idx, "] ~ dgamma(9, 4)", |
| 312 | ! |
sep = "" |
| 313 |
) |
|
| 314 | ! |
TXT <- paste(TXT, "\n", t1, |
| 315 | ! |
"theta[", free.idx, "] <- 1/itheta[", free.idx, "]", |
| 316 | ! |
sep = "" |
| 317 |
) |
|
| 318 | ! |
} else if (lhs %in% vnames$ov[[g]] && rhs %in% vnames$ov[[g]]) {
|
| 319 | ! |
TXT <- paste(TXT, "\n", t1, |
| 320 | ! |
"itheta[", free.idx, "] ~ dgamma(9, 4)", |
| 321 | ! |
sep = "" |
| 322 |
) |
|
| 323 | ! |
TXT <- paste(TXT, "\n", t1, |
| 324 | ! |
"theta[", free.idx, "] <- 1/itheta[", free.idx, "]", |
| 325 | ! |
sep = "" |
| 326 |
) |
|
| 327 |
} else {
|
|
| 328 | ! |
lav_msg_stop(gettextf("FIXME!! parameter %s", i))
|
| 329 |
} |
|
| 330 | ! |
} else if (op == "~~" && lhs != rhs) {
|
| 331 |
# covariance |
|
| 332 |
# 1. lv.x + lv.x (skip -> multivariate) |
|
| 333 |
# 2. lv.y + lv.y |
|
| 334 |
# 3. observed + observed |
|
| 335 |
# 4. else -> fix (upgrade to latent?) |
|
| 336 | ! |
if (lhs %in% vnames$lv.x[[g]] && rhs %in% vnames$lv.x[[g]]) {
|
| 337 |
# exo lv covariance |
|
| 338 | ! |
next |
| 339 | ! |
} else if (lhs %in% vnames$lv.y[[g]] && rhs %in% vnames$lv.y[[g]]) {
|
| 340 |
# lv.y |
|
| 341 | ! |
lav_msg_stop(gettextf("FIXME!! parameter ", i))
|
| 342 | ! |
} else if (lhs %in% vnames$ov[[g]] && rhs %in% vnames$ov[[g]]) {
|
| 343 | ! |
TXT <- paste(TXT, "\n", t1, |
| 344 | ! |
"itheta[", free.idx, "] ~ dgamma(9, 4)", |
| 345 | ! |
sep = "" |
| 346 |
) |
|
| 347 | ! |
TXT <- paste(TXT, "\n", t1, |
| 348 | ! |
"theta[", free.idx, "] <- 1/itheta[", free.idx, "]", |
| 349 | ! |
sep = "" |
| 350 |
) |
|
| 351 |
} else {
|
|
| 352 | ! |
lav_msg_stop(gettextf("FIXME!! parameter ", i))
|
| 353 |
} |
|
| 354 | ! |
} else if (op == "~1") {
|
| 355 |
# intercept |
|
| 356 | ! |
TXT <- paste(TXT, "\n", t1, |
| 357 | ! |
"theta[", free.idx, "] ~ dnorm(0, 1)", |
| 358 | ! |
sep = "" |
| 359 |
) |
|
| 360 |
} else {
|
|
| 361 | ! |
lav_msg_stop(gettextf("op not supported yet for parameter ", i))
|
| 362 |
} |
|
| 363 |
} |
|
| 364 | ||
| 365 | ! |
TXT <- paste(TXT, "\n\n", t1, |
| 366 | ! |
"# Priors free parameters (multivariate):", |
| 367 | ! |
sep = "" |
| 368 |
) |
|
| 369 | ! |
for (g in 1:nblocks) {
|
| 370 | ! |
lv.phi.idx <- which(partable$block == g & |
| 371 | ! |
partable$op == "~~" & |
| 372 | ! |
partable$lhs %in% vnames$lv.x[[g]] & |
| 373 | ! |
partable$rhs %in% vnames$lv.x[[g]]) |
| 374 | ! |
nx <- length(vnames$lv.x[[g]]) |
| 375 | ! |
if (length(nx) > 0L) {
|
| 376 | ! |
TXT <- paste(TXT, "\n", t1, |
| 377 | ! |
"iphi", g, "[1:", nx, ",1:", nx, "] ~ dwish(R", g, "[1:", |
| 378 | ! |
nx, ",1:", nx, "], 5)", |
| 379 | ! |
sep = "" |
| 380 |
) |
|
| 381 | ! |
TXT <- paste(TXT, "\n", t1, |
| 382 | ! |
"phi", g, "[1:", nx, ",1:", nx, "] <- inverse(iphi", g, "[1:", |
| 383 | ! |
nx, ",1:", nx, "])", |
| 384 | ! |
sep = "" |
| 385 |
) |
|
| 386 | ! |
for (idx in lv.phi.idx) {
|
| 387 | ! |
TXT <- paste(TXT, "\n", t1, |
| 388 | ! |
"theta[", partable$free[idx], "] <- phi", g, "[", |
| 389 | ! |
match(partable$lhs[idx], vnames$lv.x[[g]]), ",", |
| 390 | ! |
match(partable$rhs[idx], vnames$lv.x[[g]]), "]", |
| 391 | ! |
sep = "" |
| 392 |
) |
|
| 393 |
} |
|
| 394 |
} |
|
| 395 |
} |
|
| 396 | ||
| 397 |
# end of model |
|
| 398 | ! |
TXT <- paste(TXT, "\n\n", "} # End of model\n", sep = "") |
| 399 | ||
| 400 |
# end of model |
|
| 401 | ! |
if (as.function.) {
|
| 402 | ! |
out <- function() NULL |
| 403 | ! |
formals(out) <- alist() |
| 404 | ! |
body(out) <- parse(file = "", text = TXT) |
| 405 |
} else {
|
|
| 406 | ! |
out <- TXT |
| 407 | ! |
class(out) <- c("lavaan.character", "character")
|
| 408 |
} |
|
| 409 | ||
| 410 | ! |
out |
| 411 |
} |
| 1 |
# small utility functions to deal with PRELIS |
|
| 2 |
# Y.R.: 11 dec 2012 |
|
| 3 |
prelis.read.cor <- function(file = "") {
|
|
| 4 |
# read in numbers as characters |
|
| 5 | ! |
txt <- scan(file, what = "character", quiet = TRUE) |
| 6 | ||
| 7 |
# convert to numbers |
|
| 8 | ! |
txt <- gsub("D", "e", txt)
|
| 9 | ! |
x <- as.numeric(txt) |
| 10 | ||
| 11 |
# create COR/COR matrix |
|
| 12 | ! |
COR <- lav_matrix_lower2full(x, diagonal = TRUE) |
| 13 | ! |
COR |
| 14 |
} |
|
| 15 | ||
| 16 | ||
| 17 |
prelis.read.acm <- function(file = "", rescale = 1e-3) {
|
|
| 18 |
# read in raw data -- ignore first three elements |
|
| 19 |
# first element: 123.456789 (check?) |
|
| 20 |
# second element: 2.72 version number of prelis |
|
| 21 |
# third element: almost zero?? |
|
| 22 | ! |
zz <- file(file, "rb") |
| 23 | ! |
raw <- readBin(zz, what = "double", n = 1e+05)[-c(1, 2, 3)] |
| 24 | ! |
close(zz) |
| 25 | ||
| 26 |
# scale numbers |
|
| 27 | ! |
raw <- raw * rescale |
| 28 | ||
| 29 | ! |
ACM <- lav_matrix_lower2full(raw, diagonal = TRUE) |
| 30 | ||
| 31 |
# elements are divided by 2?? |
|
| 32 | ! |
ACM <- ACM * 2 |
| 33 | ! |
ACM |
| 34 |
} |
|
| 35 | ||
| 36 |
prelis.write.data <- function(data, file = "prelis", na.rm = TRUE, |
|
| 37 |
labels = FALSE, std.ov = FALSE) {
|
|
| 38 | ! |
dfile <- paste(file, ".raw", sep = "") |
| 39 | ! |
write.table(data, |
| 40 | ! |
file = dfile, na = "-999999", col.names = FALSE, |
| 41 | ! |
row.names = FALSE, quote = FALSE |
| 42 |
) |
|
| 43 | ! |
if (labels) {
|
| 44 | ! |
lfile <- paste(file, ".lab", sep = "") |
| 45 | ! |
write.table(unique(names(data)), |
| 46 | ! |
file = lfile, row.names = F, |
| 47 | ! |
col.names = F, quote = F |
| 48 |
) |
|
| 49 |
} |
|
| 50 |
} |
|
| 51 | ||
| 52 |
prelis.run <- function(X, type = "OR", keep.files = FALSE) {
|
|
| 53 | ! |
label <- names(X) |
| 54 | ! |
nvar <- ncol(X) |
| 55 | ||
| 56 |
# write raw data |
|
| 57 | ! |
prelis.write.data(X, file = "prelistmp") |
| 58 | ||
| 59 |
# write syntax |
|
| 60 | ! |
txt <- paste("DA NI=", nvar, " NO=0 MI=-999999\n", sep = "")
|
| 61 | ! |
txt <- paste(txt, "LA", sep = "") |
| 62 | ! |
tmp <- 0 |
| 63 | ! |
for (i in 1:nvar) {
|
| 64 | ! |
if (tmp %% 6 == 0) txt <- paste(txt, "\n", sep = "") |
| 65 | ! |
txt <- paste(txt, label[i], " ", sep = "") |
| 66 | ! |
tmp <- tmp + 1 |
| 67 |
} |
|
| 68 | ! |
txt <- paste(txt, "\n") |
| 69 | ! |
txt <- paste(txt, "RA FI=prelistmp.raw\n", sep = "") |
| 70 | ! |
txt <- paste(txt, type, " ALL\n", sep = "") |
| 71 | ! |
txt <- paste(txt, "OU MA=PM SA=prelistmp.acm SM=prelistmp.cor\n", sep = "") |
| 72 | ! |
writeLines(txt, con = "prelistmp.in") |
| 73 | ||
| 74 |
# run prelis |
|
| 75 | ! |
system("prelis prelistmp.in prelistmp.out")
|
| 76 | ||
| 77 |
# read in acm and cor |
|
| 78 | ! |
ACM <- prelis.read.acm(file = "prelistmp.acm") |
| 79 | ! |
COR <- prelis.read.cor(file = "prelistmp.cor") |
| 80 | ||
| 81 |
# clean up |
|
| 82 | ! |
if (!keep.files) {
|
| 83 | ! |
unlink(c( |
| 84 | ! |
"prelistmp.in", "prelistmp.out", "prelistmp.acm", |
| 85 | ! |
"prelistmp.cor", "prelistmp.FREQ", "prelistmp.raw" |
| 86 |
)) |
|
| 87 |
} |
|
| 88 | ||
| 89 | ! |
list(COR = COR, ACM = ACM) |
| 90 |
} |
| 1 |
# handle ov.order = "data" by adding attribute "ovda" to FLAT |
|
| 2 |
lav_partable_ov_from_data <- function(FLAT = NULL, # nolint |
|
| 3 |
data = NULL, |
|
| 4 |
sample.cov = NULL, |
|
| 5 |
slotData = NULL) { # nolint
|
|
| 6 |
# current model-based ov.names |
|
| 7 | 2x |
ov.names <- lav_partable_vnames(FLAT, type = "ov") |
| 8 | ||
| 9 |
# get data-based ov.names |
|
| 10 | 2x |
data.names <- NULL |
| 11 | 2x |
if (!is.null(data)) {
|
| 12 | ! |
data.names <- names(data) |
| 13 | 2x |
} else if (!is.null(sample.cov)) {
|
| 14 |
# multiple group/blocks? |
|
| 15 | 2x |
if (is.list(sample.cov)) {
|
| 16 | 2x |
data.names <- unique(unlist(lapply(sample.cov, colnames))) |
| 17 | 2x |
if (is.null(data.names)) {
|
| 18 |
# try again with rows |
|
| 19 | ! |
data.names <- unique(unlist(lapply(sample.cov, rownames))) |
| 20 |
} |
|
| 21 |
} else {
|
|
| 22 | ! |
data.names <- colnames(sample.cov) |
| 23 | ! |
if (is.null(data.names)) {
|
| 24 |
# try again with rows |
|
| 25 | ! |
data.names <- rownames(sample.cov) |
| 26 |
} |
|
| 27 |
} |
|
| 28 | ! |
} else if (!is.null(slotData)) {
|
| 29 | ! |
data.names <- unique(unlist(slotData@ov.names)) |
| 30 |
} |
|
| 31 | ||
| 32 | 2x |
if (is.null(data.names) || length(data.names) == 0L) {
|
| 33 | ! |
lav_msg_stop(gettext("could not find variable names in data/sample.cov"))
|
| 34 |
} |
|
| 35 | ||
| 36 |
# extract needed ov.names in the same order as the data |
|
| 37 | 2x |
ov.names.data <- data.names[data.names %in% ov.names] |
| 38 | ||
| 39 |
# check if we have all of them |
|
| 40 | 2x |
if (length(ov.names.data) != length(ov.names)) {
|
| 41 | ! |
idx.missing <- which(!(ov.names %in% ov.names.data)) |
| 42 | ! |
lav_msg_stop(gettextf( |
| 43 | ! |
"some (observed) variables specified in the model are not found |
| 44 | ! |
in the data: %s", |
| 45 | ! |
lav_msg_view(ov.names[idx.missing], "none"))) |
| 46 |
} |
|
| 47 | ||
| 48 |
# check if the order is the same |
|
| 49 | 2x |
if (!identical(ov.names, ov.names.data)) {
|
| 50 | 2x |
attr(FLAT, "ovda") <- ov.names.data # nolint |
| 51 |
} |
|
| 52 | 2x |
return(FLAT) |
| 53 |
} |
| 1 |
# utility function related to EFA |
|
| 2 | ||
| 3 |
# generate 'efa' syntax for a single block of factors |
|
| 4 |
lav_syntax_efa <- function(ov.names = NULL, nfactors = 1L, twolevel = FALSE) {
|
|
| 5 | 4x |
if (twolevel) {
|
| 6 | ! |
tmp <- lav_syntax_efa(ov.names = ov.names, nfactors = nfactors) |
| 7 | ! |
model <- c("level: 1", tmp, "level: 2", tmp)
|
| 8 |
} else {
|
|
| 9 | 4x |
model <- character(nfactors) |
| 10 | 4x |
for (f in seq_len(nfactors)) {
|
| 11 | 10x |
txt <- paste('efa("efa")*f', f, " =~ ",
|
| 12 | 10x |
paste(ov.names, collapse = " + "), |
| 13 | 10x |
sep = "" |
| 14 |
) |
|
| 15 | 10x |
model[f] <- txt |
| 16 |
} |
|
| 17 |
} |
|
| 18 | ||
| 19 | 4x |
model |
| 20 |
} |
|
| 21 | ||
| 22 |
# extract *standardized* loadings from efaList |
|
| 23 |
lav_efa_get_loadings <- function(object, ...) {
|
|
| 24 |
# kill object$loadings if present |
|
| 25 | 1x |
object[["loadings"]] <- NULL |
| 26 | ||
| 27 | 1x |
out <- lapply(object, function(x) {
|
| 28 | 4x |
STD <- lavTech(x, "std", |
| 29 | 4x |
add.class = TRUE, add.labels = TRUE, |
| 30 | 4x |
list.by.group = FALSE |
| 31 |
) |
|
| 32 | 4x |
lambda.idx <- which(names(STD) == "lambda") |
| 33 | 4x |
LAMBDA <- STD[lambda.idx] |
| 34 | 4x |
names(LAMBDA) <- NULL |
| 35 |
# if only single block, drop list |
|
| 36 | 4x |
if (length(LAMBDA) == 1L) {
|
| 37 | 4x |
LAMBDA <- LAMBDA[[1]] |
| 38 |
} else {
|
|
| 39 | ! |
names(LAMBDA) <- x@Data@block.label |
| 40 |
} |
|
| 41 | 4x |
LAMBDA |
| 42 |
}) |
|
| 43 | ||
| 44 |
# drop list if only a single model |
|
| 45 | 1x |
if (length(out) == 1L) {
|
| 46 | ! |
out <- out[[1]] |
| 47 |
} |
|
| 48 | ||
| 49 | 1x |
out |
| 50 |
} |
|
| 51 | ||
| 52 |
# find the best ordering of the columns in lambda_target, to minimize |
|
| 53 |
# the difference with the reference lambda matrix (lambda_ref) |
|
| 54 |
# |
|
| 55 |
# return the optimal order of the column for lambda_target |
|
| 56 |
lav_efa_find_best_order <- function(lambda_ref = NULL, lambda_target = NULL, |
|
| 57 |
crit = "rmse") {
|
|
| 58 | ! |
M <- ncol(lambda_ref) |
| 59 | ! |
stopifnot(ncol(lambda_target) == M) |
| 60 | ||
| 61 |
# all possible permutation |
|
| 62 |
# FIXEM:we really need a more elegant way to find the permutations... |
|
| 63 | ! |
tmp <- unname(as.matrix(expand.grid(rep(list(seq_len(M)), M)))) |
| 64 |
# select only rows where all numbers appear |
|
| 65 | ! |
perm <- tmp[apply(tmp, 1L, function(x) { length(unique(x)) == M }), ,
|
| 66 | ! |
drop = FALSE] |
| 67 | ||
| 68 | ! |
rmse.perm <- numeric( nrow(perm) ) |
| 69 | ! |
for (p in seq_len(nrow(perm))) {
|
| 70 | ! |
diff <- lambda_ref - lambda_target[,perm[p,], drop = FALSE] |
| 71 | ! |
diff2 <- diff * diff |
| 72 | ! |
mse <- mean(diff2) |
| 73 | ! |
rmse.perm[p] <- sqrt(mse) |
| 74 |
} |
|
| 75 | ! |
best.idx <- which.min(rmse.perm) |
| 76 | ||
| 77 |
# return 'best' permutation |
|
| 78 | ! |
perm[best.idx,] |
| 79 |
} |
| 1 |
lav_lavaan_step12_implied <- function(lavoptions = NULL, |
|
| 2 |
lavmodel = NULL) {
|
|
| 3 |
# # # # # # # # # # # # |
|
| 4 |
# # 12. lavimplied # # |
|
| 5 |
# # # # # # # # # # # # |
|
| 6 | ||
| 7 |
# if lavoptions$implied compute lavimplied via lav_model_implied |
|
| 8 | 140x |
lavimplied <- list() |
| 9 | 140x |
if (lavoptions$implied) {
|
| 10 | 140x |
if (lav_verbose()) {
|
| 11 | ! |
cat("lavimplied ...")
|
| 12 |
} |
|
| 13 | 140x |
lavimplied <- lav_model_implied(lavmodel) |
| 14 | 140x |
if (lav_verbose()) {
|
| 15 | ! |
cat(" done.\n")
|
| 16 |
} |
|
| 17 |
} |
|
| 18 | ||
| 19 | 140x |
lavimplied |
| 20 |
} |
|
| 21 | ||
| 22 |
lav_lavaan_step12_loglik <- function(lavoptions = NULL, |
|
| 23 |
lavdata = NULL, |
|
| 24 |
lavsamplestats = NULL, |
|
| 25 |
lavh1 = NULL, |
|
| 26 |
lavimplied = NULL, |
|
| 27 |
lavmodel = NULL) {
|
|
| 28 |
# # # # # # # # # # # # |
|
| 29 |
# # 12. lavloglik # # |
|
| 30 |
# # # # # # # # # # # # |
|
| 31 | ||
| 32 |
# only when missing = "ml" and zero coverage |
|
| 33 | 140x |
if (lavoptions$missing == "ml" && lavoptions$model.type == "unrestricted" && |
| 34 | 140x |
length(lavh1) == 0L) {
|
| 35 | ! |
lavh1 <- list(implied = lavimplied, |
| 36 | ! |
logl = list()) |
| 37 |
} |
|
| 38 | ||
| 39 |
# if lavoptions$loglik compute lavloglik via lav_model_loglik |
|
| 40 | 140x |
lavloglik <- list() |
| 41 | 140x |
if (lavoptions$loglik) {
|
| 42 | 140x |
if (lav_verbose()) {
|
| 43 | ! |
cat("lavloglik ...")
|
| 44 |
} |
|
| 45 | 140x |
lavloglik <- lav_model_loglik( |
| 46 | 140x |
lavdata = lavdata, |
| 47 | 140x |
lavsamplestats = lavsamplestats, |
| 48 | 140x |
lavh1 = lavh1, |
| 49 | 140x |
lavimplied = lavimplied, |
| 50 | 140x |
lavmodel = lavmodel, |
| 51 | 140x |
lavoptions = lavoptions |
| 52 |
) |
|
| 53 | 140x |
if (lav_verbose()) {
|
| 54 | ! |
cat(" done.\n")
|
| 55 |
} |
|
| 56 |
} |
|
| 57 | ||
| 58 | 140x |
lavloglik |
| 59 |
} |
| 1 |
lav_lavaan_step14_test <- function(lavoptions = NULL, |
|
| 2 |
lavmodel = NULL, |
|
| 3 |
lavsamplestats = NULL, |
|
| 4 |
lavdata = NULL, |
|
| 5 |
lavpartable = NULL, |
|
| 6 |
lavcache = NULL, |
|
| 7 |
lavimplied = NULL, |
|
| 8 |
lavh1 = NULL, |
|
| 9 |
x = NULL, |
|
| 10 |
VCOV = NULL, # nolint |
|
| 11 |
lavloglik = NULL) {
|
|
| 12 |
# # # # # # # # # # # |
|
| 13 |
# # 14. lavtest # # |
|
| 14 |
# # # # # # # # # # # |
|
| 15 | ||
| 16 |
# if lavoptions$test != "none" and x converged |
|
| 17 |
# compute lavtest via lav_model_test(...) |
|
| 18 |
# else |
|
| 19 |
# lavtest <- list(list(test = "none", stat = NA, |
|
| 20 |
# stat.group = rep(NA, lavdata@ngroups), |
|
| 21 |
# df = NA, refdistr = "unknown", pvalue = NA)) |
|
| 22 | 140x |
lavtest <- NULL |
| 23 | 140x |
if (!(length(lavoptions$test) == 1L && lavoptions$test == "none") && |
| 24 | 140x |
attr(x, "converged")) {
|
| 25 | 138x |
if (lav_verbose()) {
|
| 26 | ! |
cat("computing TEST for test(s) =", lavoptions$test, "...")
|
| 27 |
} |
|
| 28 | 138x |
lavtest <- lav_model_test( |
| 29 | 138x |
lavmodel = lavmodel, |
| 30 | 138x |
lavpartable = lavpartable, |
| 31 | 138x |
lavsamplestats = lavsamplestats, |
| 32 | 138x |
lavimplied = lavimplied, |
| 33 | 138x |
lavh1 = lavh1, |
| 34 | 138x |
lavoptions = lavoptions, |
| 35 | 138x |
x = x, |
| 36 | 138x |
VCOV = VCOV, |
| 37 | 138x |
lavdata = lavdata, |
| 38 | 138x |
lavcache = lavcache, |
| 39 | 138x |
lavloglik = lavloglik |
| 40 |
) |
|
| 41 | 138x |
if (lav_verbose()) {
|
| 42 | ! |
cat(" done.\n")
|
| 43 |
} |
|
| 44 |
} else {
|
|
| 45 | 2x |
lavtest <- list(list( |
| 46 | 2x |
test = "none", stat = NA, |
| 47 | 2x |
stat.group = rep(NA, lavdata@ngroups), df = NA, |
| 48 | 2x |
refdistr = "unknown", pvalue = NA |
| 49 |
)) |
|
| 50 |
} |
|
| 51 | ||
| 52 | 140x |
lavtest |
| 53 |
} |
|
| 54 | ||
| 55 |
lav_lavaan_step14_fit <- function(lavpartable = NULL, |
|
| 56 |
lavmodel = NULL, |
|
| 57 |
lavimplied = NULL, |
|
| 58 |
x = NULL, |
|
| 59 |
VCOV = NULL, # nolint |
|
| 60 |
lavtest = NULL) {
|
|
| 61 |
# # # # # # # # # # # # |
|
| 62 |
# # 14bis. lavfit # # -> remove if the offending packages are fixed!! |
|
| 63 |
# # # # # # # # # # # # |
|
| 64 | ||
| 65 | 140x |
lavfit <- lav_model_fit( |
| 66 | 140x |
lavpartable = lavpartable, |
| 67 | 140x |
lavmodel = lavmodel, |
| 68 | 140x |
lavimplied = lavimplied, |
| 69 | 140x |
x = x, |
| 70 | 140x |
VCOV = VCOV, |
| 71 | 140x |
TEST = lavtest |
| 72 |
) |
|
| 73 |
# lavfit <- new("Fit")
|
|
| 74 | ||
| 75 | 140x |
lavfit |
| 76 |
} |
| 1 |
# compute WLS.est (as a list per group) |
|
| 2 |
lav_model_wls_est <- function(lavmodel = NULL, GLIST = NULL, |
|
| 3 |
lavimplied = NULL) {
|
|
| 4 | 7356x |
nblocks <- lavmodel@nblocks |
| 5 | 7356x |
meanstructure <- lavmodel@meanstructure |
| 6 | 7356x |
correlation <- lavmodel@correlation |
| 7 | 7356x |
categorical <- lavmodel@categorical |
| 8 | 7356x |
group.w.free <- lavmodel@group.w.free |
| 9 | 7356x |
num.idx <- lavmodel@num.idx |
| 10 | ||
| 11 |
# model-implied statistics |
|
| 12 | 7356x |
if (is.null(lavimplied)) {
|
| 13 | 3862x |
lavimplied <- lav_model_implied(lavmodel, GLIST = GLIST) |
| 14 |
} |
|
| 15 | ||
| 16 | 7356x |
WLS.est <- vector("list", length = nblocks)
|
| 17 | 7356x |
for (g in 1:nblocks) {
|
| 18 | 7361x |
if (categorical) {
|
| 19 |
# order of elements is important here: |
|
| 20 |
# 1. thresholds + means (interleaved) |
|
| 21 |
# 2. slopes (if any, columnwise per exo) |
|
| 22 |
# 3. variances (if any) |
|
| 23 |
# 4. correlations (no diagonal!) |
|
| 24 | 5815x |
if (lavmodel@conditional.x) {
|
| 25 | 5815x |
wls.est <- c( |
| 26 | 5815x |
lavimplied$res.th[[g]], |
| 27 | 5815x |
lav_matrix_vec(lavimplied$res.slopes[[g]]), |
| 28 | 5815x |
diag(lavimplied$res.cov[[g]])[num.idx[[g]]], |
| 29 | 5815x |
lav_matrix_vech(lavimplied$res.cov[[g]], |
| 30 | 5815x |
diagonal = FALSE |
| 31 |
) |
|
| 32 |
) |
|
| 33 |
} else {
|
|
| 34 | ! |
wls.est <- c( |
| 35 | ! |
lavimplied$th[[g]], |
| 36 | ! |
diag(lavimplied$cov[[g]])[num.idx[[g]]], |
| 37 | ! |
lav_matrix_vech(lavimplied$cov[[g]], |
| 38 | ! |
diagonal = FALSE |
| 39 |
) |
|
| 40 |
) |
|
| 41 |
} |
|
| 42 |
} else {
|
|
| 43 |
# CONTINUOUS |
|
| 44 | 1546x |
DIAG <- TRUE |
| 45 | 1546x |
if (correlation) {
|
| 46 | ! |
DIAG <- FALSE |
| 47 |
} |
|
| 48 | ||
| 49 | 1546x |
if (lavmodel@conditional.x && lavmodel@nexo[g] > 0L) {
|
| 50 |
# order = vec(Beta), where first row are intercepts |
|
| 51 |
# cbind(res.int, res.slopes) is t(Beta) |
|
| 52 |
# so we need vecr |
|
| 53 | ! |
if (meanstructure) {
|
| 54 | ! |
wls.est <- c( |
| 55 | ! |
lav_matrix_vecr( |
| 56 | ! |
cbind( |
| 57 | ! |
lavimplied$res.int[[g]], |
| 58 | ! |
lavimplied$res.slopes[[g]] |
| 59 |
) |
|
| 60 |
), |
|
| 61 | ! |
lav_matrix_vech(lavimplied$res.cov[[g]], |
| 62 | ! |
diagonal = DIAG |
| 63 |
) |
|
| 64 |
) |
|
| 65 |
} else {
|
|
| 66 | ! |
wls.est <- c( |
| 67 | ! |
lav_matrix_vecr(lavimplied$res.slopes[[g]]), |
| 68 | ! |
lav_matrix_vech(lavimplied$res.cov[[g]], |
| 69 | ! |
diagonal = DIAG |
| 70 |
) |
|
| 71 |
) |
|
| 72 |
} |
|
| 73 |
} else {
|
|
| 74 | 1546x |
if (meanstructure) {
|
| 75 | 249x |
wls.est <- c( |
| 76 | 249x |
lavimplied$mean[[g]], |
| 77 | 249x |
lav_matrix_vech(lavimplied$cov[[g]], |
| 78 | 249x |
diagonal = DIAG |
| 79 |
) |
|
| 80 |
) |
|
| 81 |
} else {
|
|
| 82 | 1297x |
wls.est <- lav_matrix_vech(lavimplied$cov[[g]], |
| 83 | 1297x |
diagonal = DIAG |
| 84 |
) |
|
| 85 |
} |
|
| 86 |
} # conditional.x = FALSE |
|
| 87 |
} # categorical = FALSE |
|
| 88 | ||
| 89 | 7361x |
if (group.w.free) {
|
| 90 | ! |
wls.est <- c(lavimplied$group.w[[g]], wls.est) |
| 91 |
} |
|
| 92 | ||
| 93 | 7361x |
WLS.est[[g]] <- wls.est |
| 94 |
} |
|
| 95 | ||
| 96 | 7356x |
WLS.est |
| 97 |
} |
|
| 98 | ||
| 99 |
# Note: lav_model_wls_v() is replaced by lav_model_h1_information() in 0.6-1 |
| 1 |
lav_lavaan_step05_samplestats <- function(slotSampleStats = NULL, # nolint |
|
| 2 |
lavdata = NULL, |
|
| 3 |
lavoptions = NULL, |
|
| 4 |
WLS.V = NULL, # nolint |
|
| 5 |
NACOV = NULL, # nolint |
|
| 6 |
sample.cov = NULL, |
|
| 7 |
sample.mean = NULL, |
|
| 8 |
sample.th = NULL, |
|
| 9 |
sample.nobs = NULL, |
|
| 10 |
ov.names = NULL, |
|
| 11 |
ov.names.x = NULL, |
|
| 12 |
lavpartable = NULL) {
|
|
| 13 |
# # # # # # # # # # # # # # |
|
| 14 |
# # 5. lavsamplestats # # |
|
| 15 |
# # # # # # # # # # # # # # |
|
| 16 | ||
| 17 |
# if slotSampleStats not NULL |
|
| 18 |
# copy to lavsamplestats |
|
| 19 |
# else |
|
| 20 |
# if lavdata@data.type == "full" |
|
| 21 |
# compute lavsamplestats via lav_samplestats_from_data |
|
| 22 |
# else |
|
| 23 |
# if lavdata@data.type == "moment" |
|
| 24 |
# if lavoptions$meanstructure TRUE but sample.mean is NULL: |
|
| 25 |
# ** warning ** |
|
| 26 |
# compute lavsamplestats via lav_samplestats_from_moments |
|
| 27 |
# else |
|
| 28 |
# create lavsamplestats object (type lavSampleStats) with data from |
|
| 29 |
# lavdata and lavpta |
|
| 30 | ||
| 31 | 140x |
if (!is.null(slotSampleStats)) {
|
| 32 | 61x |
lavsamplestats <- slotSampleStats |
| 33 | 79x |
} else if (lavdata@data.type == "full") {
|
| 34 | 35x |
if (lav_verbose()) {
|
| 35 | ! |
cat("lavsamplestats ...")
|
| 36 |
} |
|
| 37 | 35x |
lavsamplestats <- lav_samplestats_from_data( |
| 38 | 35x |
lavdata = lavdata, |
| 39 | 35x |
lavoptions = lavoptions, |
| 40 | 35x |
WLS.V = WLS.V, |
| 41 | 35x |
NACOV = NACOV |
| 42 |
) |
|
| 43 | 35x |
if (lav_verbose()) {
|
| 44 | ! |
cat(" done.\n")
|
| 45 |
} |
|
| 46 | 44x |
} else if (lavdata@data.type == "moment") {
|
| 47 | 42x |
if (lav_verbose()) {
|
| 48 | ! |
cat("lavsamplestats ...")
|
| 49 |
} |
|
| 50 |
# check if we have sample.mean and meanstructure = TRUE |
|
| 51 | 42x |
if (lavoptions$meanstructure && is.null(sample.mean)) {
|
| 52 | ! |
lav_msg_warn( |
| 53 | ! |
gettext("sample.mean= argument is missing, but model contains
|
| 54 | ! |
mean/intercept parameters.")) |
| 55 |
} |
|
| 56 | 42x |
lavsamplestats <- lav_samplestats_from_moments( |
| 57 | 42x |
sample.cov = sample.cov, |
| 58 | 42x |
sample.mean = sample.mean, |
| 59 | 42x |
sample.th = sample.th, |
| 60 | 42x |
sample.nobs = sample.nobs, |
| 61 | 42x |
ov.names = ov.names, |
| 62 | 42x |
ov.names.x = ov.names.x, |
| 63 | 42x |
WLS.V = WLS.V, |
| 64 | 42x |
NACOV = NACOV, |
| 65 | 42x |
lavoptions = lavoptions |
| 66 |
) |
|
| 67 | 42x |
if (lav_verbose()) {
|
| 68 | ! |
cat(" done.\n")
|
| 69 |
} |
|
| 70 |
} else {
|
|
| 71 |
# no data |
|
| 72 | 2x |
lavsamplestats <- new("lavSampleStats",
|
| 73 | 2x |
ngroups = lavdata@ngroups, |
| 74 | 2x |
nobs = as.list(rep(0L, lavdata@ngroups)), |
| 75 | 2x |
cov.x = vector("list", length = lavdata@ngroups),
|
| 76 | 2x |
mean.x = vector("list", length = lavdata@ngroups),
|
| 77 | 2x |
th.idx = attr(lavpartable, "th.idx"), |
| 78 | 2x |
missing.flag = FALSE |
| 79 |
) |
|
| 80 |
} |
|
| 81 | ||
| 82 | 140x |
if (lav_debug()) {
|
| 83 | ! |
print(str(lavsamplestats)) |
| 84 |
} |
|
| 85 | ||
| 86 | 140x |
lavsamplestats |
| 87 |
} |
| 1 |
# generate a parameter table for an EFA model |
|
| 2 |
# |
|
| 3 |
# YR 20 Sept 2022: initial verion |
|
| 4 |
lav_partable_generate_efa <- function(ov.names = NULL, |
|
| 5 |
nfactors = 1L, |
|
| 6 |
meanstructure = FALSE, |
|
| 7 |
varTable = NULL) {
|
|
| 8 |
# currently, we support only a single block (but we plan for more) |
|
| 9 | ! |
nblocks <- 1L |
| 10 | ! |
ov.names <- list(ov.names) |
| 11 | ||
| 12 |
# currently, we only support continuous data (but ordered is planned) |
|
| 13 | ! |
stopifnot(is.null(ordered)) |
| 14 | ||
| 15 | ! |
lhs <- rhs <- op <- character(0) |
| 16 | ! |
block <- free <- integer(0) |
| 17 | ! |
ustart <- numeric(0) |
| 18 | ||
| 19 |
# create factor names |
|
| 20 | ! |
lv.names <- paste("f", 1:nfactors, sep = "")
|
| 21 | ||
| 22 |
# block number |
|
| 23 | ! |
for (b in seq_len(nblocks)) {
|
| 24 |
# ov.names for this block |
|
| 25 | ! |
OV.NAMES <- ov.names[[b]] |
| 26 | ! |
nvar <- length(OV.NAMES) |
| 27 | ! |
nel <- nvar * nfactors |
| 28 | ||
| 29 |
# get 'ordered' variables from varTable |
|
| 30 | ! |
categorical <- FALSE |
| 31 | ! |
if (!is.null(varTable)) {
|
| 32 | ! |
ov.names.ord <- |
| 33 | ! |
as.character(varTable$name[varTable$type == "ordered"]) |
| 34 |
# remove those that do appear in the model syntax |
|
| 35 | ! |
idx <- which(!ov.names.ord %in% OV.NAMES) |
| 36 | ! |
if (length(idx) > 0L) {
|
| 37 | ! |
ov.names.ord <- ov.names.ord[-idx] |
| 38 |
} |
|
| 39 | ! |
if (length(ov.names.ord) > 0L) {
|
| 40 | ! |
ov.names.ord <- OV.NAMES[OV.NAMES %in% ov.names.ord] |
| 41 | ! |
categorical <- TRUE |
| 42 |
} |
|
| 43 |
} |
|
| 44 | ||
| 45 |
# a) factor loadings |
|
| 46 | ! |
lhs <- c(lhs, rep(lv.names, each = nvar)) |
| 47 | ! |
op <- c(op, rep("=~", nel))
|
| 48 | ! |
rhs <- c(rhs, rep(OV.NAMES, times = nfactors)) |
| 49 | ! |
block <- c(block, rep(b, nel)) |
| 50 |
# group <- c(group, rep(1L, nel)) |
|
| 51 |
# level <- c(level, rep(1L, nel)) |
|
| 52 | ! |
free <- c(free, rep(1L, nel)) # for now |
| 53 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nel)) |
| 54 | ||
| 55 |
# b) ov variances |
|
| 56 | ! |
lhs <- c(lhs, OV.NAMES) |
| 57 | ! |
op <- c(op, rep("~~", nvar))
|
| 58 | ! |
rhs <- c(rhs, OV.NAMES) |
| 59 | ! |
block <- c(block, rep(b, nvar)) |
| 60 |
# group <- c(group, rep(1L, nvar)) |
|
| 61 |
# level <- c(level, rep(1L, nvar)) |
|
| 62 | ! |
free <- c(free, rep(1L, nvar)) |
| 63 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nvar)) |
| 64 | ||
| 65 |
# c) lv variances |
|
| 66 | ! |
lhs <- c(lhs, lv.names) |
| 67 | ! |
op <- c(op, rep("~~", nfactors))
|
| 68 | ! |
rhs <- c(rhs, lv.names) |
| 69 | ! |
block <- c(block, rep(b, nfactors)) |
| 70 |
# group <- c(group, rep(1L, nfactors)) |
|
| 71 |
# level <- c(level, rep(1L, nfactors)) |
|
| 72 | ! |
free <- c(free, rep(0L, nfactors)) # standardized! |
| 73 | ! |
ustart <- c(ustart, rep(1, nfactors)) |
| 74 | ||
| 75 |
# d) lv covariances |
|
| 76 | ! |
pstar <- nfactors * (nfactors - 1) / 2 |
| 77 | ! |
if (pstar > 0L) { # only if more than 1 variable
|
| 78 | ! |
tmp <- utils::combn(lv.names, 2) |
| 79 | ! |
lhs <- c(lhs, tmp[1, ]) # to fill upper.tri |
| 80 | ! |
op <- c(op, rep("~~", pstar))
|
| 81 | ! |
rhs <- c(rhs, tmp[2, ]) |
| 82 | ! |
block <- c(block, rep(b, pstar)) |
| 83 |
# group <- c(group, rep(g, pstar)) |
|
| 84 |
# level <- c(level, rep(l, pstar)) |
|
| 85 | ! |
free <- c(free, rep(1L, pstar)) # to be changed... |
| 86 | ! |
ustart <- c(ustart, rep(as.numeric(NA), pstar)) |
| 87 |
} |
|
| 88 | ||
| 89 | ! |
if (meanstructure) {
|
| 90 |
# e) ov means/intercepts |
|
| 91 | ! |
lhs <- c(lhs, OV.NAMES) |
| 92 | ! |
op <- c(op, rep("~1", nvar))
|
| 93 | ! |
rhs <- c(rhs, rep("", nvar))
|
| 94 | ! |
block <- c(block, rep(b, nvar)) |
| 95 |
# group <- c(group, rep(1L, nvar)) |
|
| 96 |
# level <- c(level, rep(1L, nvar)) |
|
| 97 | ! |
free <- c(free, rep(1L, nvar)) |
| 98 | ! |
ustart <- c(ustart, rep(as.numeric(NA), nvar)) |
| 99 | ||
| 100 |
# f) lv means/intercepts |
|
| 101 | ! |
lhs <- c(lhs, lv.names) |
| 102 | ! |
op <- c(op, rep("~1", nfactors))
|
| 103 | ! |
rhs <- c(rhs, rep("", nfactors))
|
| 104 | ! |
block <- c(block, rep(b, nfactors)) |
| 105 |
# group <- c(group, rep(1L, nfactors)) |
|
| 106 |
# level <- c(level, rep(1L, nfactors)) |
|
| 107 | ! |
free <- c(free, rep(0L, nfactors)) |
| 108 | ! |
ustart <- c(ustart, rep(0, nfactors)) |
| 109 |
} # meanstructure |
|
| 110 |
} # blocks |
|
| 111 | ||
| 112 |
# create LIST |
|
| 113 | ! |
LIST <- list( |
| 114 | ! |
id = 1:length(lhs), |
| 115 | ! |
lhs = lhs, |
| 116 | ! |
op = op, |
| 117 | ! |
rhs = rhs, |
| 118 | ! |
user = rep(0L, length(lhs)), # all system-generated |
| 119 | ! |
block = block, |
| 120 | ! |
group = rep(1L, length(lhs)), |
| 121 |
# level = level, |
|
| 122 | ! |
free = free, |
| 123 | ! |
ustart = ustart, |
| 124 | ! |
exo = rep(0L, length(lhs)), |
| 125 | ! |
label = rep("", length(lhs)),
|
| 126 | ! |
efa = rep("", length(lhs))
|
| 127 |
) |
|
| 128 | ||
| 129 |
# add 'efa' column with a single block string (i.e., "efa") |
|
| 130 | ! |
LIST$efa[LIST$op == "=~"] <- "efa" |
| 131 | ||
| 132 |
# take care of EFA constraints |
|
| 133 | ! |
LIST <- lav_partable_efa_constraints(LIST) |
| 134 | ||
| 135 |
# free counter |
|
| 136 | ! |
idx.free <- which(LIST$free > 0) |
| 137 | ! |
LIST$free[idx.free] <- seq_along(idx.free) |
| 138 | ||
| 139 |
# needed? |
|
| 140 | ! |
LIST <- lav_partable_complete(LIST) |
| 141 | ||
| 142 | ! |
LIST |
| 143 |
} |
|
| 144 | ||
| 145 |
# handle EFA equality constraints |
|
| 146 |
# YR 14 Jan 2020: 0.6-6 does no longer impose 'explicit' constraints |
|
| 147 |
# if we only need to fix a parameter to 0/1 |
|
| 148 |
# Note: we should also check if they are really needed: |
|
| 149 |
# eg., if all the factor-loadings of the 'second' set (time/group) |
|
| 150 |
# are constrained to be equal to the factor-loadings of the first |
|
| 151 |
# set, no further constraints are needed |
|
| 152 |
lav_partable_efa_constraints <- function(LIST = NULL, |
|
| 153 |
orthogonal.efa = FALSE, |
|
| 154 |
group.equal = character(0L)) {
|
|
| 155 |
# for each set, for each block |
|
| 156 | 4x |
nblocks <- lav_partable_nblocks(LIST) |
| 157 | 4x |
set.names <- lav_partable_efa_values(LIST) |
| 158 | 4x |
nsets <- length(set.names) |
| 159 | ||
| 160 | 4x |
for (b in seq_len(nblocks)) {
|
| 161 | 4x |
for (s in seq_len(nsets)) {
|
| 162 |
# lv's for this block/set |
|
| 163 | 4x |
lv.nam.efa <- unique(LIST$lhs[LIST$op == "=~" & |
| 164 | 4x |
LIST$block == b & |
| 165 | 4x |
LIST$efa == set.names[s]]) |
| 166 | 4x |
if (length(lv.nam.efa) == 1L) {
|
| 167 |
# nothing to do (warn?) |
|
| 168 | 1x |
next |
| 169 |
} |
|
| 170 | ||
| 171 |
# equality constraints on ALL factor loadings in this set? |
|
| 172 |
# two scenario's: |
|
| 173 |
# 1. eq constraints within the same block, perhaps time1/time2/ |
|
| 174 |
# 2. eq constraints across groups (group.equal = "loadings") |
|
| 175 |
# --> no constraints are needed |
|
| 176 | ||
| 177 |
# store labels (if any) |
|
| 178 | 3x |
fix.to.zero <- TRUE |
| 179 | ||
| 180 |
# 1. within block/group |
|
| 181 | 3x |
if (s == 1L) {
|
| 182 | 3x |
set.idx <- which(LIST$op == "=~" & |
| 183 | 3x |
LIST$block == b & |
| 184 | 3x |
LIST$lhs %in% lv.nam.efa) |
| 185 | 3x |
LABEL.set1 <- LIST$label[set.idx] |
| 186 |
} else {
|
|
| 187 |
# collect labels for this set, if any |
|
| 188 | ! |
set.idx <- which(LIST$op == "=~" & |
| 189 | ! |
LIST$block == b & |
| 190 | ! |
LIST$lhs %in% lv.nam.efa) |
| 191 | ||
| 192 |
# user-provided labels (if any) |
|
| 193 | ! |
this.label.set <- LIST$label[set.idx] |
| 194 | ||
| 195 |
# same as in reference set? |
|
| 196 | ! |
if (all(nchar(this.label.set) > 0L) && |
| 197 | ! |
all(this.label.set %in% LABEL.set1)) {
|
| 198 | ! |
fix.to.zero <- FALSE |
| 199 |
} |
|
| 200 |
} |
|
| 201 | ||
| 202 |
# 2. across groups |
|
| 203 | 3x |
if (b == 1L) {
|
| 204 | 3x |
set.idx <- which(LIST$op == "=~" & |
| 205 | 3x |
LIST$block == b & |
| 206 | 3x |
LIST$lhs %in% lv.nam.efa) |
| 207 | 3x |
LABEL.group1 <- LIST$label[set.idx] |
| 208 |
} else {
|
|
| 209 | ! |
if ("loadings" %in% group.equal) {
|
| 210 | ! |
fix.to.zero <- FALSE |
| 211 |
} else {
|
|
| 212 |
# collect labels for this set, if any |
|
| 213 | ! |
set.idx <- which(LIST$op == "=~" & |
| 214 | ! |
LIST$block == b & |
| 215 | ! |
LIST$lhs %in% lv.nam.efa) |
| 216 | ||
| 217 |
# user-provided labels (if any) |
|
| 218 | ! |
this.label.set <- LIST$label[set.idx] |
| 219 | ||
| 220 |
# same as in reference set? |
|
| 221 | ! |
if (all(nchar(this.label.set) > 0L) && |
| 222 | ! |
all(this.label.set %in% LABEL.group1)) {
|
| 223 | ! |
fix.to.zero <- FALSE |
| 224 |
} |
|
| 225 |
} |
|
| 226 |
} |
|
| 227 | ||
| 228 |
# 1. echelon pattern |
|
| 229 | 3x |
nfac <- length(lv.nam.efa) |
| 230 | 3x |
for (f in seq_len(nfac)) {
|
| 231 | 9x |
if (f == 1L) {
|
| 232 | 3x |
next |
| 233 |
} |
|
| 234 | 6x |
nzero <- (f - 1L) |
| 235 | 6x |
ind.idx <- which(LIST$op == "=~" & |
| 236 | 6x |
LIST$block == b & |
| 237 | 6x |
LIST$lhs %in% lv.nam.efa[f]) |
| 238 | 6x |
if (length(ind.idx) < nzero) {
|
| 239 | ! |
lav_msg_stop(gettextf( |
| 240 | ! |
"efa factor %s has not enough indicators for echelon pattern", |
| 241 | ! |
lv.nam.efa[f])) |
| 242 |
} |
|
| 243 | ||
| 244 |
# fix to zero |
|
| 245 | 6x |
if (fix.to.zero) {
|
| 246 | 6x |
LIST$free[ind.idx[seq_len(nzero)]] <- 0L |
| 247 | 6x |
LIST$ustart[ind.idx[seq_len(nzero)]] <- 0 |
| 248 | 6x |
LIST$user[ind.idx[seq_len(nzero)]] <- 7L |
| 249 |
} else {
|
|
| 250 | ! |
LIST$user[ind.idx[seq_len(nzero)]] <- 77L |
| 251 |
} |
|
| 252 |
} |
|
| 253 | ||
| 254 |
# 2. covariances constrained to zero (only if oblique rotation) |
|
| 255 | 3x |
if (!orthogonal.efa) {
|
| 256 |
# skip if user == 1 (user-override!) |
|
| 257 | 3x |
cov.idx <- which(LIST$op == "~~" & |
| 258 | 3x |
LIST$block == b & |
| 259 | 3x |
LIST$user == 0L & |
| 260 | 3x |
LIST$lhs %in% lv.nam.efa & |
| 261 | 3x |
LIST$rhs %in% lv.nam.efa & |
| 262 | 3x |
LIST$lhs != LIST$rhs) |
| 263 | ||
| 264 |
# fix to zero |
|
| 265 | 3x |
if (fix.to.zero) {
|
| 266 | 3x |
LIST$free[cov.idx] <- 0L |
| 267 | 3x |
LIST$ustart[cov.idx] <- 0 |
| 268 | 3x |
LIST$user[cov.idx] <- 7L |
| 269 |
} else {
|
|
| 270 | ! |
LIST$user[cov.idx] <- 77L |
| 271 |
} |
|
| 272 |
} |
|
| 273 |
} # sets |
|
| 274 |
} # blocks |
|
| 275 | ||
| 276 | 4x |
LIST |
| 277 |
} |
| 1 |
lav_lavaan_step10_cache <- function(slotCache = NULL, # nolint |
|
| 2 |
lavdata = NULL, |
|
| 3 |
lavmodel = NULL, |
|
| 4 |
lavpartable = NULL, |
|
| 5 |
lavoptions = NULL, |
|
| 6 |
sampling.weights = NULL) {
|
|
| 7 |
# # # # # # # # # # # |
|
| 8 |
# # 10. lavcache # # |
|
| 9 |
# # # # # # # # # # # |
|
| 10 | ||
| 11 |
# if slotCache not NULL |
|
| 12 |
# copy to lavcache |
|
| 13 |
# else |
|
| 14 |
# lavcache = list of length lavdata@ngroups |
|
| 15 |
# set tmp.ov.types = lavdata$ov$types |
|
| 16 |
# if lavmodel@conditional.x and sum(lavmodel@nexo) > 0L remove elements |
|
| 17 |
# lavpta$vidx$ov.x from tmp.ov.types |
|
| 18 |
# if lavoptions$estimator == "PML" and all tmp.ov.types are "ordered" |
|
| 19 |
# th = lav_model_th(lavmodel) |
|
| 20 |
# bi = lav_tables_pairwise_freq_cells(lavdata) |
|
| 21 |
# if lavoptions$missing is "available.cases" or "doubly.robust" |
|
| 22 |
# uni = lav_tables_univariate_freq_cell(lavdata) |
|
| 23 |
# if lavoptions$missing is "doubly.robust" |
|
| 24 |
# if lavoptions$control$pairwiseProbGivObs NULL: *** error *** |
|
| 25 |
# if lavoptions$control$univariateProbGivObs NULL: *** error *** |
|
| 26 |
# for all groups (1:lavdata@ngroups) |
|
| 27 |
# set tmp.idx = 1:length(bi$ibs.freq) |
|
| 28 |
# if bi$group not NULL and max(bi$group) > 1L set tmp.idx = indexes |
|
| 29 |
# for this group in bi |
|
| 30 |
# set bifreq = bi$obs.freq[tmp.idx] |
|
| 31 |
# set binobs = bi$nobs[tmp.idx] |
|
| 32 |
# set long = lav_pml_longvec_ind(no.x = ncol(lavdata@X[[g]]), |
|
| 33 |
# all.thres = th[[g]], |
|
| 34 |
# index.var.of.thres = lavmodel@th.idx[[g]]) |
|
| 35 |
# set lavcache[[g]] = list(bifreq = bifreq, nobs = binobs, long = long) |
|
| 36 |
# if sampling.weights not NULL |
|
| 37 |
# compute (for group g) lavcache[[g]]$sum_obs_weights_xixj_ab_vec (*) |
|
| 38 |
# if lavoptions$missing is "available.cases" or "doubly.robust" |
|
| 39 |
# set tmp.idx = 1:length(bi$ibs.freq) |
|
| 40 |
# if bi$group not NULL and max(bi$group) > 1L set tmp.idx = indexes |
|
| 41 |
# for this group in bi |
|
| 42 |
# set lavcache[[g]]$unifreq = unifreq = uni$obs.freq[tmp.idx] |
|
| 43 |
# set lavcache[[g]]$uninobs = uninobs = uni$nobs[tmp.idx] |
|
| 44 |
# set lavcache[[g]]$uniweights.casewise = uniweights.casewise = |
|
| 45 |
# rowSums(is.na(lavdata@X[[g]])) |
|
| 46 |
# compute lavcache[[g]]$uniweights (*) |
|
| 47 |
# if lavoptions$missing is "doubly.robust" |
|
| 48 |
# lavcache[[g]]$pairwiseProbGivObs = |
|
| 49 |
# lavoptions$control$pairwiseProbGivObs[[g]] |
|
| 50 |
# lavcache[[g]]$univariateProbGivObs = |
|
| 51 |
# lavoptions$control$univariateProbGivObs[[g]] |
|
| 52 |
# compute members idx.y1, idx.gy2, idx.cat.y1, idx.cat.gy2 and |
|
| 53 |
# id.uniPrGivObs from |
|
| 54 |
# lavchache[[g]] (*) |
|
| 55 |
# if lavdata$data.type is "full" and lavdata@Rp[[1L]] not NULL |
|
| 56 |
# copy lavdata@Rp[[g]]$pat to lavcache[[g]]$pat for all groups g |
|
| 57 |
# if lavoptions$estimator is "MML" |
|
| 58 |
# compute for all groups g lavcache[[g]]$GH via |
|
| 59 |
# lav_integration_gauss_hermite |
|
| 60 |
# |
|
| 61 |
# (*) !!! computations too complicated to summarize here !!! |
|
| 62 | ||
| 63 | 140x |
if (!is.null(slotCache)) {
|
| 64 | 61x |
lavcache <- slotCache |
| 65 |
} else {
|
|
| 66 |
# prepare cache -- stuff needed for estimation, but also post-estimation |
|
| 67 | 79x |
lavcache <- vector("list", length = lavdata@ngroups)
|
| 68 | ||
| 69 |
# ov.types? (for PML check) |
|
| 70 | 79x |
tmp.ov.types <- lavdata@ov$type |
| 71 | 79x |
if (lavmodel@conditional.x && sum(lavmodel@nexo) > 0L) {
|
| 72 |
# remove ov.x |
|
| 73 | 2x |
tmp.ov.x.idx <- unlist(attr(lavpartable, "vidx")$ov.x) |
| 74 | 2x |
tmp.ov.types <- tmp.ov.types[-tmp.ov.x.idx] |
| 75 |
} |
|
| 76 | ||
| 77 | 79x |
if (lavoptions$estimator == "PML" && all(tmp.ov.types == "ordered")) {
|
| 78 | ! |
th <- lav_model_th(lavmodel) |
| 79 | ! |
bi <- lav_tables_pairwise_freq_cell(lavdata) |
| 80 | ||
| 81 |
# handle option missing = "available.cases" or "doubly.robust" |
|
| 82 | ! |
if (lavoptions$missing == "available.cases" || |
| 83 | ! |
lavoptions$missing == "doubly.robust") {
|
| 84 | ! |
uni <- lav_tables_univariate_freq_cell(lavdata) |
| 85 |
# checks for missing = "double.robust" |
|
| 86 | ! |
if (lavoptions$missing == "doubly.robust") {
|
| 87 |
# check whether the probabilities pairwiseProbGivObs and |
|
| 88 |
# univariateProbGivObs are given by the user |
|
| 89 | ! |
if (is.null(lavoptions$control$pairwiseProbGivObs)) {
|
| 90 | ! |
lav_msg_stop(gettext( |
| 91 | ! |
"could not find `pairwiseProbGivObs' in control() list")) |
| 92 |
} |
|
| 93 | ! |
if (is.null(lavoptions$control$univariateProbGivObs)) {
|
| 94 | ! |
lav_msg_stop(gettext( |
| 95 | ! |
"could not find `univariateProbGivObs' in control() list")) |
| 96 |
} |
|
| 97 |
} |
|
| 98 |
} |
|
| 99 | ||
| 100 | ! |
for (g in 1:lavdata@ngroups) {
|
| 101 | ! |
if (is.null(bi$group) || max(bi$group) == 1L) {
|
| 102 | ! |
bifreq <- bi$obs.freq |
| 103 | ! |
binobs <- bi$nobs |
| 104 |
} else {
|
|
| 105 | ! |
idx <- which(bi$group == g) |
| 106 | ! |
bifreq <- bi$obs.freq[idx] |
| 107 | ! |
binobs <- bi$nobs[idx] |
| 108 |
} |
|
| 109 | ! |
long <- lav_pml_longvec_ind( |
| 110 | ! |
no.x = ncol(lavdata@X[[g]]), |
| 111 | ! |
all.thres = th[[g]], |
| 112 | ! |
index.var.of.thres = lavmodel@th.idx[[g]] |
| 113 |
) |
|
| 114 | ! |
lavcache[[g]] <- list( |
| 115 | ! |
bifreq = bifreq, |
| 116 | ! |
nobs = binobs, |
| 117 | ! |
long = long |
| 118 |
) |
|
| 119 | ||
| 120 |
# >>>>>>>> HJ/MK PML CODE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 121 | ||
| 122 |
# I need to add something that splits weights into g groups so |
|
| 123 |
# adjust what follows in the new code also compute the sum of |
|
| 124 |
# weights within a group, this will substitute n_g (group size) |
|
| 125 |
# of simple random sampling (SRS) and also compute the total the |
|
| 126 |
# total sum of weights over all observation over all groups, |
|
| 127 |
# this substitutes the total sample size of SRS. |
|
| 128 | ||
| 129 | ! |
if (!is.null(sampling.weights)) {
|
| 130 |
# Keep track of indices of the response categories (a,b) of a |
|
| 131 |
# pair of ordinal variables (xi,xj) appearing in the data as |
|
| 132 |
# well as the index of the pair. |
|
| 133 | ! |
idx_ab_of_xixj_ab <- lapply(long[c(1:2, 5)], function(x) {
|
| 134 | ! |
x[(long$index.thres.var1.of.pair != 0) & |
| 135 | ! |
(long$index.thres.var2.of.pair != 0)] |
| 136 |
}) |
|
| 137 | ! |
names(idx_ab_of_xixj_ab) <- c("idx_a", "idx_b", "idx_pairs")
|
| 138 | ! |
lavcache[[g]]$idx_ab_of_xixj_ab <- idx_ab_of_xixj_ab |
| 139 | ||
| 140 |
# Raw data for group g |
|
| 141 | ! |
X.g <- lavdata@X[[g]] # nolint |
| 142 | ||
| 143 |
# I assume that X.g includes only the ordinal indicators nvar |
|
| 144 |
# gives the number of ordinal indicators |
|
| 145 | ! |
nvar <- ncol(X.g) |
| 146 | ||
| 147 |
# pstar gives the number of pairs formed by the nvar ordinal |
|
| 148 |
# indicators |
|
| 149 | ! |
pstar <- nvar * (nvar - 1) / 2 |
| 150 | ||
| 151 |
# Keep track of the indices of variables forming each pair |
|
| 152 | ! |
idx_vars_in_pair <- combn(nvar, 2) |
| 153 | ||
| 154 |
# The output of sapply below provides the sum of weights for |
|
| 155 |
# all bivariate response pattern for all pairs of indicators. |
|
| 156 | ||
| 157 |
# If all indicators have the same number of response |
|
| 158 |
# categories, the output of sapply function below is a matrix. |
|
| 159 |
# Each column refers to a different pair of indicators (i,j) |
|
| 160 |
# with j running faster than i, e.g. (1,2) (1,3) (2,3). Within |
|
| 161 |
# each column, each element (i.e. each row of the matrix) |
|
| 162 |
# refers to a different combination of response categories |
|
| 163 |
# (a,b) with a, the category index of indicator i, running |
|
| 164 |
# faster than b, the category index of indicator j, e.g. |
|
| 165 |
# (1,1), (2,1) (3,1) (1,2) (2,2) (3,2) |
|
| 166 | ||
| 167 |
# If the indicators have different number of response |
|
| 168 |
# categories, the output of sapply function below is a list. |
|
| 169 |
# Each element of the list refers to a different pair of |
|
| 170 |
# indicators (i,j) with j running faster than i and it is a |
|
| 171 |
# matrix with number of rows the number of response categories |
|
| 172 |
# of indicator i and ncol = the number of response categories |
|
| 173 |
# of indicator j. |
|
| 174 | ||
| 175 | ! |
sum_obs_weights_xixj_ab <- sapply(1:pstar, function(x) {
|
| 176 | ! |
tmp_idx_ab <- lapply(idx_ab_of_xixj_ab, function(y) {
|
| 177 | ! |
y[idx_ab_of_xixj_ab$idx_pairs == x] |
| 178 |
}) |
|
| 179 | ! |
tmp_idx_cols <- idx_vars_in_pair[, x] |
| 180 | ! |
tmp_var1 <- factor(X.g[, tmp_idx_cols[1]], |
| 181 | ! |
levels = |
| 182 | ! |
as.character(unique(tmp_idx_ab$idx_a)) |
| 183 |
) |
|
| 184 | ! |
tmp_var2 <- factor(X.g[, tmp_idx_cols[2]], |
| 185 | ! |
levels = |
| 186 | ! |
as.character(unique(tmp_idx_ab$idx_b)) |
| 187 |
) |
|
| 188 | ! |
tapply( |
| 189 | ! |
X = lavdata@weights[[g]], |
| 190 | ! |
INDEX = list(tmp_var1, tmp_var2), |
| 191 | ! |
FUN = sum |
| 192 |
) |
|
| 193 |
}) |
|
| 194 | ||
| 195 |
# We need to transform the output of sapply into a vector |
|
| 196 |
# where the sum of weights (for all bivariate response |
|
| 197 |
# patterns for all pairs of indicators) are listed in the same |
|
| 198 |
# order as in pairwisePI vector, i.e. a runs the fastest, |
|
| 199 |
# followed by b, then by j and lastly by i. |
|
| 200 | ||
| 201 | ! |
if (is.matrix(sum_obs_weights_xixj_ab)) {
|
| 202 | ! |
sum_obs_weights_xixj_ab_vec <- c(sum_obs_weights_xixj_ab) |
| 203 | ! |
} else if (is.list(sum_obs_weights_xixj_ab)) {
|
| 204 | ! |
sum_obs_weights_xixj_ab_vec <- |
| 205 | ! |
do.call(c, sum_obs_weights_xixj_ab) |
| 206 |
} |
|
| 207 | ||
| 208 |
# Note that sapply gives NA for these bivariate response |
|
| 209 |
# patterns which are not observed at all. Substitute NA with |
|
| 210 |
# 0. |
|
| 211 | ! |
idx_na_sowxav <- is.na(sum_obs_weights_xixj_ab_vec) |
| 212 | ! |
if (any(idx_na_sowxav)) {
|
| 213 | ! |
sum_obs_weights_xixj_ab_vec[idx_na_sowxav] <- 0 |
| 214 |
} |
|
| 215 | ||
| 216 | ! |
lavcache[[g]]$sum_obs_weights_xixj_ab_vec <- |
| 217 | ! |
sum_obs_weights_xixj_ab_vec |
| 218 |
} |
|
| 219 | ||
| 220 |
# >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> |
|
| 221 | ||
| 222 |
# available cases |
|
| 223 | ! |
if (lavoptions$missing == "available.cases" || |
| 224 | ! |
lavoptions$missing == "doubly.robust") {
|
| 225 | ! |
if (is.null(uni$group) || max(uni$group) == 1L) {
|
| 226 | ! |
unifreq <- uni$obs.freq |
| 227 | ! |
uninobs <- uni$nobs |
| 228 |
} else {
|
|
| 229 | ! |
idx <- which(uni$group == g) |
| 230 | ! |
unifreq <- uni$obs.freq[idx] |
| 231 | ! |
uninobs <- uni$nobs[idx] |
| 232 |
} |
|
| 233 | ! |
lavcache[[g]]$unifreq <- unifreq |
| 234 | ! |
lavcache[[g]]$uninobs <- uninobs |
| 235 | ||
| 236 | ! |
uniweights.casewise <- rowSums(is.na(lavdata@X[[g]])) |
| 237 | ! |
lavcache[[g]]$uniweights.casewise <- uniweights.casewise |
| 238 | ||
| 239 |
# weights per response category per variable in the same |
|
| 240 |
# order as unifreq; i.e. w_ia, i = 1,...,p, (p variables), |
|
| 241 |
# a = 1,...,Ci, (Ci response categories for variable i), |
|
| 242 |
# a running faster than i |
|
| 243 | ! |
tmp.uniweights <- apply( |
| 244 | ! |
lavdata@X[[g]], 2, |
| 245 | ! |
function(x) {
|
| 246 | ! |
tapply(uniweights.casewise, as.factor(x), sum, |
| 247 | ! |
na.rm = TRUE |
| 248 |
) |
|
| 249 |
} |
|
| 250 |
) |
|
| 251 | ! |
if (is.matrix(tmp.uniweights)) {
|
| 252 | ! |
lavcache[[g]]$uniweights <- c(tmp.uniweights) |
| 253 |
} |
|
| 254 | ! |
if (is.list(tmp.uniweights)) {
|
| 255 | ! |
lavcache[[g]]$uniweights <- unlist(tmp.uniweights) |
| 256 |
} |
|
| 257 |
} # "available.cases" or "double.robust" |
|
| 258 | ||
| 259 |
# doubly.robust only |
|
| 260 | ! |
if (lavoptions$missing == "doubly.robust") {
|
| 261 |
# add the provided by the user probabilities |
|
| 262 |
# pairwiseProbGivObs and univariateProbGivObs in Cache |
|
| 263 | ! |
lavcache[[g]]$pairwiseProbGivObs <- |
| 264 | ! |
lavoptions$control$pairwiseProbGivObs[[g]] |
| 265 | ! |
lavcache[[g]]$univariateProbGivObs <- |
| 266 | ! |
lavoptions$control$univariateProbGivObs[[g]] |
| 267 |
# compute different indices vectors that will help to do |
|
| 268 |
# calculations |
|
| 269 | ! |
ind.vec <- as.data.frame(long[1:5]) |
| 270 | ! |
ind.vec <- |
| 271 | ! |
ind.vec[((ind.vec$index.thres.var1.of.pair != 0) & |
| 272 | ! |
(ind.vec$index.thres.var2.of.pair != 0)), ] |
| 273 | ! |
idx.cat.y1 <- ind.vec$index.thres.var1.of.pair |
| 274 | ! |
idx.cat.y2 <- ind.vec$index.thres.var2.of.pair |
| 275 | ! |
idx.pairs <- ind.vec$index.pairs.extended |
| 276 | ! |
lavcache[[g]]$idx.pairs <- idx.pairs |
| 277 | ||
| 278 | ! |
idx.cat.y1.split <- split(idx.cat.y1, idx.pairs) |
| 279 | ! |
idx.cat.y2.split <- split(idx.cat.y2, idx.pairs) |
| 280 | ! |
lavcache[[g]]$idx.cat.y1.split <- idx.cat.y1.split |
| 281 | ! |
lavcache[[g]]$idx.cat.y2.split <- idx.cat.y2.split |
| 282 | ||
| 283 |
# generate the variables, categories indices vector which |
|
| 284 |
# keep track to which variables and categories the |
|
| 285 |
# elements of vector probY1Gy2 refer to |
|
| 286 | ! |
nlev <- lavdata@ov$nlev |
| 287 | ! |
nvar <- length(nlev) |
| 288 | ||
| 289 | ! |
idx.var.matrix <- matrix(1:nvar, nrow = nvar, ncol = nvar) |
| 290 | ! |
idx.diag <- diag(matrix(1:(nvar * nvar), |
| 291 | ! |
nrow = nvar, |
| 292 | ! |
ncol = nvar |
| 293 |
)) |
|
| 294 | ! |
idx.y1gy2.matrix <- rbind( |
| 295 | ! |
t(idx.var.matrix)[-idx.diag], |
| 296 | ! |
idx.var.matrix[-idx.diag] |
| 297 |
) |
|
| 298 | ! |
no.pairs.y1gy2 <- ncol(idx.y1gy2.matrix) |
| 299 | ! |
idx.cat.y1 <- unlist(lapply(1:no.pairs.y1gy2, function(x) {
|
| 300 | ! |
rep(1:nlev[idx.y1gy2.matrix[1, x]], |
| 301 | ! |
times = nlev[idx.y1gy2.matrix[2, x]] |
| 302 |
) |
|
| 303 |
})) |
|
| 304 | ! |
idx.cat.gy2 <- unlist(lapply(1:no.pairs.y1gy2, function(x) {
|
| 305 | ! |
rep(1:nlev[idx.y1gy2.matrix[2, x]], |
| 306 | ! |
each = nlev[idx.y1gy2.matrix[1, x]] |
| 307 |
) |
|
| 308 |
})) |
|
| 309 | ! |
dim.pairs <- unlist(lapply(1:no.pairs.y1gy2, function(x) {
|
| 310 | ! |
nlev[idx.y1gy2.matrix[1, x]] * |
| 311 | ! |
nlev[idx.y1gy2.matrix[2, x]] |
| 312 |
})) |
|
| 313 | ! |
idx.y1 <- unlist(mapply(rep, idx.y1gy2.matrix[1, ], |
| 314 | ! |
each = dim.pairs |
| 315 |
)) |
|
| 316 | ! |
idx.gy2 <- unlist(mapply(rep, idx.y1gy2.matrix[2, ], |
| 317 | ! |
each = dim.pairs |
| 318 |
)) |
|
| 319 | ||
| 320 | ! |
lavcache[[g]]$idx.Y1 <- idx.y1 |
| 321 | ! |
lavcache[[g]]$idx.Gy2 <- idx.gy2 |
| 322 | ! |
lavcache[[g]]$idx.cat.Y1 <- idx.cat.y1 |
| 323 | ! |
lavcache[[g]]$idx.cat.Gy2 <- idx.cat.gy2 |
| 324 | ||
| 325 |
# the vector below keeps track of the variable each column |
|
| 326 |
# of the matrix univariateProbGivObs refers to |
|
| 327 | ! |
lavcache[[g]]$id.uniPrGivObs <- |
| 328 | ! |
sort(c( |
| 329 | ! |
unique(lavmodel@th.idx[[g]]), |
| 330 | ! |
lavmodel@th.idx[[g]] |
| 331 |
)) |
|
| 332 |
} # doubly.robust |
|
| 333 |
} # g |
|
| 334 |
} |
|
| 335 |
# copy response patterns to cache -- FIXME!! (data not included |
|
| 336 |
# in Model only functions) |
|
| 337 | 79x |
if (lavdata@data.type == "full" && !is.null(lavdata@Rp[[1L]])) {
|
| 338 | 2x |
for (g in 1:lavdata@ngroups) {
|
| 339 | 2x |
lavcache[[g]]$pat <- lavdata@Rp[[g]]$pat |
| 340 |
} |
|
| 341 |
} |
|
| 342 |
} |
|
| 343 | ||
| 344 |
# If estimator = MML, store Gauss-Hermite nodes/weights |
|
| 345 | 140x |
if (lavoptions$estimator == "MML") {
|
| 346 | ! |
for (g in 1:lavdata@ngroups) {
|
| 347 |
# count only the ones with non-normal indicators |
|
| 348 |
# nfac <- lavpta$nfac.nonnormal[[g]] |
|
| 349 | ! |
nfac <- attr(lavpartable, "nfac")[[g]] |
| 350 | ! |
lavcache[[g]]$GH <- |
| 351 | ! |
lav_integration_gauss_hermite( |
| 352 | ! |
n = lavoptions$integration.ngh, |
| 353 | ! |
dnorm = TRUE, |
| 354 | ! |
mean = 0, sd = 1, |
| 355 | ! |
ndim = nfac |
| 356 |
) |
|
| 357 |
# lavcache[[g]]$DD <- lav_model_gradient_DD(lavmodel, group = g) |
|
| 358 |
} |
|
| 359 |
} |
|
| 360 | ||
| 361 | 140x |
lavcache |
| 362 |
} |
| 1 |
# YR 19 September 2022 |
|
| 2 |
# |
|
| 3 |
# Entry function to handle noniterative estimators |
|
| 4 | ||
| 5 | ||
| 6 |
lav_optim_noniter <- function(lavmodel = NULL, lavsamplestats = NULL, |
|
| 7 |
lavpartable = NULL, lavh1 = NULL, |
|
| 8 |
lavdata = NULL, lavoptions = NULL) {
|
|
| 9 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 10 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 11 | ||
| 12 |
# no support for many things: |
|
| 13 | ! |
if (lavmodel@ngroups > 1L) {
|
| 14 | ! |
lav_msg_stop(gettext( |
| 15 | ! |
"multiple groups not supported (yet) with optim.method = 'NONITER'.")) |
| 16 |
} |
|
| 17 | ||
| 18 | ! |
if (lavdata@nlevels > 1L) {
|
| 19 | ! |
lav_msg_stop(gettext( |
| 20 | ! |
"multilevel not supported (yet) with optim.method = 'NONITER'.")) |
| 21 |
} |
|
| 22 | ||
| 23 |
# no support (yet) for nonlinear constraints |
|
| 24 | ! |
nonlinear.idx <- c( |
| 25 | ! |
lavmodel@ceq.nonlinear.idx, |
| 26 | ! |
lavmodel@cin.nonlinear.idx |
| 27 |
) |
|
| 28 | ! |
if (length(nonlinear.idx) > 0L) {
|
| 29 | ! |
lav_msg_stop(gettext( |
| 30 | ! |
"nonlinear constraints not supported (yet) with optim.method = 'NONITER'." |
| 31 |
)) |
|
| 32 |
} |
|
| 33 | ||
| 34 |
# no support (yet) for inequality constraints |
|
| 35 | ! |
if (!lavmodel@cin.simple.only && !is.null(body(lavmodel@cin.function))) {
|
| 36 | ! |
lav_msg_stop(gettext( |
| 37 | ! |
"inequality constraints not supported (yet) with optim.method = 'NONITER'." |
| 38 |
)) |
|
| 39 |
} |
|
| 40 | ||
| 41 |
# no support (yet) for equality constraints |
|
| 42 | ! |
if (length(lavmodel@ceq.linear.idx) > 0L) {
|
| 43 | ! |
lav_msg_stop(gettext( |
| 44 | ! |
"equality constraints not supported (yet) with optim.method = 'NONITER'." |
| 45 |
)) |
|
| 46 |
} |
|
| 47 | ||
| 48 |
# extract current set of free parameters |
|
| 49 | ! |
x.old <- lav_model_get_parameters(lavmodel) |
| 50 | ! |
npar <- length(x.old) |
| 51 | ||
| 52 | ||
| 53 |
# fabin? |
|
| 54 | ! |
ok.flag <- FALSE |
| 55 | ! |
if (lavoptions$estimator %in% c("FABIN2", "FABIN3")) {
|
| 56 | ! |
x <- try(lav_cfa_fabin_internal( |
| 57 | ! |
lavmodel = lavmodel, |
| 58 | ! |
lavsamplestats = lavsamplestats, lavpartable = lavpartable, |
| 59 | ! |
lavoptions = lavoptions |
| 60 | ! |
), silent = TRUE) |
| 61 | ! |
} else if (lavoptions$estimator == "MGM") {
|
| 62 | ! |
x <- try(lav_cfa_guttman1952_internal( |
| 63 | ! |
lavmodel = lavmodel, |
| 64 | ! |
lavsamplestats = lavsamplestats, lavpartable = lavpartable, |
| 65 | ! |
lavoptions = lavoptions |
| 66 | ! |
), silent = TRUE) |
| 67 | ! |
} else if (lavoptions$estimator == "BENTLER1982") {
|
| 68 | ! |
x <- try(lav_cfa_bentler1982_internal( |
| 69 | ! |
lavmodel = lavmodel, |
| 70 | ! |
lavsamplestats = lavsamplestats, lavpartable = lavpartable, |
| 71 | ! |
lavoptions = lavoptions |
| 72 | ! |
), silent = TRUE) |
| 73 | ! |
} else if (lavoptions$estimator %in% c("JS", "JSA")) {
|
| 74 | ! |
x <- try(lav_cfa_jamesstein_internal( |
| 75 | ! |
lavmodel = lavmodel, |
| 76 | ! |
lavsamplestats = lavsamplestats, lavpartable = lavpartable, |
| 77 | ! |
lavdata = lavdata, |
| 78 | ! |
lavoptions = lavoptions |
| 79 | ! |
), silent = TRUE) |
| 80 | ! |
} else if (lavoptions$estimator == "BENTLER1982") {
|
| 81 | ! |
x <- try(lav_cfa_bentler1982_internal( |
| 82 | ! |
lavmodel = lavmodel, |
| 83 | ! |
lavsamplestats = lavsamplestats, lavpartable = lavpartable, |
| 84 | ! |
lavoptions = lavoptions |
| 85 | ! |
), silent = TRUE) |
| 86 | ! |
} else if (lavoptions$estimator == "IV") {
|
| 87 | ! |
x <- try(lav_sem_miiv_internal( |
| 88 | ! |
lavmodel = lavmodel, lavdata = lavdata, lavh1 = lavh1, |
| 89 | ! |
lavsamplestats = lavsamplestats, lavpartable = lavpartable, |
| 90 | ! |
lavoptions = lavoptions |
| 91 | ! |
), silent = TRUE) |
| 92 |
} else {
|
|
| 93 | ! |
lav_msg_warn( |
| 94 | ! |
gettextf("unknown (noniterative) estimator: %s
|
| 95 | ! |
(returning starting values)", lavoptions$estimator) |
| 96 |
) |
|
| 97 |
} |
|
| 98 | ! |
if (inherits(x, "try-error")) {
|
| 99 | ! |
x <- x.old |
| 100 |
} else {
|
|
| 101 | ! |
ok.flag <- TRUE |
| 102 |
} |
|
| 103 | ||
| 104 |
# closing |
|
| 105 | ! |
fx <- 0 |
| 106 | ! |
attr(fx, "fx.group") <- rep(0, lavmodel@ngroups) |
| 107 | ! |
if (ok.flag) {
|
| 108 | ! |
attr(x, "converged") <- TRUE |
| 109 | ! |
attr(x, "warn.txt") <- "" |
| 110 |
} else {
|
|
| 111 | ! |
attr(x, "converged") <- FALSE |
| 112 | ! |
attr(x, "warn.txt") <- "noniterative estimation failed" |
| 113 |
} |
|
| 114 | ! |
attr(x, "iterations") <- 1L |
| 115 | ! |
attr(x, "control") <- list() |
| 116 | ! |
attr(x, "fx") <- fx |
| 117 | ||
| 118 | ! |
x |
| 119 |
} |
| 1 |
# compute the loglikelihood of the data, given the current values of the |
|
| 2 |
# model parameters |
|
| 3 |
lav_model_loglik <- function(lavdata = NULL, |
|
| 4 |
lavsamplestats = NULL, |
|
| 5 |
lavh1 = NULL, |
|
| 6 |
lavimplied = NULL, |
|
| 7 |
lavmodel = NULL, |
|
| 8 |
lavoptions = NULL) {
|
|
| 9 | 140x |
ngroups <- lavdata@ngroups |
| 10 | ||
| 11 | 140x |
logl.group <- rep(as.numeric(NA), ngroups) |
| 12 | ||
| 13 |
# should compute logl, or return NA? |
|
| 14 | 140x |
logl.ok <- FALSE |
| 15 | 140x |
if (lavoptions$estimator %in% c("ML", "MML")) {
|
| 16 |
# check if everything is numeric, OR if we have exogenous |
|
| 17 |
# factor with 2 levels only |
|
| 18 |
# if(all(lavdata@ov$type == "numeric")) {
|
|
| 19 | 120x |
logl.ok <- TRUE |
| 20 |
# } else {
|
|
| 21 | 120x |
if (lavoptions$fixed.x == FALSE) {
|
| 22 | 60x |
exo.idx <- which(lavdata@ov$exo == 1L) |
| 23 | 60x |
for (i in exo.idx) {
|
| 24 | ! |
if (lavdata@ov$nlev[i] > 1L) {
|
| 25 | ! |
logl.ok <- FALSE |
| 26 |
} |
|
| 27 |
} |
|
| 28 |
} |
|
| 29 |
# nlevels + fiml |
|
| 30 |
# if(lavdata@nlevels > 1L && lavsamplestats@missing.flag) {
|
|
| 31 |
# logl.ok <- FALSE |
|
| 32 |
# } |
|
| 33 |
} |
|
| 34 | ||
| 35 |
# lavsamplestats filled in? (not if no data, or samplestats = FALSE) |
|
| 36 | 140x |
if (length(lavsamplestats@ntotal) == 0L || |
| 37 | 140x |
(!is.null(lavoptions$samplestats) && !lavoptions$samplestats)) {
|
| 38 | 2x |
logl.ok <- FALSE |
| 39 |
} |
|
| 40 | ||
| 41 |
# catch all-zero Sigma (new in 0.6-20) |
|
| 42 | 140x |
nblocks <- lavmodel@nblocks |
| 43 | 140x |
for (b in seq_len(nblocks)) {
|
| 44 | 157x |
if (lavmodel@conditional.x) {
|
| 45 | 4x |
if (all(lavimplied$res.cov[[b]] == 0)) {
|
| 46 | ! |
logl.ok <- FALSE |
| 47 |
} |
|
| 48 |
} else {
|
|
| 49 | 153x |
if (all(lavimplied$cov[[b]] == 0)) {
|
| 50 | ! |
logl.ok <- FALSE |
| 51 |
} |
|
| 52 |
} |
|
| 53 |
} |
|
| 54 | ||
| 55 | ||
| 56 | 140x |
if (logl.ok) {
|
| 57 | 118x |
for (g in seq_len(ngroups)) {
|
| 58 | 126x |
if (lavdata@nlevels > 1L) {
|
| 59 |
# here, we assume only 2 levels, at [[1]] and [[2]] |
|
| 60 | 8x |
if (lavmodel@conditional.x) {
|
| 61 | ! |
Res.Sigma.W <- lavimplied$res.cov[[(g - 1) * 2 + 1]] |
| 62 | ! |
Res.Int.W <- lavimplied$res.int[[(g - 1) * 2 + 1]] |
| 63 | ! |
Res.Pi.W <- lavimplied$res.slopes[[(g - 1) * 2 + 1]] |
| 64 | ||
| 65 | ! |
Res.Sigma.B <- lavimplied$res.cov[[(g - 1) * 2 + 2]] |
| 66 | ! |
Res.Int.B <- lavimplied$res.int[[(g - 1) * 2 + 2]] |
| 67 | ! |
Res.Pi.B <- lavimplied$res.slopes[[(g - 1) * 2 + 2]] |
| 68 |
} else {
|
|
| 69 | 8x |
Sigma.W <- lavimplied$cov[[(g - 1) * 2 + 1]] |
| 70 | 8x |
Mu.W <- lavimplied$mean[[(g - 1) * 2 + 1]] |
| 71 | 8x |
Sigma.B <- lavimplied$cov[[(g - 1) * 2 + 2]] |
| 72 | 8x |
Mu.B <- lavimplied$mean[[(g - 1) * 2 + 2]] |
| 73 |
} |
|
| 74 | ||
| 75 | 8x |
if (lavsamplestats@missing.flag) {
|
| 76 | ! |
if (lavmodel@conditional.x) {
|
| 77 |
# TODO |
|
| 78 | ! |
logl.group[g] <- as.numeric(NA) |
| 79 |
} else {
|
|
| 80 | ! |
logl.group[g] <- |
| 81 | ! |
lav_mvnorm_cluster_missing_loglik_samplestats_2l( |
| 82 | ! |
Y1 = lavdata@X[[g]], |
| 83 | ! |
Y2 = lavsamplestats@YLp[[g]][[2]]$Y2, |
| 84 | ! |
Lp = lavdata@Lp[[g]], |
| 85 | ! |
Mp = lavdata@Mp[[g]], |
| 86 | ! |
Mu.W = Mu.W, Sigma.W = Sigma.W, |
| 87 | ! |
Mu.B = Mu.B, Sigma.B = Sigma.B, |
| 88 | ! |
loglik.x = lavsamplestats@YLp[[g]][[2]]$loglik.x, |
| 89 | ! |
log2pi = TRUE, minus.two = FALSE |
| 90 |
) |
|
| 91 |
} |
|
| 92 |
} else {
|
|
| 93 |
# complete case |
|
| 94 | 8x |
if (lavmodel@conditional.x) {
|
| 95 | ! |
logl.group[g] <- |
| 96 | ! |
lav_mvreg_cluster_loglik_samplestats_2l( |
| 97 | ! |
YLp = lavsamplestats@YLp[[g]], |
| 98 | ! |
Lp = lavdata@Lp[[g]], |
| 99 | ! |
Res.Sigma.W = Res.Sigma.W, |
| 100 | ! |
Res.Int.W = Res.Int.W, |
| 101 | ! |
Res.Pi.W = Res.Pi.W, |
| 102 | ! |
Res.Sigma.B = Res.Sigma.B, |
| 103 | ! |
Res.Int.B = Res.Int.B, |
| 104 | ! |
Res.Pi.B = Res.Pi.B, |
| 105 | ! |
Sinv.method = "eigen", |
| 106 | ! |
log2pi = TRUE, |
| 107 | ! |
minus.two = FALSE |
| 108 |
) |
|
| 109 |
} else {
|
|
| 110 | 8x |
logl.group[g] <- |
| 111 | 8x |
lav_mvnorm_cluster_loglik_samplestats_2l( |
| 112 | 8x |
YLp = lavsamplestats@YLp[[g]], |
| 113 | 8x |
Lp = lavdata@Lp[[g]], |
| 114 | 8x |
Mu.W = Mu.W, |
| 115 | 8x |
Sigma.W = Sigma.W, |
| 116 | 8x |
Mu.B = Mu.B, |
| 117 | 8x |
Sigma.B = Sigma.B, |
| 118 | 8x |
Sinv.method = "eigen", |
| 119 | 8x |
log2pi = TRUE, |
| 120 | 8x |
minus.two = FALSE |
| 121 |
) |
|
| 122 |
} |
|
| 123 |
} # complete |
|
| 124 |
# end multilevel |
|
| 125 | 118x |
} else if (lavsamplestats@missing.flag) {
|
| 126 | 32x |
x.idx <- lavsamplestats@x.idx[[g]] |
| 127 | 32x |
X.MEAN <- X.COV <- NULL |
| 128 | 32x |
if (length(x.idx) > 0L) {
|
| 129 | 24x |
X.MEAN <- lavh1$implied$mean[[g]][x.idx] |
| 130 | 24x |
X.COV <- lavh1$implied$cov[[g]][x.idx, x.idx, drop = FALSE] |
| 131 |
} |
|
| 132 | 32x |
logl.group[g] <- lav_mvnorm_missing_loglik_samplestats( |
| 133 | 32x |
Yp = lavsamplestats@missing[[g]], |
| 134 | 32x |
Mu = lavimplied$mean[[g]], |
| 135 | 32x |
Sigma = lavimplied$cov[[g]], |
| 136 | 32x |
x.idx = lavsamplestats@x.idx[[g]], |
| 137 | 32x |
x.mean = X.MEAN, # not needed? should be part of Sigma |
| 138 | 32x |
x.cov = X.COV |
| 139 | 32x |
) # not needed at all! |
| 140 |
} else { # single-level, complete data
|
|
| 141 | 86x |
if (lavoptions$conditional.x) {
|
| 142 |
# FIXME: use lavh1 |
|
| 143 | ! |
logl.group[g] <- lav_mvreg_loglik_samplestats( |
| 144 | ! |
sample.res.int = lavsamplestats@res.int[[g]], |
| 145 | ! |
sample.res.slopes = lavsamplestats@res.slopes[[g]], |
| 146 | ! |
sample.res.cov = lavsamplestats@res.cov[[g]], |
| 147 | ! |
sample.mean.x = lavsamplestats@mean.x[[g]], |
| 148 | ! |
sample.cov.x = lavsamplestats@cov.x[[g]], |
| 149 | ! |
sample.nobs = lavsamplestats@nobs[[g]], |
| 150 | ! |
res.int = lavimplied$res.int[[g]], |
| 151 | ! |
res.slopes = lavimplied$res.slopes[[g]], |
| 152 | ! |
res.cov = lavimplied$res.cov[[g]], |
| 153 | ! |
Sinv.method = "eigen" |
| 154 |
) |
|
| 155 |
} else {
|
|
| 156 | 86x |
if (lavoptions$meanstructure) {
|
| 157 | 54x |
Mu <- lavimplied$mean[[g]] |
| 158 |
} else {
|
|
| 159 | 32x |
Mu <- lavsamplestats@mean[[g]] |
| 160 |
} |
|
| 161 | 86x |
logl.group[g] <- lav_mvnorm_loglik_samplestats( |
| 162 | 86x |
sample.mean = lavsamplestats@mean[[g]], |
| 163 | 86x |
sample.cov = lavsamplestats@cov[[g]], |
| 164 | 86x |
sample.nobs = lavsamplestats@nobs[[g]], |
| 165 | 86x |
Mu = Mu, |
| 166 | 86x |
Sigma = lavimplied$cov[[g]], |
| 167 | 86x |
x.idx = lavsamplestats@x.idx[[g]], |
| 168 | 86x |
x.mean = lavsamplestats@mean.x[[g]], |
| 169 | 86x |
x.cov = lavsamplestats@cov.x[[g]], |
| 170 | 86x |
Sinv.method = "eigen", |
| 171 | 86x |
Sigma.inv = NULL |
| 172 |
) |
|
| 173 |
} |
|
| 174 |
} # complete |
|
| 175 |
} # g |
|
| 176 |
} # logl.ok is TRUE |
|
| 177 | ||
| 178 |
# logl |
|
| 179 | 140x |
logl <- sum(logl.group) |
| 180 | ||
| 181 |
# number of parameters, taking into account any equality constraints |
|
| 182 | 140x |
npar <- lavmodel@nx.free |
| 183 | 140x |
ceq.simple.only <- lavmodel@ceq.simple.only |
| 184 | 140x |
cin.simple.only <- lavmodel@cin.simple.only |
| 185 | ||
| 186 | 140x |
if (ceq.simple.only) {
|
| 187 |
# nothing to do |
|
| 188 | 140x |
} else if (!cin.simple.only && nrow(lavmodel@con.jac) > 0L) {
|
| 189 | 12x |
ceq.idx <- attr(lavmodel@con.jac, "ceq.idx") |
| 190 | 12x |
if (length(ceq.idx) > 0L) {
|
| 191 | 10x |
neq <- qr(lavmodel@con.jac[ceq.idx, , drop = FALSE])$rank |
| 192 | 10x |
npar <- npar - neq |
| 193 |
} |
|
| 194 |
} |
|
| 195 | ||
| 196 |
# logl |
|
| 197 | 140x |
logl <- sum(logl.group) |
| 198 | ||
| 199 | 140x |
if (logl.ok) {
|
| 200 |
# AIC |
|
| 201 | 118x |
AIC <- lav_fit_aic(logl = logl, npar = npar) |
| 202 | ||
| 203 |
# BIC |
|
| 204 | 118x |
BIC <- lav_fit_bic(logl = logl, npar = npar, N = lavsamplestats@ntotal) |
| 205 | ||
| 206 |
# BIC2 |
|
| 207 | 118x |
BIC2 <- lav_fit_sabic( |
| 208 | 118x |
logl = logl, npar = npar, |
| 209 | 118x |
N = lavsamplestats@ntotal |
| 210 |
) |
|
| 211 |
} else {
|
|
| 212 | 22x |
AIC <- BIC <- BIC2 <- as.numeric(NA) |
| 213 |
} |
|
| 214 | ||
| 215 | 140x |
out <- list( |
| 216 | 140x |
loglik = logl, |
| 217 | 140x |
loglik.group = logl.group, |
| 218 | 140x |
npar = npar, |
| 219 | 140x |
ntotal = lavsamplestats@ntotal, |
| 220 | 140x |
AIC = AIC, |
| 221 | 140x |
BIC = BIC, |
| 222 | 140x |
BIC2 = BIC2, |
| 223 | 140x |
estimator = lavoptions$estimator, |
| 224 | 140x |
conditional.x = lavoptions$conditional.x, |
| 225 | 140x |
fixed.x = lavoptions$fixed.x |
| 226 |
) |
|
| 227 | ||
| 228 | 140x |
out |
| 229 |
} |
| 1 |
# FABIN = factor analysis by instrumental variables |
|
| 2 |
# Hagglund 1982 (efa), 1986 (cfa) |
|
| 3 | ||
| 4 |
lav_cfa_fabin2 <- function(S, marker.idx = NULL, lambda.nonzero.idx = NULL) {
|
|
| 5 | ! |
nvar <- ncol(S) |
| 6 | ! |
nfac <- length(marker.idx) |
| 7 | ||
| 8 |
# overview of free/fixed |
|
| 9 | ! |
LAMBDA <- matrix(0, nvar, nfac) |
| 10 | ! |
LAMBDA[lambda.nonzero.idx] <- -1L |
| 11 | ||
| 12 | ! |
lambda <- matrix(0, nvar, nfac) |
| 13 | ! |
for (i in 1:nvar) {
|
| 14 | ! |
if (i %in% marker.idx) {
|
| 15 | ! |
lambda[i, marker.idx == i] <- 1.0 |
| 16 | ! |
next |
| 17 |
} |
|
| 18 | ! |
free.idx <- LAMBDA[i, ] == -1L |
| 19 | ! |
idx3 <- (1:nvar)[-c(i, marker.idx)] |
| 20 | ! |
s23 <- S[i, idx3] |
| 21 | ! |
fac.idx <- marker.idx[free.idx] |
| 22 | ||
| 23 | ! |
if (length(fac.idx) == 1L) { # most common scenario in CFA
|
| 24 | ! |
S31 <- S13 <- S[idx3, fac.idx] |
| 25 | ! |
lambda[i, free.idx] <- sum(s23 * S31) / sum(S13 * S13) |
| 26 |
} else {
|
|
| 27 | ! |
S31 <- S[idx3, fac.idx, drop = FALSE] |
| 28 | ! |
S13 <- S[fac.idx, idx3, drop = FALSE] |
| 29 | ! |
lambda[i, free.idx] <- solve(S13 %*% S31, drop(s23 %*% S31)) |
| 30 |
} |
|
| 31 |
} |
|
| 32 | ||
| 33 | ! |
lambda |
| 34 |
} |
|
| 35 | ||
| 36 |
lav_cfa_fabin3 <- function(S, marker.idx = NULL, lambda.nonzero.idx = NULL) {
|
|
| 37 | ! |
nvar <- ncol(S) |
| 38 | ! |
nfac <- length(marker.idx) |
| 39 | ||
| 40 |
# overview of free/fixed |
|
| 41 | ! |
LAMBDA <- matrix(0, nvar, nfac) |
| 42 | ! |
LAMBDA[lambda.nonzero.idx] <- -1L |
| 43 | ||
| 44 | ! |
S33.inv <- try(solve(S[-marker.idx, -marker.idx, drop = FALSE]), |
| 45 | ! |
silent = TRUE |
| 46 |
) |
|
| 47 | ! |
if (inherits(S33.inv, "try-error")) {
|
| 48 | ! |
lav_msg_warn(gettext("fabin3 failed; switching to fabin2"))
|
| 49 | ! |
return(lav_cfa_fabin2( |
| 50 | ! |
S = S, marker.idx = marker.idx, |
| 51 | ! |
lambda.nonzero.idx = lambda.nonzero.idx |
| 52 |
)) |
|
| 53 |
} |
|
| 54 | ||
| 55 | ! |
lambda <- matrix(0, nvar, nfac) |
| 56 | ! |
rm3.idx <- 0L |
| 57 | ! |
for (i in 1:nvar) {
|
| 58 | ! |
if (i %in% marker.idx) {
|
| 59 | ! |
lambda[i, marker.idx == i] <- 1.0 |
| 60 | ! |
next |
| 61 |
} |
|
| 62 | ! |
free.idx <- LAMBDA[i, ] == -1L |
| 63 | ! |
idx3 <- (1:nvar)[-c(i, marker.idx)] |
| 64 | ! |
S33 <- S[idx3, idx3, drop = FALSE] |
| 65 | ! |
s23 <- S[i, idx3] |
| 66 | ! |
fac.idx <- marker.idx[free.idx] |
| 67 | ! |
rm3.idx <- rm3.idx + 1L |
| 68 |
# update inverse |
|
| 69 | ! |
s33.inv <- lav_matrix_symmetric_inverse_update( |
| 70 | ! |
S.inv = S33.inv, |
| 71 | ! |
rm.idx = rm3.idx |
| 72 |
) |
|
| 73 | ||
| 74 | ! |
if (length(fac.idx) == 1L) { # most common scenario in CFA
|
| 75 | ! |
S31 <- S13 <- S[idx3, fac.idx] |
| 76 | ! |
tmp <- s33.inv %*% S31 # or colSums(s33.inv * S31) |
| 77 | ! |
lambda[i, free.idx] <- sum(s23 * tmp) / sum(S13 * tmp) |
| 78 |
} else {
|
|
| 79 | ! |
S31 <- S[idx3, fac.idx, drop = FALSE] |
| 80 | ! |
S13 <- S[fac.idx, idx3, drop = FALSE] |
| 81 | ! |
tmp <- s33.inv %*% S31 |
| 82 |
# lambda[i, free.idx] <- ( s23 %*% solve(S33) %*% S31 %*% |
|
| 83 |
# solve(S13 %*% solve(S33) %*% S31) ) |
|
| 84 | ! |
lambda[i, free.idx] <- solve(S13 %*% tmp, drop(s23 %*% tmp)) |
| 85 |
} |
|
| 86 |
} |
|
| 87 | ||
| 88 | ! |
lambda |
| 89 |
} |
|
| 90 | ||
| 91 |
# internal function to be used inside lav_optim_noniter |
|
| 92 |
# return 'x', the estimated vector of free parameters |
|
| 93 |
lav_cfa_fabin_internal <- function(lavmodel = NULL, lavsamplestats = NULL, |
|
| 94 |
lavpartable = NULL, |
|
| 95 |
lavdata = NULL, lavoptions = NULL) {
|
|
| 96 | ! |
lavpta <- lav_partable_attributes(lavpartable) |
| 97 | ! |
lavpartable <- lav_partable_set_cache(lavpartable, lavpta) |
| 98 |
# no structural part! |
|
| 99 | ! |
if (any(lavpartable$op == "~")) {
|
| 100 | ! |
lav_msg_stop(gettext("FABIN estimator only available for CFA models"))
|
| 101 |
} |
|
| 102 |
# no BETA matrix! (i.e., no higher-order factors) |
|
| 103 | ! |
if (!is.null(lavmodel@GLIST$beta)) {
|
| 104 | ! |
lav_msg_stop(gettext( |
| 105 | ! |
"FABIN estimator not available for models that require a BETA matrix")) |
| 106 |
} |
|
| 107 |
# no std.lv = TRUE for now |
|
| 108 | ! |
if (lavoptions$std.lv) {
|
| 109 | ! |
lav_msg_stop( |
| 110 | ! |
gettext("FABIN estimator not available if std.lv = TRUE"))
|
| 111 |
} |
|
| 112 | ||
| 113 | ! |
nblocks <- lav_partable_nblocks(lavpartable) |
| 114 | ! |
stopifnot(nblocks == 1L) # for now |
| 115 | ! |
b <- 1L |
| 116 | ! |
sample.cov <- lavsamplestats@cov[[b]] |
| 117 | ! |
nvar <- nrow(sample.cov) |
| 118 | ! |
lv.names <- lavpta$vnames$lv.regular[[b]] |
| 119 | ! |
nfac <- length(lv.names) |
| 120 | ! |
marker.idx <- lavpta$vidx$lv.marker[[b]] |
| 121 | ! |
lambda.idx <- which(names(lavmodel@GLIST) == "lambda") |
| 122 | ! |
lambda.nonzero.idx <- lavmodel@m.free.idx[[lambda.idx]] |
| 123 |
# only diagonal THETA for now... |
|
| 124 |
# because if we have correlated residuals, we should remove the |
|
| 125 |
# corresponding variables as instruments before we estimate lambda... |
|
| 126 |
# (see MIIV) |
|
| 127 | ! |
theta.idx <- which(names(lavmodel@GLIST) == "theta") # usually '2' |
| 128 | ! |
m.theta <- lavmodel@m.free.idx[[theta.idx]] |
| 129 | ! |
nondiag.idx <- m.theta[!m.theta %in% lav_matrix_diag_idx(nvar)] |
| 130 | ! |
if (length(nondiag.idx) > 0L) {
|
| 131 | ! |
lav_msg_warn(gettext( |
| 132 | ! |
"this implementation of FABIN does not handle correlated residuals yet!" |
| 133 |
)) |
|
| 134 |
} |
|
| 135 | ||
| 136 |
# 1. estimate LAMBDA |
|
| 137 | ! |
if (lavoptions$estimator == "FABIN2") {
|
| 138 | ! |
LAMBDA <- lav_cfa_fabin2( |
| 139 | ! |
S = sample.cov, marker.idx = marker.idx, |
| 140 | ! |
lambda.nonzero.idx = lambda.nonzero.idx |
| 141 |
) |
|
| 142 |
} else {
|
|
| 143 | ! |
LAMBDA <- lav_cfa_fabin3( |
| 144 | ! |
S = sample.cov, marker.idx = marker.idx, |
| 145 | ! |
lambda.nonzero.idx = lambda.nonzero.idx |
| 146 |
) |
|
| 147 |
} |
|
| 148 | ||
| 149 |
# 2. simple ULS method to get THETA and PSI (for now) |
|
| 150 | ! |
GLS.flag <- FALSE |
| 151 | ! |
psi.mapping.ML.flag <- FALSE |
| 152 | ! |
if (!is.null(lavoptions$estimator.args$thetapsi.method) && |
| 153 | ! |
lavoptions$estimator.args$thetapsi.method %in% c("GLS", "GLS.ML")) {
|
| 154 | ! |
GLS.flag <- TRUE |
| 155 |
} |
|
| 156 | ! |
if (!is.null(lavoptions$estimator.args$thetapsi.method) && |
| 157 | ! |
lavoptions$estimator.args$thetapsi.method %in% c("ULS.ML", "GLS.ML")) {
|
| 158 | ! |
psi.mapping.ML.flag <- TRUE |
| 159 |
} |
|
| 160 | ! |
out <- lav_cfa_lambda2thetapsi( |
| 161 | ! |
lambda = LAMBDA, S = sample.cov, |
| 162 | ! |
S.inv = lavsamplestats@icov[[b]], |
| 163 | ! |
GLS = GLS.flag, |
| 164 | ! |
psi.mapping.ML = psi.mapping.ML.flag, |
| 165 | ! |
nobs = lavsamplestats@ntotal |
| 166 |
) |
|
| 167 | ! |
THETA <- diag(out$theta) |
| 168 | ! |
PSI <- out$psi |
| 169 | ||
| 170 |
# 3. correlated residuals (if any) are just the difference between |
|
| 171 |
# Sigma and S |
|
| 172 |
# if(length(nondiag.idx) > 0L) {
|
|
| 173 |
# Sigma <- LAMBDA %*% PSI %*% t(LAMBDA) + THETA |
|
| 174 |
# THETA[nondiag.idx] <- (sample.cov - Sigma)[nondiag.idx] |
|
| 175 |
# } |
|
| 176 | ||
| 177 |
# store matrices in lavmodel@GLIST |
|
| 178 | ! |
lavmodel@GLIST$lambda <- LAMBDA |
| 179 | ! |
lavmodel@GLIST$theta <- THETA |
| 180 | ! |
lavmodel@GLIST$psi <- PSI |
| 181 | ||
| 182 |
# extract free parameters only |
|
| 183 | ! |
x <- lav_model_get_parameters(lavmodel) |
| 184 | ||
| 185 |
# apply bounds (if any) |
|
| 186 | ! |
if (!is.null(lavpartable$lower)) {
|
| 187 | ! |
lower.x <- lavpartable$lower[lavpartable$free > 0] |
| 188 | ! |
too.small.idx <- which(x < lower.x) |
| 189 | ! |
if (length(too.small.idx) > 0L) {
|
| 190 | ! |
x[too.small.idx] <- lower.x[too.small.idx] |
| 191 |
} |
|
| 192 |
} |
|
| 193 | ! |
if (!is.null(lavpartable$upper)) {
|
| 194 | ! |
upper.x <- lavpartable$upper[lavpartable$free > 0] |
| 195 | ! |
too.large.idx <- which(x > upper.x) |
| 196 | ! |
if (length(too.large.idx) > 0L) {
|
| 197 | ! |
x[too.large.idx] <- upper.x[too.large.idx] |
| 198 |
} |
|
| 199 |
} |
|
| 200 | ||
| 201 | ! |
x |
| 202 |
} |
| 1 |
# data.frame utilities |
|
| 2 |
# Y.R. 11 April 2013 |
|
| 3 | ||
| 4 |
# - 10 nov 2019: * removed lav_dataframe_check_vartype(), as we can simply use |
|
| 5 |
# sapply(lapply(frame, class), "[", 1L) (unused anyway) |
|
| 6 |
# * removed lav_dataframe_check_ordered() as we can simply use |
|
| 7 |
# any(sapply(frame[, ov.names], inherits, "ordered")) |
|
| 8 | ||
| 9 |
# construct vartable, but allow 'ordered/factor' argument to intervene |
|
| 10 |
# we do NOT change the data.frame |
|
| 11 |
lav_dataframe_vartable <- function(frame = NULL, ov.names = NULL, |
|
| 12 |
ov.names.x = NULL, |
|
| 13 |
ordered = NULL, |
|
| 14 |
factor = NULL, |
|
| 15 |
as.data.frame. = FALSE, |
|
| 16 |
allow.empty.cell = FALSE) {
|
|
| 17 | 35x |
if (missing(ov.names)) {
|
| 18 | ! |
var.names <- names(frame) |
| 19 |
} else {
|
|
| 20 | 35x |
ov.names <- unlist(ov.names, use.names = FALSE) |
| 21 | 35x |
ov.names.x <- unlist(ov.names.x, use.names = FALSE) |
| 22 | 35x |
var.names <- unique(c(ov.names, ov.names.x)) |
| 23 |
} |
|
| 24 | 35x |
nvar <- length(var.names) |
| 25 | 35x |
var.idx <- match(var.names, names(frame)) |
| 26 | ||
| 27 | ||
| 28 | 35x |
nobs <- integer(nvar) |
| 29 | 35x |
type <- character(nvar) |
| 30 | 35x |
user <- integer(nvar) |
| 31 | 35x |
exo <- ifelse(var.names %in% ov.names.x, 1L, 0L) |
| 32 | 35x |
mean <- numeric(nvar) |
| 33 | 35x |
var <- numeric(nvar) |
| 34 | 35x |
nlev <- integer(nvar) |
| 35 | 35x |
lnam <- character(nvar) |
| 36 | 35x |
for (i in seq_len(nvar)) {
|
| 37 | 299x |
x <- frame[[var.idx[i]]] |
| 38 | ||
| 39 | 299x |
type.x <- class(x)[1L] |
| 40 | ||
| 41 |
# correct for matrix with 1 column |
|
| 42 | 299x |
if (inherits(x, "matrix") && (is.null(dim(x)) || |
| 43 | 299x |
(!is.null(dim) && ncol(x) == 1L))) {
|
| 44 | ! |
type.x <- "numeric" |
| 45 |
} |
|
| 46 | ||
| 47 |
# correct for integers |
|
| 48 | 299x |
if (inherits(x, "integer")) {
|
| 49 | 60x |
type.x <- "numeric" |
| 50 |
} |
|
| 51 | ||
| 52 |
# handle the 'labelled' type from the haven package |
|
| 53 |
# - if the variable name is not in 'ordered', we assume |
|
| 54 |
# it is numeric (for now) 11 March 2018 |
|
| 55 | 299x |
if (inherits(x, "labelled") && !(var.names[i] %in% ordered)) {
|
| 56 | ! |
type.x <- "numeric" |
| 57 |
} |
|
| 58 | ||
| 59 |
# handle ordered/factor |
|
| 60 | 299x |
if (!is.null(ordered) && var.names[i] %in% ordered) {
|
| 61 | 8x |
type.x <- "ordered" |
| 62 | 8x |
if (allow.empty.cell) {
|
| 63 | ! |
if (inherits(x, 'factor')) {
|
| 64 | ! |
nlev[i] <- nlevels(x) |
| 65 | ! |
lnam[i] <- paste(levels(x), collapse = "|") |
| 66 |
} else {
|
|
| 67 | ! |
nlev[i] <- max(as.numeric(x), na.rm = TRUE) |
| 68 | ! |
lnam[i] <- paste(1:nlev[i], collapse = "|") |
| 69 |
} |
|
| 70 |
} else {
|
|
| 71 | 8x |
lev <- sort(unique(x)) # we assume integers! |
| 72 | 8x |
nlev[i] <- length(lev) |
| 73 | 8x |
lnam[i] <- paste(lev, collapse = "|") |
| 74 |
} |
|
| 75 | 8x |
user[i] <- 1L |
| 76 | 291x |
} else if (!is.null(factor) && var.names[i] %in% factor) {
|
| 77 | ! |
type.x <- "factor" |
| 78 | ! |
lev <- sort(unique(x)) # we assume integers! |
| 79 | ! |
nlev[i] <- length(lev) |
| 80 | ! |
lnam[i] <- paste(lev, collapse = "|") |
| 81 | ! |
user[i] <- 1L |
| 82 |
} else {
|
|
| 83 | 291x |
nlev[i] <- nlevels(x) |
| 84 | 291x |
lnam[i] <- paste(levels(x), collapse = "|") |
| 85 |
} |
|
| 86 | ||
| 87 | 299x |
type[i] <- type.x |
| 88 | 299x |
nobs[i] <- sum(!is.na(x)) |
| 89 | 299x |
mean[i] <- ifelse(type.x == "numeric", mean(x, na.rm = TRUE), |
| 90 | 299x |
as.numeric(NA) |
| 91 |
) |
|
| 92 | 299x |
var[i] <- ifelse(type.x == "numeric", var(x, na.rm = TRUE), |
| 93 | 299x |
as.numeric(NA) |
| 94 |
) |
|
| 95 |
} |
|
| 96 | ||
| 97 | 35x |
VAR <- list( |
| 98 | 35x |
name = var.names, idx = var.idx, nobs = nobs, type = type, exo = exo, |
| 99 | 35x |
user = user, mean = mean, var = var, nlev = nlev, lnam = lnam |
| 100 |
) |
|
| 101 | ||
| 102 | 35x |
if (as.data.frame.) {
|
| 103 | ! |
VAR <- as.data.frame(VAR, |
| 104 | ! |
stringsAsFactors = FALSE, |
| 105 | ! |
row.names = 1:length(VAR$name) |
| 106 |
) |
|
| 107 | ! |
class(VAR) <- c("lavaan.data.frame", "data.frame")
|
| 108 |
} |
|
| 109 | ||
| 110 | 35x |
VAR |
| 111 |
} |
| 1 |
lav_lavaan_step09_model <- function(slotModel = NULL, # nolint |
|
| 2 |
lavoptions = NULL, |
|
| 3 |
lavpartable = NULL, |
|
| 4 |
lavsamplestats = NULL, |
|
| 5 |
lavdata = NULL) {
|
|
| 6 |
# # # # # # # # # # # |
|
| 7 |
# # 9. lavmodel # # |
|
| 8 |
# # # # # # # # # # # |
|
| 9 | ||
| 10 |
# if slotModel not NULL |
|
| 11 |
# copy to lavmodel |
|
| 12 |
# else |
|
| 13 |
# compute lavmodel via lav_model |
|
| 14 |
# if lavdata@data.type == "none" and categorical mode |
|
| 15 |
# set parameters in lavmodel via lav_model_set_parameters and |
|
| 16 |
# re-adjust start column in lavpartable |
|
| 17 |
# if differences between start and ustart column (in lavpartable) |
|
| 18 |
# if lavmodel$parameterization == "delta" |
|
| 19 |
# if user specified delta values : ** warning ** |
|
| 20 |
# if lavmodel$parameterization == "theta" |
|
| 21 |
# if user specified theta values : ** warning ** |
|
| 22 | ||
| 23 | 140x |
if (!is.null(slotModel)) {
|
| 24 | ! |
lavmodel <- slotModel |
| 25 |
} else {
|
|
| 26 | 140x |
if (lav_verbose()) {
|
| 27 | ! |
cat("lavmodel ...")
|
| 28 |
} |
|
| 29 | 140x |
lavmodel <- lav_model( |
| 30 | 140x |
lavpartable = lavpartable, |
| 31 | 140x |
lavoptions = lavoptions, |
| 32 | 140x |
th.idx = lavsamplestats@th.idx |
| 33 |
) |
|
| 34 |
# no longer needed: x values are in start |
|
| 35 |
# cov.x = lavsamplestats@cov.x, |
|
| 36 |
# mean.x = lavsamplestats@mean.x) |
|
| 37 | ||
| 38 |
# if no data, call lav_model_set_parameters once (for categorical case) |
|
| 39 | 140x |
if (lavdata@data.type == "none" && lavmodel@categorical) {
|
| 40 | ! |
lavmodel <- lav_model_set_parameters( |
| 41 | ! |
lavmodel = lavmodel, |
| 42 | ! |
x = lav_model_get_parameters(lavmodel) |
| 43 |
) |
|
| 44 |
# re-adjust parameter table |
|
| 45 | ! |
lavpartable$start <- lav_model_get_parameters(lavmodel, type = "user") |
| 46 | ||
| 47 |
# check/warn if theta/delta values make sense |
|
| 48 | ! |
if (!all(lavpartable$start == lavpartable$ustart)) {
|
| 49 | ! |
if (lavmodel@parameterization == "delta") {
|
| 50 |
# did the user specify theta values? |
|
| 51 | ! |
user.var.idx <- which(lavpartable$op == "~~" & |
| 52 | ! |
lavpartable$lhs == lavpartable$rhs & |
| 53 | ! |
lavpartable$lhs %in% unlist(attr(lavpartable, "vnames")$ov.ord) & |
| 54 | ! |
lavpartable$user == 1L) |
| 55 | ! |
if (length(user.var.idx)) {
|
| 56 | ! |
lav_msg_warn( |
| 57 | ! |
gettextf("variance (theta) values for categorical variables
|
| 58 | ! |
are ignored if parameterization = %s!", |
| 59 | ! |
"'delta'") |
| 60 |
) |
|
| 61 |
} |
|
| 62 | ! |
} else if (lavmodel@parameterization == "theta") {
|
| 63 |
# did the user specify theta values? |
|
| 64 | ! |
user.delta.idx <- which(lavpartable$op == "~*~" & |
| 65 | ! |
lavpartable$lhs == lavpartable$rhs & |
| 66 | ! |
lavpartable$lhs %in% unlist(attr(lavpartable, "vnames")$ov.ord) & |
| 67 | ! |
lavpartable$user == 1L) |
| 68 | ! |
if (length(user.delta.idx)) {
|
| 69 | ! |
lav_msg_warn( |
| 70 | ! |
gettextf("scaling (~*~) values for categorical variables
|
| 71 | ! |
are ignored if parameterization = %s!", |
| 72 | ! |
"'theta'") |
| 73 |
) |
|
| 74 |
} |
|
| 75 |
} |
|
| 76 |
} |
|
| 77 | ||
| 78 |
# same for composites: call lav_model_set_parameters once to set |
|
| 79 |
# total/residual variances of composites in PSI |
|
| 80 | 140x |
} else if (lavmodel@composites) {
|
| 81 | ! |
lavmodel <- lav_model_set_parameters( |
| 82 | ! |
lavmodel = lavmodel, |
| 83 | ! |
x = lav_model_get_parameters(lavmodel) |
| 84 |
) |
|
| 85 |
# re-adjust parameter table |
|
| 86 | ! |
lavpartable$start <- lav_model_get_parameters(lavmodel, type = "user") |
| 87 |
} |
|
| 88 | 140x |
if (lav_verbose()) {
|
| 89 | ! |
cat(" done.\n")
|
| 90 |
} |
|
| 91 |
} |
|
| 92 | ||
| 93 |
# if parameterization = "delta" and categorical/correlation: check if |
|
| 94 |
# we have an observed mediator (new in 0.6-19) |
|
| 95 |
# but fixed (for recursive models) in 0.6-20 |
|
| 96 |
# check.flag <- FALSE |
|
| 97 |
# if (!is.null(lavoptions$check.delta.cat.mediator) && # lavaan >= 0.6.19 |
|
| 98 |
# lavoptions$check.delta.cat.mediator) {
|
|
| 99 |
# check.flag <- TRUE |
|
| 100 |
# } |
|
| 101 |
# if (check.flag && |
|
| 102 |
# (lavmodel@categorical || lavmodel@correlation) && |
|
| 103 |
# lavmodel@representation == "LISREL" && |
|
| 104 |
# lavmodel@parameterization == "delta") {
|
|
| 105 |
# # get idx BETA matrices |
|
| 106 |
# beta.idx <- which(names(lavmodel@GLIST) == "beta") |
|
| 107 |
# # for every block |
|
| 108 |
# for (i in seq_len(length(beta.idx))) {
|
|
| 109 |
# this.beta <- abs(lavmodel@GLIST[[beta.idx[i]]]) |
|
| 110 |
# this.beta[lavmodel@m.free.idx[[beta.idx[i]]]] <- 1.0 |
|
| 111 |
# # exogenous variables: have zero rows |
|
| 112 |
# # endogenous variables: have non-zero rows |
|
| 113 |
# # endogenous-only variables: have non-zero rows and zero columns |
|
| 114 |
# # mediators: have non-zero rows and non-zero columns |
|
| 115 |
# m.idx <- which(apply(this.beta, 1, sum) != 0 & |
|
| 116 |
# apply(this.beta, 2, sum) != 0) |
|
| 117 |
# if (length(m.idx) > 0L) {
|
|
| 118 |
# # we have (at least) one mediator |
|
| 119 |
# # is one of them an observed variable? -> warn |
|
| 120 |
# m.names <- lavmodel@dimNames[[beta.idx[i]]][[1]][m.idx] |
|
| 121 |
# ov.names <- unlist(lavdata@ov.names) |
|
| 122 |
# ov.ordered <- unlist(lavdata@ordered) |
|
| 123 |
# # correlation model |
|
| 124 |
# if (lavmodel@correlation && any(m.names %in% ov.names)) {
|
|
| 125 |
# bad.names <- m.names[m.names %in% ov.names] |
|
| 126 |
# if (length(beta.idx) == 1L) {
|
|
| 127 |
# lav_msg_warn(gettextf("model contains at least one observed mediator: [%s]; consider switching to parameterization = \"theta\"",
|
|
| 128 |
# paste(bad.names, collapse = " "))) |
|
| 129 |
# } else {
|
|
| 130 |
# lav_msg_warn(gettextf("model contains at least one observed mediator in block %i: [%s]; consider switching to parameterization = \"theta\"", i,
|
|
| 131 |
# paste(bad.names, collapse = " "))) |
|
| 132 |
# } |
|
| 133 |
# # categorical mode |
|
| 134 |
# } else if (lavmodel@categorical && any(m.names %in% ov.ordered)) {
|
|
| 135 |
# bad.names <- m.names[m.names %in% ov.ordered] |
|
| 136 |
# if (length(beta.idx) == 1L) {
|
|
| 137 |
# lav_msg_warn(gettextf("model contains at least one observed categorical mediator: [%s]; consider switching to parameterization = \"theta\"",
|
|
| 138 |
# paste(bad.names, collapse = " "))) |
|
| 139 |
# } else {
|
|
| 140 |
# lav_msg_warn(gettextf("model contains at least one observed categorical mediator in block %i: [%s]; consider switching to parameterization = \"theta\"", i,
|
|
| 141 |
# paste(bad.names, collapse = " "))) |
|
| 142 |
# } |
|
| 143 |
# } |
|
| 144 |
# } # mediators |
|
| 145 |
# } # block |
|
| 146 |
# } # delta parameterization |
|
| 147 | ||
| 148 | 140x |
list( |
| 149 | 140x |
lavpartable = lavpartable, |
| 150 | 140x |
lavmodel = lavmodel |
| 151 |
) |
|
| 152 |
} |
|
| 153 |
| 1 |
lav_samplestats_icov <- function(COV = NULL, ridge = 0.0, x.idx = integer(0L), |
|
| 2 |
ngroups = 1L, g = 1L) {
|
|
| 3 | ||
| 4 | 67x |
cS <- tryCatch(chol(COV), error = function(e) NULL) |
| 5 | ||
| 6 |
# what if this fails... |
|
| 7 |
# ridge exogenous part only (if any); this may help for GLS (but not ML) |
|
| 8 | 67x |
if (is.null(cS)) {
|
| 9 | ! |
if (length(x.idx) > 0L && ridge > 0) {
|
| 10 |
# maybe, we can fix it by gently ridging the exo variances |
|
| 11 | ! |
ridge.eps <- ridge |
| 12 | ! |
diag(COV)[x.idx] <- diag(COV)[x.idx] + ridge.eps |
| 13 | ||
| 14 |
# try again |
|
| 15 | ! |
cS <- tryCatch(chol(COV), error = function(e) NULL) |
| 16 | ||
| 17 | ! |
if (is.null(cS)) {
|
| 18 |
# fatal stop after all |
|
| 19 | ! |
lav_msg_stop(gettext( |
| 20 | ! |
"sample covariance matrix is not positive-definite")) |
| 21 |
} else {
|
|
| 22 | ! |
cov <- chol2inv(cS) |
| 23 | ! |
d <- diag(cS) |
| 24 | ! |
cov.log.det <- 2 * sum(log(d)) |
| 25 |
# give a warning |
|
| 26 | ! |
if (ngroups > 1) {
|
| 27 | ! |
lav_msg_warn(gettextf( |
| 28 | ! |
"sample covariance matrix in group: %s is not |
| 29 | ! |
positive-definite", g)) |
| 30 |
} else {
|
|
| 31 | ! |
lav_msg_warn(gettext( |
| 32 | ! |
"sample covariance matrix is not positive-definite")) |
| 33 |
} |
|
| 34 |
} |
|
| 35 |
} else {
|
|
| 36 |
# fatal stop |
|
| 37 | ! |
lav_msg_stop(gettext("sample covariance matrix is not positive-definite"))
|
| 38 |
} |
|
| 39 |
} else {
|
|
| 40 | 67x |
icov <- chol2inv(cS) |
| 41 | 67x |
d <- diag(cS) |
| 42 | 67x |
cov.log.det <- 2 * sum(log(d)) |
| 43 |
} |
|
| 44 | ||
| 45 | 67x |
list(icov = icov, cov.log.det = cov.log.det) |
| 46 |
} |
| 1 |
lav_samplestats_step2 <- function(UNI = NULL, |
|
| 2 |
wt = NULL, |
|
| 3 |
ov.names = NULL, # error message only |
|
| 4 |
# polychoric and empty cells |
|
| 5 |
zero.add = c(0.5, 0.0), |
|
| 6 |
zero.keep.margins = TRUE, |
|
| 7 |
zero.cell.warn = FALSE, |
|
| 8 |
# keep track of tables with zero cells? |
|
| 9 |
zero.cell.tables = TRUE) {
|
|
| 10 | 2x |
nvar <- length(UNI) |
| 11 | 2x |
COR <- diag(nvar) |
| 12 | ||
| 13 | 2x |
if (zero.cell.tables) {
|
| 14 | 2x |
zero.var1 <- character(0L) |
| 15 | 2x |
zero.var2 <- character(0L) |
| 16 |
} |
|
| 17 | ||
| 18 |
# one-by-one (for now) |
|
| 19 | 2x |
for (j in seq_len(nvar - 1L)) {
|
| 20 | 26x |
for (i in (j + 1L):nvar) {
|
| 21 | 182x |
if (is.null(UNI[[i]]$th.idx) && |
| 22 | 182x |
is.null(UNI[[j]]$th.idx)) {
|
| 23 | 90x |
rho <- lav_bvreg_cor_twostep_fit( |
| 24 | 90x |
fit.y1 = UNI[[i]], # linear |
| 25 | 90x |
fit.y2 = UNI[[j]], # linear |
| 26 | 90x |
wt = wt, |
| 27 | 90x |
Y1.name = ov.names[i], |
| 28 | 90x |
Y2.name = ov.names[j] |
| 29 |
) |
|
| 30 | 90x |
COR[i, j] <- COR[j, i] <- rho |
| 31 | 92x |
} else if (is.null(UNI[[i]]$th.idx) && |
| 32 | 92x |
!is.null(UNI[[j]]$th.idx)) {
|
| 33 |
# polyserial |
|
| 34 | 32x |
rho <- lav_bvmix_cor_twostep_fit( |
| 35 | 32x |
fit.y1 = UNI[[i]], # linear |
| 36 | 32x |
fit.y2 = UNI[[j]], # ordinal |
| 37 | 32x |
wt = wt, |
| 38 | 32x |
Y1.name = ov.names[i], |
| 39 | 32x |
Y2.name = ov.names[j] |
| 40 |
) |
|
| 41 | 32x |
COR[i, j] <- COR[j, i] <- rho |
| 42 | 60x |
} else if (is.null(UNI[[j]]$th.idx) && |
| 43 | 60x |
!is.null(UNI[[i]]$th.idx)) {
|
| 44 |
# polyserial |
|
| 45 | 48x |
rho <- lav_bvmix_cor_twostep_fit( |
| 46 | 48x |
fit.y1 = UNI[[j]], # linear |
| 47 | 48x |
fit.y2 = UNI[[i]], # ordinal |
| 48 | 48x |
wt = wt, |
| 49 | 48x |
Y1.name = ov.names[j], |
| 50 | 48x |
Y2.name = ov.names[i] |
| 51 |
) |
|
| 52 | 48x |
COR[i, j] <- COR[j, i] <- rho |
| 53 | 12x |
} else if (!is.null(UNI[[i]]$th.idx) && |
| 54 | 12x |
!is.null(UNI[[j]]$th.idx)) {
|
| 55 |
# polychoric correlation |
|
| 56 | 12x |
rho <- lav_bvord_cor_twostep_fit( |
| 57 | 12x |
fit.y1 = UNI[[j]], # ordinal |
| 58 | 12x |
fit.y2 = UNI[[i]], # ordinal |
| 59 | 12x |
wt = wt, |
| 60 | 12x |
zero.add = zero.add, |
| 61 | 12x |
zero.keep.margins = zero.keep.margins, |
| 62 | 12x |
zero.cell.warn = zero.cell.warn, |
| 63 | 12x |
zero.cell.flag = zero.cell.tables, |
| 64 | 12x |
Y1.name = ov.names[i], |
| 65 | 12x |
Y2.name = ov.names[j] |
| 66 |
) |
|
| 67 | 12x |
if (zero.cell.tables) {
|
| 68 | 12x |
if (attr(rho, "zero.cell.flag")) {
|
| 69 | ! |
zero.var1 <- c(zero.var1, ov.names[j]) |
| 70 | ! |
zero.var2 <- c(zero.var2, ov.names[i]) |
| 71 |
} |
|
| 72 | 12x |
attr(rho, "zero.cell.flag") <- NULL |
| 73 |
} |
|
| 74 | 12x |
COR[i, j] <- COR[j, i] <- rho |
| 75 |
} |
|
| 76 |
# check for near 1.0 correlations |
|
| 77 | 182x |
if (abs(COR[i, j]) > 0.99) {
|
| 78 | ! |
lav_msg_warn(gettextf( |
| 79 | ! |
"correlation between variables %1$s and %2$s is (nearly) 1.0", |
| 80 | ! |
ov.names[i], ov.names[j])) |
| 81 |
} |
|
| 82 |
} |
|
| 83 |
} |
|
| 84 | ||
| 85 |
# keep track of tables with zero cells |
|
| 86 | 2x |
if (zero.cell.tables) {
|
| 87 | 2x |
zero.cell.tables <- cbind(zero.var1, zero.var2) |
| 88 | 2x |
attr(COR, "zero.cell.tables") <- zero.cell.tables |
| 89 |
} |
|
| 90 | ||
| 91 | 2x |
COR |
| 92 |
} |
| 1 |
# check if a fitted model is admissible |
|
| 2 |
lav_object_post_check <- function(object) {
|
|
| 3 | 45x |
stopifnot(inherits(object, "lavaan")) |
| 4 | 45x |
lavpartable <- object@ParTable |
| 5 | 45x |
lavmodel <- object@Model |
| 6 | 45x |
lavdata <- object@Data |
| 7 | ||
| 8 | 45x |
var.ov.ok <- var.lv.ok <- result.ok <- TRUE |
| 9 | ||
| 10 |
# 1a. check for negative variances ov |
|
| 11 | 45x |
var.idx <- which(lavpartable$op == "~~" & |
| 12 | 45x |
lavpartable$lhs %in% lav_object_vnames(object, "ov") & |
| 13 | 45x |
lavpartable$lhs == lavpartable$rhs) |
| 14 | 45x |
if (length(var.idx) > 0L && any(lavpartable$est[var.idx] < 0.0)) {
|
| 15 | ! |
result.ok <- var.ov.ok <- FALSE |
| 16 | ! |
lav_msg_warn(gettext("some estimated ov variances are negative"))
|
| 17 |
} |
|
| 18 | ||
| 19 |
# 1b. check for negative variances lv |
|
| 20 | 45x |
var.idx <- which(lavpartable$op == "~~" & |
| 21 | 45x |
lavpartable$lhs %in% lav_object_vnames(object, "lv") & |
| 22 | 45x |
lavpartable$lhs == lavpartable$rhs) |
| 23 | 45x |
if (length(var.idx) > 0L && any(lavpartable$est[var.idx] < 0.0)) {
|
| 24 | 2x |
result.ok <- var.lv.ok <- FALSE |
| 25 | 2x |
lav_msg_warn(gettext("some estimated lv variances are negative"))
|
| 26 |
} |
|
| 27 | ||
| 28 |
# 2. is cov.lv (PSI) positive definite? (only if we did not already warn |
|
| 29 |
# for negative variances) |
|
| 30 | 45x |
if (var.lv.ok && length(lav_object_vnames(lavpartable, type = "lv.regular")) > 0L) {
|
| 31 | 27x |
ETA <- lavTech(object, "cov.lv") |
| 32 | 27x |
for (g in 1:lavdata@ngroups) {
|
| 33 | ! |
if (nrow(ETA[[g]]) == 0L) next |
| 34 | 31x |
txt.group <- if (lavdata@ngroups > 1L) gettextf("in group %s", g) else ""
|
| 35 | 31x |
eigvals <- eigen(ETA[[g]], symmetric = TRUE, only.values = TRUE)$values |
| 36 | 31x |
if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
|
| 37 | ! |
lav_msg_warn(gettextf( |
| 38 | ! |
"covariance matrix of latent variables is not positive definite %s; |
| 39 | ! |
use lavInspect(fit, \"cov.lv\") to investigate.", txt.group |
| 40 |
)) |
|
| 41 | ! |
result.ok <- FALSE |
| 42 |
} |
|
| 43 |
} |
|
| 44 |
} |
|
| 45 | ||
| 46 |
# 3. is THETA positive definite (but only for numeric variables) |
|
| 47 |
# and if we not already warned for negative ov variances |
|
| 48 | 45x |
if (var.ov.ok) {
|
| 49 | 45x |
THETA <- lavTech(object, "theta") |
| 50 | 45x |
for (g in 1:lavdata@ngroups) {
|
| 51 | 49x |
num.idx <- lavmodel@num.idx[[g]] |
| 52 | 49x |
if (length(num.idx) > 0L) {
|
| 53 | 49x |
txt.group <- if (lavdata@ngroups > 1L) gettextf("in group %s", g) else ""
|
| 54 | 49x |
eigvals <- eigen(THETA[[g]][num.idx, num.idx, drop = FALSE], |
| 55 | 49x |
symmetric = TRUE, |
| 56 | 49x |
only.values = TRUE |
| 57 | 49x |
)$values |
| 58 | 49x |
if (any(eigvals < -1 * .Machine$double.eps^(3 / 4))) {
|
| 59 | ! |
lav_msg_warn(gettextf( |
| 60 | ! |
"the covariance matrix of the residuals of the observed variables |
| 61 | ! |
(theta) is not positive definite %s; use lavInspect(fit, \"theta\") |
| 62 | ! |
to investigate.", txt.group)) |
| 63 | ! |
result.ok <- FALSE |
| 64 |
} |
|
| 65 |
} |
|
| 66 |
} |
|
| 67 |
} |
|
| 68 | ||
| 69 | 45x |
result.ok |
| 70 |
} |
| 1 |
# functions related to GFI and other 'absolute' fit indices |
|
| 2 | ||
| 3 |
# lower-level functions: |
|
| 4 |
# - lav_fit_gfi |
|
| 5 |
# - lav_fit_agfi |
|
| 6 |
# - lav_fit_pgfi |
|
| 7 | ||
| 8 |
# higher-level functions: |
|
| 9 |
# - lav_fit_gfi_lavobject |
|
| 10 | ||
| 11 |
# Y.R. 21 July 2022 |
|
| 12 | ||
| 13 |
# original formulas were given in Joreskog and Sorbom (1984) user's guide |
|
| 14 |
# for LISREL VI (one for ML, and another for ULS) |
|
| 15 | ||
| 16 |
# here we use the more 'general' formulas |
|
| 17 |
# (generalized to allow for meanstructures etc) |
|
| 18 | ||
| 19 |
# References: |
|
| 20 | ||
| 21 |
# Mulaik, S. A., James, L. R., Van Alstine, J., Bennett, N., Lind, S., & |
|
| 22 |
# Stilwell, C. D. (1989). Evaluation of goodness-of-fit indices for structural |
|
| 23 |
# equation models. Psychological bulletin, 105(3), 430. |
|
| 24 | ||
| 25 |
# Tanaka, J. S., & Huba, G. J. (1985). A fit index for covariance structure |
|
| 26 |
# models under arbitrary GLS estimation. British Journal of Mathematical and |
|
| 27 |
# Statistical Psychology, 38,197-201. |
|
| 28 | ||
| 29 |
lav_fit_gfi <- function(WLS.obs = NULL, WLS.est = NULL, WLS.V = NULL, |
|
| 30 |
NOBS = NULL) {
|
|
| 31 |
# number of groups |
|
| 32 | 19x |
G <- length(WLS.obs) |
| 33 | ||
| 34 |
# compute gfi per group |
|
| 35 | 19x |
gfi.group <- numeric(G) |
| 36 | 19x |
for (g in 1:G) {
|
| 37 | 20x |
wls.obs <- WLS.obs[[g]] |
| 38 | 20x |
wls.est <- WLS.est[[g]] |
| 39 | 20x |
wls.v <- WLS.V[[g]] |
| 40 | ||
| 41 | 20x |
if (is.null(wls.v)) {
|
| 42 | ! |
gfi.group[g] <- as.numeric(NA) |
| 43 |
} else {
|
|
| 44 | 20x |
wls.diff <- wls.obs - wls.est |
| 45 | 20x |
if (is.matrix(wls.v)) {
|
| 46 |
# full weight matrix |
|
| 47 | 20x |
t1 <- crossprod(wls.diff, wls.v) %*% wls.diff |
| 48 | 20x |
t2 <- crossprod(wls.obs, wls.v) %*% wls.obs |
| 49 |
} else {
|
|
| 50 |
# diagonal weight matrix |
|
| 51 | ! |
t1 <- as.numeric(crossprod(wls.diff^2, wls.v)) |
| 52 | ! |
t2 <- as.numeric(crossprod(wls.obs^2, wls.v)) |
| 53 |
} |
|
| 54 | 20x |
gfi.group[g] <- 1 - t1 / t2 |
| 55 |
} |
|
| 56 |
} |
|
| 57 | ||
| 58 | 19x |
if (G > 1) {
|
| 59 |
## CHECKME: get the scaling right |
|
| 60 | 1x |
NOBS <- unlist(NOBS) |
| 61 | 1x |
GFI <- as.numeric((NOBS %*% gfi.group) / sum(NOBS)) |
| 62 |
} else {
|
|
| 63 | 18x |
GFI <- gfi.group[1L] |
| 64 |
} |
|
| 65 | ||
| 66 | 19x |
GFI |
| 67 |
} |
|
| 68 | ||
| 69 |
# 'adjusted' GFI (adjusted for degrees of freedom) |
|
| 70 |
lav_fit_agfi <- function(GFI = NULL, nel = NULL, df = NULL) {
|
|
| 71 | 19x |
if (!is.finite(GFI) || !is.finite(nel) || !is.finite(df)) {
|
| 72 | ! |
AGFI <- as.numeric(NA) |
| 73 | 19x |
} else if (df > 0) {
|
| 74 | 12x |
AGFI <- 1 - (nel / df) * (1 - GFI) |
| 75 |
} else {
|
|
| 76 | 7x |
AGFI <- 1 |
| 77 |
} |
|
| 78 | ||
| 79 | 19x |
AGFI |
| 80 |
} |
|
| 81 | ||
| 82 |
# PGFI: parsimony goodness-of-fit index |
|
| 83 | ||
| 84 |
# Mulaik, S. A., James, L. R., Van Alstine, J., Bennett, N., Lind, S., & |
|
| 85 |
# Stilwell, C. D. (1989). Evaluation of goodness-of-fit indices for structural |
|
| 86 |
# equation models. Psychological bulletin, 105(3), 430. |
|
| 87 | ||
| 88 |
# LISREL formula (Simplis book 2002, p. 126) |
|
| 89 |
lav_fit_pgfi <- function(GFI = NULL, nel = NULL, df = NULL) {
|
|
| 90 | 19x |
if (!is.finite(GFI) || !is.finite(nel) || !is.finite(df)) {
|
| 91 | ! |
PGFI <- as.numeric(NA) |
| 92 | 19x |
} else if (nel == 0) {
|
| 93 | ! |
PGFI <- as.numeric(NA) |
| 94 |
} else {
|
|
| 95 | 19x |
PGFI <- (df / nel) * GFI |
| 96 |
} |
|
| 97 | ||
| 98 | 19x |
PGFI |
| 99 |
} |
|
| 100 | ||
| 101 | ||
| 102 |
lav_fit_gfi_lavobject <- function(lavobject = NULL, fit.measures = "gfi") {
|
|
| 103 |
# check lavobject |
|
| 104 | 19x |
stopifnot(inherits(lavobject, "lavaan")) |
| 105 | ||
| 106 |
# possible fit measures |
|
| 107 | 19x |
fit.gfi <- c("gfi", "agfi", "pgfi")
|
| 108 | ||
| 109 |
# which one do we need? |
|
| 110 | 19x |
if (missing(fit.measures)) {
|
| 111 |
# default set |
|
| 112 | ! |
fit.measures <- fit.gfi |
| 113 |
} else {
|
|
| 114 |
# remove any not-GFI related index from fit.measures |
|
| 115 | 19x |
rm.idx <- which(!fit.measures %in% fit.gfi) |
| 116 | 19x |
if (length(rm.idx) > 0L) {
|
| 117 | 19x |
fit.measures <- fit.measures[-rm.idx] |
| 118 |
} |
|
| 119 | 19x |
if (length(fit.measures) == 0L) {
|
| 120 | ! |
return(list()) |
| 121 |
} |
|
| 122 |
} |
|
| 123 | ||
| 124 |
# extract ingredients |
|
| 125 | 19x |
WLS.obs <- lav_object_inspect_wls_obs(lavobject) |
| 126 | 19x |
WLS.est <- lav_object_inspect_wls_est(lavobject) |
| 127 | 19x |
WLS.V <- lav_object_inspect_wls_v(lavobject) |
| 128 | 19x |
NOBS <- lavobject@SampleStats@nobs |
| 129 | ||
| 130 |
# compute GFI |
|
| 131 | 19x |
GFI <- lav_fit_gfi( |
| 132 | 19x |
WLS.obs = WLS.obs, WLS.est = WLS.est, |
| 133 | 19x |
WLS.V = WLS.V, NOBS = NOBS |
| 134 |
) |
|
| 135 | ||
| 136 |
# total number of modeled sample stats |
|
| 137 | 19x |
nel <- length(unlist(WLS.obs)) |
| 138 | ||
| 139 |
# degrees of freedom |
|
| 140 | 19x |
df <- lavobject@test[[1]]$df |
| 141 | ||
| 142 |
# container |
|
| 143 | 19x |
indices <- list() |
| 144 | ||
| 145 | 19x |
indices["gfi"] <- GFI |
| 146 | 19x |
indices["agfi"] <- lav_fit_agfi(GFI = GFI, nel = nel, df = df) |
| 147 | 19x |
indices["pgfi"] <- lav_fit_pgfi(GFI = GFI, nel = nel, df = df) |
| 148 | ||
| 149 |
# return only those that were requested |
|
| 150 | 19x |
indices[fit.measures] |
| 151 |
} |
| 1 |
# 'robust' mean and (co)variance matrix using Huber weights |
|
| 2 |
# |
|
| 3 |
# see Yuan & Hayashi (2010). Fitting Data to Model: SEM Diagnosis using two |
|
| 4 |
# scatter plots. Psychological Methods, 15(4), 335-351 |
|
| 5 |
# |
|
| 6 |
# this function is based on the 'robmusig' function from K.H. Yuan's website: |
|
| 7 |
# https://www.nd.edu/~kyuan/SEMdiagnosis |
|
| 8 |
# see file CFA.r lines 46--96 |
|
| 9 |
# |
|
| 10 |
lav_cov_huber <- function(Y = NULL, prob = 0.95, max.it = 200L, tol = 1e-07) {
|
|
| 11 | ! |
Y <- as.matrix(Y) |
| 12 | ! |
NAMES <- colnames(Y) |
| 13 | ! |
Y <- unname(Y) |
| 14 | ! |
N <- nrow(Y) |
| 15 | ! |
P <- ncol(Y) |
| 16 | ||
| 17 |
# tuning parameters for Huber's weight |
|
| 18 | ! |
chip <- qchisq(prob, P) |
| 19 | ! |
ck <- sqrt(chip) |
| 20 | ! |
cbeta <- (P * pchisq(chip, P + 2L) + chip * (1 - prob)) / P |
| 21 | ||
| 22 |
# initial values |
|
| 23 | ! |
this.mu <- colMeans(Y, na.rm = TRUE) |
| 24 | ! |
this.sigma <- cov(Y, use = "pairwise.complete.obs") |
| 25 | ||
| 26 | ! |
for (i in seq_len(max.it)) {
|
| 27 |
# store old |
|
| 28 | ! |
old.mu <- this.mu |
| 29 | ! |
old.sigma <- this.sigma |
| 30 | ||
| 31 |
# squared Mahalanobis distance |
|
| 32 | ! |
inv.sigma <- solve(this.sigma) |
| 33 | ! |
Y.c <- t(t(Y) - this.mu) |
| 34 | ! |
mdist2 <- rowSums((Y.c %*% inv.sigma) * Y.c) |
| 35 | ! |
mdist <- sqrt(mdist2) |
| 36 | ||
| 37 |
# Huber weights |
|
| 38 | ! |
wt <- ifelse(mdist <= ck, 1, ck / mdist) |
| 39 | ||
| 40 |
# weighted mean |
|
| 41 | ! |
this.mu <- apply(Y, 2L, weighted.mean, w = wt, na.rm = TRUE) |
| 42 | ||
| 43 |
# weighted cov |
|
| 44 | ! |
Y.c <- t(t(Y) - this.mu) |
| 45 | ! |
this.sigma <- crossprod(Y.c * wt) / (N * cbeta) |
| 46 |
# question: why N, and not sum(wt)? |
|
| 47 | ||
| 48 |
# check progress |
|
| 49 | ! |
diff.mu <- abs(this.mu - old.mu) |
| 50 | ! |
diff.sigma <- abs(this.sigma - old.sigma) |
| 51 | ! |
crit <- max(c(max(diff.mu), max(diff.sigma))) |
| 52 | ! |
if (crit < tol) {
|
| 53 | ! |
break |
| 54 |
} |
|
| 55 | ! |
if (i == max.it) {
|
| 56 | ! |
lav_msg_warn(gettext( |
| 57 | ! |
"maximum number of iterations has been reached, without convergence.")) |
| 58 |
} |
|
| 59 |
} |
|
| 60 | ||
| 61 | ! |
names(this.mu) <- NAMES |
| 62 | ! |
colnames(this.sigma) <- rownames(this.sigma) <- NAMES |
| 63 | ||
| 64 | ! |
res <- list(Mu = this.mu, Sigma = this.sigma, niter = i, wt = wt) |
| 65 | ||
| 66 | ! |
res |
| 67 |
} |
| 1 |
# small functions to do something useful with the common |
|
| 2 |
# plot commands |
|
| 3 | ||
| 4 |
# suggested by JEB |
|
| 5 |
lav_lavaan_pairs <- function(x, group = 1L, ...) {
|
|
| 6 | ! |
X <- x@Data@X[[group]] |
| 7 | ! |
colnames(X) <- x@Data@ov.names[[group]] |
| 8 | ! |
pairs(X, ...) |
| 9 |
} |
| 1 |
# YR 18 Dec 2015 |
|
| 2 |
# - functions to (directly) compute the inverse of 'Gamma' (the asymptotic |
|
| 3 |
# variance matrix of the sample statistics) |
|
| 4 |
# - often used as 'WLS.V' (the weight matrix in WLS estimation) |
|
| 5 |
# and when computing the expected information matrix |
|
| 6 | ||
| 7 |
# NOTE: |
|
| 8 |
# - three types: |
|
| 9 |
# 1) plain (conditional.x = FALSE, fixed.x = FALSE) |
|
| 10 |
# 2) fixed.x (conditional.x = FALSE, fixed.x = TRUE) |
|
| 11 |
# 3) conditional.x (conditional.x = TRUE) |
|
| 12 |
# - if conditional.x = TRUE, we ignore fixed.x (can be TRUE or FALSE) |
|
| 13 | ||
| 14 |
# NORMAL-THEORY |
|
| 15 |
lav_samplestats_Gamma_inverse_NT <- function(Y = NULL, |
|
| 16 |
COV = NULL, |
|
| 17 |
ICOV = NULL, |
|
| 18 |
MEAN = NULL, |
|
| 19 |
rescale = TRUE, |
|
| 20 |
x.idx = integer(0L), |
|
| 21 |
fixed.x = FALSE, |
|
| 22 |
conditional.x = FALSE, |
|
| 23 |
meanstructure = FALSE, |
|
| 24 |
slopestructure = FALSE) {
|
|
| 25 |
# check arguments |
|
| 26 | 6x |
if (length(x.idx) == 0L) {
|
| 27 | 6x |
conditional.x <- FALSE |
| 28 | 6x |
fixed.x <- FALSE |
| 29 |
} |
|
| 30 | ||
| 31 | 6x |
if (is.null(ICOV)) {
|
| 32 | ! |
if (is.null(COV)) {
|
| 33 | ! |
stopifnot(!is.null(Y)) |
| 34 | ||
| 35 |
# coerce to matrix |
|
| 36 | ! |
Y <- unname(as.matrix(Y)) |
| 37 | ! |
N <- nrow(Y) |
| 38 | ! |
COV <- cov(Y) |
| 39 | ! |
if (rescale) {
|
| 40 | ! |
COV <- COV * (N - 1) / N # ML version |
| 41 |
} |
|
| 42 |
} |
|
| 43 | ||
| 44 | ! |
ICOV <- solve(COV) |
| 45 |
} |
|
| 46 | ||
| 47 |
# if conditional.x, we may also need COV and MEAN |
|
| 48 | 6x |
if (conditional.x && length(x.idx) > 0L && |
| 49 | 6x |
(meanstructure || slopestructure)) {
|
| 50 | ! |
if (is.null(COV)) {
|
| 51 | ! |
stopifnot(!is.null(Y)) |
| 52 | ||
| 53 |
# coerce to matrix |
|
| 54 | ! |
Y <- unname(as.matrix(Y)) |
| 55 | ! |
N <- nrow(Y) |
| 56 | ! |
COV <- cov(Y) |
| 57 | ||
| 58 | ! |
if (rescale) {
|
| 59 | ! |
COV <- COV * (N - 1) / N # ML version |
| 60 |
} |
|
| 61 |
} |
|
| 62 | ||
| 63 | ! |
if (is.null(MEAN)) {
|
| 64 | ! |
stopifnot(!is.null(Y)) |
| 65 | ! |
MEAN <- unname(colMeans(Y)) |
| 66 |
} |
|
| 67 |
} |
|
| 68 | ||
| 69 |
# rename |
|
| 70 | 6x |
S.inv <- ICOV |
| 71 | 6x |
S <- COV |
| 72 | 6x |
M <- MEAN |
| 73 | ||
| 74 |
# unconditional |
|
| 75 | 6x |
if (!conditional.x) {
|
| 76 |
# unconditional - stochastic x |
|
| 77 | 6x |
if (!fixed.x) {
|
| 78 |
# if (lav_use_lavaanC()) {
|
|
| 79 |
# Gamma.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5) |
|
| 80 |
# } else {
|
|
| 81 | 6x |
Gamma.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv) |
| 82 |
# } |
|
| 83 | 6x |
if (meanstructure) {
|
| 84 | 2x |
Gamma.inv <- lav_matrix_bdiag(S.inv, Gamma.inv) |
| 85 |
} |
|
| 86 | ||
| 87 |
# unconditional - fixed x |
|
| 88 |
} else {
|
|
| 89 |
# handle fixed.x = TRUE |
|
| 90 |
# if (lav_use_lavaanC()) {
|
|
| 91 |
# Gamma.inv <- lavaanC::m_kronecker_dup_pre_post(S.inv, multiplicator = 0.5) |
|
| 92 |
# } else {
|
|
| 93 | ! |
Gamma.inv <- 0.5 * lav_matrix_duplication_pre_post(S.inv %x% S.inv) |
| 94 |
# } |
|
| 95 | ||
| 96 |
# zero rows/cols corresponding with x/x combinations |
|
| 97 | ! |
nvar <- NROW(ICOV) |
| 98 | ! |
pstar <- nvar * (nvar + 1) / 2 |
| 99 | ! |
M <- matrix(0, nvar, nvar) |
| 100 | ! |
M[lav_matrix_vech_idx(nvar)] <- seq_len(pstar) |
| 101 | ! |
zero.idx <- lav_matrix_vech(M[x.idx, x.idx, drop = FALSE]) |
| 102 | ! |
Gamma.inv[zero.idx, ] <- 0 |
| 103 | ! |
Gamma.inv[, zero.idx] <- 0 |
| 104 | ||
| 105 | ! |
if (meanstructure) {
|
| 106 | ! |
S.inv.nox <- S.inv |
| 107 | ! |
S.inv.nox[x.idx, ] <- 0 |
| 108 | ! |
S.inv.nox[, x.idx] <- 0 |
| 109 | ! |
Gamma.inv <- lav_matrix_bdiag(S.inv.nox, Gamma.inv) |
| 110 |
} |
|
| 111 |
} |
|
| 112 |
} else {
|
|
| 113 |
# conditional.x |
|
| 114 | ||
| 115 |
# 4 possibilities: |
|
| 116 |
# - no meanstructure, no slopes |
|
| 117 |
# - meanstructure, no slopes |
|
| 118 |
# - no meanstructure, slopes |
|
| 119 |
# - meanstructure, slopes |
|
| 120 | ||
| 121 | ! |
S11 <- S.inv[-x.idx, -x.idx, drop = FALSE] |
| 122 | ||
| 123 |
# if (lav_use_lavaanC()) {
|
|
| 124 |
# Gamma.inv <- lavaanC::m_kronecker_dup_pre_post(S11, multiplicator = 0.5) |
|
| 125 |
# } else {
|
|
| 126 | ! |
Gamma.inv <- 0.5 * lav_matrix_duplication_pre_post(S11 %x% S11) |
| 127 |
# } |
|
| 128 | ||
| 129 | ! |
if (meanstructure || slopestructure) {
|
| 130 | ! |
C <- S[x.idx, x.idx, drop = FALSE] |
| 131 | ! |
MY <- M[-x.idx] |
| 132 | ! |
MX <- M[x.idx] |
| 133 | ! |
C3 <- rbind( |
| 134 | ! |
c(1, MX), |
| 135 | ! |
cbind(MX, C + tcrossprod(MX)) |
| 136 |
) |
|
| 137 |
} |
|
| 138 | ||
| 139 | ! |
if (meanstructure) {
|
| 140 | ! |
if (slopestructure) {
|
| 141 | ! |
A11 <- C3 %x% S11 |
| 142 |
} else {
|
|
| 143 | ! |
c11 <- 1 / solve(C3)[1, 1, drop = FALSE] |
| 144 | ! |
A11 <- c11 %x% S11 |
| 145 |
} |
|
| 146 |
} else {
|
|
| 147 | ! |
if (slopestructure) {
|
| 148 | ! |
A11 <- C %x% S11 |
| 149 |
} else {
|
|
| 150 | ! |
A11 <- matrix(0, 0, 0) |
| 151 |
} |
|
| 152 |
} |
|
| 153 | ||
| 154 | ! |
if (meanstructure || slopestructure) {
|
| 155 | ! |
Gamma.inv <- lav_matrix_bdiag(A11, Gamma.inv) |
| 156 |
} |
|
| 157 |
} |
|
| 158 | ||
| 159 | 6x |
Gamma.inv |
| 160 |
} |
| 1 |
# numeric approximation of the Hessian |
|
| 2 |
# using an analytic gradient |
|
| 3 |
lav_model_hessian <- function(lavmodel = NULL, |
|
| 4 |
lavsamplestats = NULL, |
|
| 5 |
lavdata = NULL, |
|
| 6 |
lavoptions = NULL, |
|
| 7 |
lavcache = NULL, |
|
| 8 |
group.weight = TRUE, |
|
| 9 |
ceq.simple = FALSE, |
|
| 10 |
h = 1e-06) {
|
|
| 11 | 44x |
estimator <- lavmodel@estimator |
| 12 | ||
| 13 |
# catch numerical gradient |
|
| 14 | 44x |
if (lavoptions$optim.gradient == "numerical") {
|
| 15 | ! |
obj.f <- function(x) {
|
| 16 | ! |
lavmodel2 <- lav_model_set_parameters(lavmodel, x = x) |
| 17 | ! |
lav_model_objective( |
| 18 | ! |
lavmodel = lavmodel2, |
| 19 | ! |
lavsamplestats = lavsamplestats, lavdata = lavdata, |
| 20 | ! |
lavcache = lavcache |
| 21 | ! |
)[1] |
| 22 |
} |
|
| 23 | ! |
x <- lav_model_get_parameters(lavmodel = lavmodel) |
| 24 | ! |
Hessian <- numDeriv::hessian(func = obj.f, x = x) |
| 25 | ! |
return(Hessian) |
| 26 |
} |
|
| 27 | ||
| 28 |
# computing the Richardson extrapolation |
|
| 29 | 44x |
if (!ceq.simple && lavmodel@ceq.simple.only) {
|
| 30 | ! |
npar <- lavmodel@nx.unco |
| 31 | ! |
type.glist <- "unco" |
| 32 |
} else {
|
|
| 33 | 44x |
npar <- lavmodel@nx.free |
| 34 | 44x |
type.glist <- "free" |
| 35 |
} |
|
| 36 | 44x |
Hessian <- matrix(0, npar, npar) |
| 37 | 44x |
x <- lav_model_get_parameters(lavmodel = lavmodel) |
| 38 | 44x |
if (!ceq.simple && lavmodel@ceq.simple.only) {
|
| 39 |
# unpack |
|
| 40 | ! |
x <- drop(x %*% t(lavmodel@ceq.simple.K)) |
| 41 |
} |
|
| 42 | 44x |
for (j in seq_len(npar)) {
|
| 43 |
# FIXME: the number below should vary as a function of 'x[j]' |
|
| 44 | 852x |
h.j <- h |
| 45 | 852x |
x.left <- x.left2 <- x.right <- x.right2 <- x |
| 46 | 852x |
x.left[j] <- x[j] - h.j |
| 47 | 852x |
x.left2[j] <- x[j] - 2 * h.j |
| 48 | 852x |
x.right[j] <- x[j] + h.j |
| 49 | 852x |
x.right2[j] <- x[j] + 2 * h.j |
| 50 | ||
| 51 | 852x |
g.left <- |
| 52 | 852x |
lav_model_gradient( |
| 53 | 852x |
lavmodel = lavmodel, |
| 54 | 852x |
GLIST = lav_model_x2glist( |
| 55 | 852x |
lavmodel = |
| 56 | 852x |
lavmodel, type = type.glist, |
| 57 | 852x |
x.left |
| 58 |
), |
|
| 59 | 852x |
lavsamplestats = lavsamplestats, |
| 60 | 852x |
lavdata = lavdata, |
| 61 | 852x |
lavcache = lavcache, |
| 62 | 852x |
type = "free", |
| 63 | 852x |
group.weight = group.weight, |
| 64 | 852x |
ceq.simple = ceq.simple |
| 65 |
) |
|
| 66 | 852x |
g.left2 <- |
| 67 | 852x |
lav_model_gradient( |
| 68 | 852x |
lavmodel = lavmodel, |
| 69 | 852x |
GLIST = lav_model_x2glist( |
| 70 | 852x |
lavmodel = |
| 71 | 852x |
lavmodel, type = type.glist, |
| 72 | 852x |
x.left2 |
| 73 |
), |
|
| 74 | 852x |
lavsamplestats = lavsamplestats, |
| 75 | 852x |
lavdata = lavdata, |
| 76 | 852x |
lavcache = lavcache, |
| 77 | 852x |
type = "free", |
| 78 | 852x |
group.weight = group.weight, |
| 79 | 852x |
ceq.simple = ceq.simple |
| 80 |
) |
|
| 81 | ||
| 82 | 852x |
g.right <- |
| 83 | 852x |
lav_model_gradient( |
| 84 | 852x |
lavmodel = lavmodel, |
| 85 | 852x |
GLIST = lav_model_x2glist( |
| 86 | 852x |
lavmodel = |
| 87 | 852x |
lavmodel, type = type.glist, |
| 88 | 852x |
x.right |
| 89 |
), |
|
| 90 | 852x |
lavsamplestats = lavsamplestats, |
| 91 | 852x |
lavdata = lavdata, |
| 92 | 852x |
lavcache = lavcache, |
| 93 | 852x |
type = "free", |
| 94 | 852x |
group.weight = group.weight, |
| 95 | 852x |
ceq.simple = ceq.simple |
| 96 |
) |
|
| 97 | ||
| 98 | 852x |
g.right2 <- |
| 99 | 852x |
lav_model_gradient( |
| 100 | 852x |
lavmodel = lavmodel, |
| 101 | 852x |
GLIST = lav_model_x2glist( |
| 102 | 852x |
lavmodel = |
| 103 | 852x |
lavmodel, type = type.glist, |
| 104 | 852x |
x.right2 |
| 105 |
), |
|
| 106 | 852x |
lavsamplestats = lavsamplestats, |
| 107 | 852x |
lavdata = lavdata, |
| 108 | 852x |
lavcache = lavcache, |
| 109 | 852x |
type = "free", |
| 110 | 852x |
group.weight = group.weight, |
| 111 | 852x |
ceq.simple = ceq.simple |
| 112 |
) |
|
| 113 | ||
| 114 | 852x |
Hessian[, j] <- (g.left2 - 8 * g.left + 8 * g.right - g.right2) / (12 * h.j) |
| 115 |
} |
|
| 116 | ||
| 117 |
# check if Hessian is (almost) symmetric, as it should be |
|
| 118 | 44x |
max.diff <- max(abs(Hessian - t(Hessian))) |
| 119 | 44x |
if (max.diff > 1e-05 * max(diag(Hessian))) {
|
| 120 |
# hm, Hessian is not symmetric -> WARNING! |
|
| 121 | ! |
lav_msg_warn(gettextf( |
| 122 | ! |
"Hessian is not fully symmetric. Max diff = %1$s (Max diag Hessian = %2$s)", |
| 123 | ! |
max.diff, max(diag(Hessian)))) |
| 124 |
# FIXME: use numDeriv::hessian instead? |
|
| 125 |
} |
|
| 126 | 44x |
Hessian <- (Hessian + t(Hessian)) / 2.0 |
| 127 | ||
| 128 | 44x |
Hessian |
| 129 |
} |
|
| 130 | ||
| 131 |
# if only chol would accept a complex matrix... |
|
| 132 |
lav_model_hessian_complex <- function(lavmodel = NULL, |
|
| 133 |
lavsamplestats = NULL, |
|
| 134 |
lavdata = NULL, |
|
| 135 |
lavcache = NULL, |
|
| 136 |
group.weight = TRUE) {
|
|
| 137 | ! |
gradf <- function(x) {
|
| 138 | ! |
GLIST <- lav_model_x2glist(lavmodel = lavmodel, x = x) |
| 139 | ! |
dx <- lav_model_gradient( |
| 140 | ! |
lavmodel = lavmodel, |
| 141 | ! |
GLIST = GLIST, |
| 142 | ! |
lavsamplestats = lavsamplestats, |
| 143 | ! |
lavdata = lavdata, |
| 144 | ! |
lavcache = lavcache, |
| 145 | ! |
type = "free", |
| 146 | ! |
group.weight = group.weight |
| 147 |
) |
|
| 148 | ! |
dx |
| 149 |
} |
|
| 150 | ||
| 151 | ! |
x <- lav_model_get_parameters(lavmodel = lavmodel) |
| 152 | ! |
Hessian <- lav_func_jacobian_complex(func = gradf, x = x) |
| 153 | ||
| 154 | ! |
Hessian |
| 155 |
} |
| 1 |
# casewise residuals |
|
| 2 | ||
| 3 |
lav_residuals_casewise <- function(object, labels = labels) {
|
|
| 4 | ||
| 5 |
# check object |
|
| 6 | 3x |
object <- lav_object_check_version(object) |
| 7 | ||
| 8 |
# check if we have full data |
|
| 9 | 3x |
if (object@Data@data.type != "full") {
|
| 10 | ! |
lav_msg_stop(gettext("casewise residuals not available if sample statistics
|
| 11 | ! |
were used for fitting the model")) |
| 12 |
} |
|
| 13 |
# check if we have categorical data |
|
| 14 | 3x |
if (object@Model@categorical) {
|
| 15 | ! |
lav_msg_stop(gettext( |
| 16 | ! |
"casewise residuals not available if data is categorical")) |
| 17 |
} |
|
| 18 | ||
| 19 | 3x |
G <- object@Data@ngroups |
| 20 | 3x |
ov.names <- object@Data@ov.names |
| 21 | ||
| 22 | 3x |
X <- object@Data@X |
| 23 | 3x |
if (object@Model@categorical) {
|
| 24 |
# add 'eXo' columns to X |
|
| 25 | ! |
X <- lapply(seq_len(object@Data@ngroups), function(g) {
|
| 26 | ! |
ret <- cbind(X[[g]], object@Data@eXo[[g]]) |
| 27 | ! |
ret |
| 28 |
}) |
|
| 29 |
} |
|
| 30 | 3x |
M <- lav_predict_yhat(object) |
| 31 |
# Note: if M has already class lavaan.matrix, print goes crazy |
|
| 32 |
# with Error: C stack usage is too close to the limit |
|
| 33 | 3x |
OUT <- lapply(seq_len(G), function(x) {
|
| 34 | 4x |
out <- X[[x]] - M[[x]] |
| 35 | 4x |
class(out) <- c("lavaan.matrix", "matrix")
|
| 36 | 4x |
out |
| 37 |
}) |
|
| 38 | ||
| 39 | 3x |
if (labels) {
|
| 40 | 3x |
for (g in 1:G) {
|
| 41 | 4x |
colnames(OUT[[g]]) <- object@pta$vnames$ov[[g]] |
| 42 |
} |
|
| 43 |
} |
|
| 44 | ||
| 45 | 3x |
if (G == 1) {
|
| 46 | 2x |
OUT <- OUT[[1]] |
| 47 |
} else {
|
|
| 48 | 1x |
names(OUT) <- unlist(object@Data@group.label) |
| 49 |
} |
|
| 50 | ||
| 51 | 3x |
OUT |
| 52 |
} |
| 1 |
# store pta in attributes of partable |
|
| 2 |
lav_partable_set_cache <- function(partable, pta = NULL, force = FALSE) {
|
|
| 3 | 1701x |
if (!force && |
| 4 | 1701x |
!is.null(attr(partable, "vnames")) && |
| 5 | 1701x |
!is.null(attr(partable, "nvar"))) {
|
| 6 | 391x |
return(partable) # cache already OK |
| 7 |
} |
|
| 8 | 1310x |
if (is.null(pta)) {
|
| 9 | 140x |
if (force) attr(partable, "vnames") <- NULL |
| 10 | 280x |
pta <- lav_partable_attributes(partable) |
| 11 |
} |
|
| 12 | ||
| 13 | 1310x |
for (n in names(pta)) {
|
| 14 | 13986x |
attr(partable, n) <- pta[[n]] |
| 15 |
} |
|
| 16 | ||
| 17 | 1310x |
partable |
| 18 |
} |
|
| 19 | ||
| 20 |
lav_partable_remove_cache <- function(partable) {
|
|
| 21 | 140x |
attributelist <- names(attributes(partable)) |
| 22 | ||
| 23 | 140x |
for (n in attributelist) {
|
| 24 | 1400x |
if (n != "ovda" && n != "names") attr(partable, n) <- NULL |
| 25 |
} |
|
| 26 | ||
| 27 | 140x |
partable |
| 28 |
} |
| 1 |
# lavMultipleImputation: fit the *same* model, on a set of imputed datasets |
|
| 2 |
# YR - 11 July 2016 |
|
| 3 | ||
| 4 |
lavMultipleImputation <- |
|
| 5 |
function(model = NULL, |
|
| 6 |
dataList = NULL, |
|
| 7 |
ndat = length(dataList), |
|
| 8 |
cmd = "sem", |
|
| 9 |
..., |
|
| 10 |
store.slots = c("partable"),
|
|
| 11 |
FUN = NULL, |
|
| 12 |
show.progress = FALSE, |
|
| 13 |
parallel = c("no", "multicore", "snow"),
|
|
| 14 |
ncpus = max(1L, parallel::detectCores() - 1L), |
|
| 15 |
cl = NULL) {
|
|
| 16 |
# dotdotdot |
|
| 17 | ! |
dotdotdot <- list() |
| 18 | ||
| 19 |
# fit multiple times |
|
| 20 | ! |
fit <- do.call("lavaanList", args = c(list(
|
| 21 | ! |
model = model, |
| 22 | ! |
dataList = dataList, ndat = ndat, cmd = cmd, |
| 23 | ! |
store.slots = store.slots, FUN = FUN, |
| 24 | ! |
show.progress = show.progress, |
| 25 | ! |
parallel = parallel, ncpus = ncpus, cl = cl |
| 26 | ! |
), dotdotdot)) |
| 27 | ||
| 28 |
# flag multiple imputation |
|
| 29 | ! |
fit@meta$lavMultipleImputation <- TRUE |
| 30 | ||
| 31 | ! |
fit |
| 32 |
} |
| 1 |
# read in information from Mplus difftest output, return as list |
|
| 2 |
# |
|
| 3 |
# line 1: test statistic (unscaled) |
|
| 4 |
# line 2: number of groups |
|
| 5 |
# line 3: number of sample statistics (ndat) |
|
| 6 |
# line 4: number of free parameters (npar) |
|
| 7 |
# delta (ndat x npar) |
|
| 8 |
# P1 (E.inv) lav_matrix_vechr(npar x npar) |
|
| 9 |
# V1 (NVarCov) lav_matrix_vechr(npar x npar) |
|
| 10 |
lavutils_mplus_readdifftest <- function(file = "deriv.dat") {
|
|
| 11 |
### FIXME: does not work for multiple groups yet!!! |
|
| 12 | ||
| 13 | ! |
raw <- scan(file, quiet = TRUE) |
| 14 | ! |
T1 <- raw[1] # function value (usually T1 * 2 * nobs to get X2) |
| 15 | ! |
ngroups <- as.integer(raw[2]) |
| 16 | ! |
ndat <- as.integer(raw[3]) |
| 17 | ! |
npar <- as.integer(raw[4]) |
| 18 | ! |
pstar <- npar * (npar + 1) / 2 |
| 19 | ||
| 20 |
# delta |
|
| 21 | ! |
offset <- 4L |
| 22 | ! |
delta_raw <- raw[offset + seq_len(npar * ndat)] |
| 23 | ! |
Delta <- matrix(delta_raw, nrow = ndat, ncol = npar, byrow = TRUE) |
| 24 | ||
| 25 |
# P1 |
|
| 26 | ! |
offset <- 4L + npar * ndat |
| 27 | ! |
p1_raw <- raw[offset + seq_len(pstar)] |
| 28 | ! |
P1 <- lav_matrix_lower2full(p1_raw) |
| 29 | ||
| 30 |
# (robust) NACOV npar |
|
| 31 | ! |
offset <- 4L + npar * ndat + pstar |
| 32 | ! |
nacov_raw <- raw[offset + seq_len(pstar)] |
| 33 | ! |
V1 <- lav_matrix_lower2full(nacov_raw) |
| 34 | ||
| 35 |
# just for fun, M1 |
|
| 36 |
# M1 <- (P1 - P1 %*% H %*% solve(t(H) %*% P1 %*% H) %*% t(H) %*% P1) %*% V1 |
|
| 37 | ||
| 38 | ! |
list( |
| 39 | ! |
T1 = T1, ngroups = ngroups, ndat = ndat, npar = npar, pstar = pstar, |
| 40 | ! |
Delta = Delta, P1 = P1, V1 = V1 |
| 41 |
) |
|
| 42 |
} |
| 1 |
# various fit measures |
|
| 2 | ||
| 3 |
# - lav_fit_cn |
|
| 4 |
# - lav_fit_wrmr |
|
| 5 |
# - lav_fit_mfi |
|
| 6 |
# - lav_fit_ecvi |
|
| 7 | ||
| 8 |
# Y.R. 21 July 2022 |
|
| 9 | ||
| 10 |
# Hoelter Critical N (CN) |
|
| 11 |
lav_fit_cn <- function(X2 = NULL, df = NULL, N = NULL, alpha = 0.05) {
|
|
| 12 |
# catch df=0, X2=0 |
|
| 13 | 38x |
if (df == 0 && X2 < sqrt(.Machine$double.eps)) { # added sqrt() in 0.6-21
|
| 14 | 12x |
CN <- as.numeric(NA) |
| 15 |
} else {
|
|
| 16 | 26x |
CN <- qchisq(p = (1 - alpha), df = df) / (X2 / N) + 1 |
| 17 |
} |
|
| 18 | ||
| 19 | 38x |
CN |
| 20 |
} |
|
| 21 | ||
| 22 |
# WRMR |
|
| 23 |
# we use the definition: wrmr = sqrt ( 2*N*F / nel ) |
|
| 24 |
# Note: when multiple groups, 'nel' only seems to correspond to the |
|
| 25 |
# first group??? |
|
| 26 |
lav_fit_wrmr <- function(X2 = NULL, nel = NULL) {
|
|
| 27 | 1x |
if (nel > 0) {
|
| 28 | 1x |
WRMR <- sqrt(X2 / nel) |
| 29 |
} else {
|
|
| 30 | ! |
WRMR <- as.numeric(NA) |
| 31 |
} |
|
| 32 | ||
| 33 | 1x |
WRMR |
| 34 |
} |
|
| 35 | ||
| 36 |
# MFI - McDonald Fit Index (McDonald, 1989) |
|
| 37 |
lav_fit_mfi <- function(X2 = NULL, df = NULL, N = NULL) {
|
|
| 38 | 19x |
MFI <- exp(-0.5 * (X2 - df) / N) |
| 39 | 19x |
MFI |
| 40 |
} |
|
| 41 | ||
| 42 |
# ECVI - cross-validation index (Brown & Cudeck, 1989, eq 5) |
|
| 43 |
# "In the special case where F = F_ML, Equation 5 [=ECVI] is the |
|
| 44 |
# rescaled AIC employed by Cudeck and Browne (1983, Equation 5.1). This |
|
| 45 |
# result is concordant with a finding of Stone (1977). He showed under general |
|
| 46 |
# conditions that if the "leaving one out at a time" method of cross-validation |
|
| 47 |
# (Stone, 1974; Geisser, 1975) is employed, a log-likelihood measure of |
|
| 48 |
# predictive validity is asymptotically equivalent to the AIC." (p. 448) |
|
| 49 | ||
| 50 |
# not defined for multiple groups and/or models with meanstructures |
|
| 51 |
# TDJ: According to Dudgeon (2004, p. 317), "ECVI requires no adjustment |
|
| 52 |
# when a model is fitted simultaneously in multiple samples." |
|
| 53 |
# And I think the lack of mean structure in Brown & Cudeck (1989) |
|
| 54 |
# was a matter of habitual simplification back then, not necessity. |
|
| 55 |
# YR: - why does Dudgeon eq 22 use (df + 2*npar) instead of (2*npar)?? |
|
| 56 |
lav_fit_ecvi <- function(X2 = NULL, npar = npar, N = N) {
|
|
| 57 | 18x |
ECVI <- X2 / N + (2 * npar) / N |
| 58 | 18x |
ECVI |
| 59 |
} |
| 1 |
# in separate file LDW 06/04/2024 |
|
| 2 | ||
| 3 |
# rename names of se values, and check for invalid values |
|
| 4 |
lav_options_check_se <- function(opt = NULL) {
|
|
| 5 |
# unlike test=, se= should be a single character string |
|
| 6 | ! |
if (length(opt$se) > 1L) opt$se <- opt$se[1] |
| 7 | ||
| 8 |
# backwards compatibility (0.4 -> 0.5) |
|
| 9 | 79x |
if (opt$se == "first.order") {
|
| 10 | ! |
opt$se <- "standard" |
| 11 | ! |
opt$information[1] <- "first.order" |
| 12 | ! |
if (length(opt$information) > 1L && |
| 13 | ! |
opt$information[2] == "default") {
|
| 14 | ! |
opt$information[2] <- "first.order" |
| 15 |
} |
|
| 16 | 79x |
} else if (opt$se == "observed") {
|
| 17 | ! |
opt$se <- "standard" |
| 18 | ! |
opt$information[1] <- "observed" |
| 19 | ! |
if (length(opt$information) > 1L && |
| 20 | ! |
opt$information[2] == "default") {
|
| 21 | ! |
opt$information[2] <- "observed" |
| 22 |
} |
|
| 23 | 79x |
} else if (opt$se == "expected") {
|
| 24 | ! |
opt$se <- "standard" |
| 25 | ! |
opt$information[1] <- "expected" |
| 26 | ! |
if (length(opt$information) > 1L && |
| 27 | ! |
opt$information[2] == "default") {
|
| 28 | ! |
opt$information[2] <- "expected" |
| 29 |
} |
|
| 30 |
} |
|
| 31 | ||
| 32 |
# handle generic 'robust' (except clustered/multilvel) |
|
| 33 |
# else if(opt$se == "robust" && !opt$.clustered && !opt$.multilevel) {
|
|
| 34 |
# if(opt$missing %in% c("ml", "ml.x")) {
|
|
| 35 |
# opt$se <- "robust.huber.white" |
|
| 36 |
# } else if(opt$missing == "two.stage") {
|
|
| 37 |
# opt$se <- "two.stage" |
|
| 38 |
# } else if(opt$missing == "robust.two.stage") {
|
|
| 39 |
# opt$se <- "robust.two.stage" |
|
| 40 |
# } else {
|
|
| 41 |
# # depends on estimator! |
|
| 42 |
# opt$se <- "robust.sem" |
|
| 43 |
# } |
|
| 44 |
# } |
|
| 45 | ||
| 46 |
# GLS, NTRLS, FML, UMN |
|
| 47 | 79x |
ok.flag <- TRUE |
| 48 | 79x |
if (any(opt$estimator == c("gls", "ntrls", "fml"))) {
|
| 49 | 6x |
ok.flag <- any(opt$se == c( |
| 50 | 6x |
"default", "none", "standard", |
| 51 | 6x |
"bootstrap", "external" |
| 52 |
)) |
|
| 53 |
} |
|
| 54 | ||
| 55 |
# WLS, DLS, DWLS, WLSM, WLSMV, WLSMVS, ULS, ULSM, ULSMV, ULSMVS |
|
| 56 | 73x |
else if (any(opt$estimator == c( |
| 57 | 73x |
"wls", "dls", |
| 58 | 73x |
"dwls", "wlsm", "wlsmv", "wlsmvs", |
| 59 | 73x |
"uls", "ulsm", "ulsmv", "ulsmvs" |
| 60 |
))) {
|
|
| 61 | 4x |
ok.flag <- any(opt$se == c( |
| 62 | 4x |
"default", "none", "standard", |
| 63 | 4x |
"bootstrap", "external", |
| 64 | 4x |
"robust", "robust.sem", "robust.sem.nt" |
| 65 |
)) |
|
| 66 |
} |
|
| 67 | ||
| 68 |
# PML |
|
| 69 | 69x |
else if (opt$estimator == "pml") {
|
| 70 | ! |
ok.flag <- any(opt$se == c( |
| 71 | ! |
"default", "none", "standard", |
| 72 | ! |
"bootstrap", "external", |
| 73 | ! |
"robust.huber.white" |
| 74 |
)) |
|
| 75 |
} |
|
| 76 | ||
| 77 |
# FABIN, GUTTMAN1952, BENTLER1982, ... |
|
| 78 | 69x |
else if (any(opt$estimator == c( |
| 79 | 69x |
"fabin2", "fabin3", "mgm"))) {
|
| 80 | ! |
ok.flag <- any(opt$se == c("default", "none", "bootstrap", "external"))
|
| 81 |
} |
|
| 82 | ||
| 83 |
# OTHERS |
|
| 84 | 69x |
else if (any(opt$estimator == c("fml", "mml", "reml"))) {
|
| 85 | ! |
ok.flag <- any(opt$se == c("default", "none", "standard", "external"))
|
| 86 |
} |
|
| 87 | ||
| 88 | 79x |
if (!ok.flag) {
|
| 89 | ! |
lav_msg_stop(gettextf( |
| 90 | ! |
"invalid value (%1$s) in se= argument for estimator %2$s.", |
| 91 | ! |
opt$se, toupper(opt$estimator))) |
| 92 |
} |
|
| 93 | ||
| 94 | 79x |
opt |
| 95 |
} |
| 1 |
lav_lavaan_step13_vcov_boot <- function(lavoptions = NULL, |
|
| 2 |
lavmodel = NULL, |
|
| 3 |
lavsamplestats = NULL, |
|
| 4 |
lavdata = NULL, |
|
| 5 |
lavpartable = NULL, |
|
| 6 |
lavcache = NULL, |
|
| 7 |
lavimplied = NULL, |
|
| 8 |
lavh1 = NULL, |
|
| 9 |
x = NULL) {
|
|
| 10 |
# # # # # # # # # # # # # # # # |
|
| 11 |
# # 13. lavvcov + lavboot # # |
|
| 12 |
# # # # # # # # # # # # # # # # |
|
| 13 | ||
| 14 |
# set VCOV to NULL |
|
| 15 |
# if lavoptions$se not "none", "external", "twostep" and |
|
| 16 |
# lavmodel@nx.free > 0L and x converged or optim.method == "none" |
|
| 17 |
# compute VCOV via lav_model_vcov |
|
| 18 |
# if attribute BOOT.COEFF of VCOV not NULL, store it in lavboot$coef |
|
| 19 |
# lavvcov <- list(se = lavoptions$se, information = lavoptions$information, |
|
| 20 |
# vcov = VCOV1) |
|
| 21 |
# where VCOV1 = VCOV without attributes (except dim) or ... |
|
| 22 |
# NULL if lavoptions$store.vcov FALSE or |
|
| 23 |
# store.vcov=="default" and rotation="none" |
|
| 24 |
# if lavoptions$se == "external" |
|
| 25 |
# if lavpartable$se NULL |
|
| 26 |
# lavpartable$se <- lav_model_vcov_se(..., VCOV=NULL, BOOT=NULL) |
|
| 27 |
# + ** warning ** |
|
| 28 |
# if lavpartable not "external" or "none" or "twostep" |
|
| 29 |
# lavpartable$se <- lav_model_vcov_se(...) |
|
| 30 | ||
| 31 | 140x |
VCOV <- NULL # nolint |
| 32 | 140x |
if (lavoptions$se != "none" && lavoptions$se != "external" && |
| 33 | 140x |
lavoptions$se != "twostep" && |
| 34 | 140x |
(lavmodel@nefa == 0L || |
| 35 | 140x |
(lavmodel@nefa > 0L && lavoptions$rotation == "none") || |
| 36 | 140x |
(lavmodel@nefa > 0L && lavoptions$rotation.se == "delta") |
| 37 |
) && |
|
| 38 | 140x |
lavmodel@nx.free > 0L && (attr(x, "converged") || |
| 39 | 140x |
lavoptions$optim.method == "none")) {
|
| 40 | 101x |
if (lav_verbose()) {
|
| 41 | ! |
cat("computing VCOV for se =", lavoptions$se, "...")
|
| 42 |
} |
|
| 43 |
# special case: estimator = "IV" |
|
| 44 | 101x |
if (lavoptions$estimator %in% "IV" && !is.null(attr(x, "eqs"))) {
|
| 45 | ! |
VCOV <- lav_sem_miiv_vcov( |
| 46 | ! |
lavmodel = lavmodel, |
| 47 | ! |
lavsamplestats = lavsamplestats, |
| 48 | ! |
lavoptions = lavoptions, |
| 49 | ! |
lavpartable = lavpartable, |
| 50 | ! |
lavimplied = lavimplied, |
| 51 | ! |
lavh1 = lavh1, |
| 52 | ! |
eqs = attr(x, "eqs") |
| 53 |
) |
|
| 54 |
} else {
|
|
| 55 |
# everything else: |
|
| 56 | 101x |
VCOV <- lav_model_vcov( # nolint |
| 57 | 101x |
lavmodel = lavmodel, |
| 58 | 101x |
lavsamplestats = lavsamplestats, |
| 59 | 101x |
lavoptions = lavoptions, |
| 60 | 101x |
lavdata = lavdata, |
| 61 | 101x |
lavpartable = lavpartable, |
| 62 | 101x |
lavcache = lavcache, |
| 63 | 101x |
lavimplied = lavimplied, |
| 64 | 101x |
lavh1 = lavh1 |
| 65 |
) |
|
| 66 |
} |
|
| 67 | 101x |
if (lav_verbose()) {
|
| 68 | ! |
cat(" done.\n")
|
| 69 |
} |
|
| 70 |
} # VCOV |
|
| 71 | ||
| 72 |
# extract bootstrap results (if any) |
|
| 73 | 140x |
if (!is.null(attr(VCOV, "BOOT.COEF"))) {
|
| 74 | ! |
lavboot <- list() |
| 75 | ! |
lavboot$coef <- attr(VCOV, "BOOT.COEF") |
| 76 |
} else {
|
|
| 77 | 140x |
lavboot <- list() |
| 78 |
} |
|
| 79 | ||
| 80 |
# store VCOV in vcov |
|
| 81 |
# strip all attributes but 'dim' |
|
| 82 | 140x |
tmp.attr <- attributes(VCOV) |
| 83 | 140x |
VCOV1 <- VCOV # nolint |
| 84 | 140x |
attributes(VCOV1) <- tmp.attr["dim"] # nolint |
| 85 |
# store vcov? new in 0.6-6 |
|
| 86 | 140x |
if (!is.null(lavoptions$store.vcov) && !is.null(VCOV1)) {
|
| 87 | 100x |
if (is.logical(lavoptions$store.vcov) && !lavoptions$store.vcov) {
|
| 88 | ! |
VCOV1 <- NULL # nolint |
| 89 |
} |
|
| 90 | 100x |
if (is.character(lavoptions$store.vcov) && |
| 91 | 100x |
lavoptions$rotation == "none" && |
| 92 | 100x |
lavoptions$store.vcov == "default" && |
| 93 | 100x |
ncol(VCOV1) > 200L) {
|
| 94 | ! |
VCOV1 <- NULL # nolint |
| 95 |
} |
|
| 96 |
} |
|
| 97 | 140x |
lavvcov <- list( |
| 98 | 140x |
se = lavoptions$se, |
| 99 | 140x |
information = lavoptions$information[1], |
| 100 | 140x |
vcov = VCOV1 |
| 101 |
) |
|
| 102 | ||
| 103 |
# store se in partable |
|
| 104 | 140x |
if (lavoptions$se == "external") {
|
| 105 | ! |
if (is.null(lavpartable$se)) {
|
| 106 | ! |
lavpartable$se <- lav_model_vcov_se( |
| 107 | ! |
lavmodel = lavmodel, |
| 108 | ! |
lavpartable = lavpartable, |
| 109 | ! |
VCOV = NULL, BOOT = NULL |
| 110 |
) |
|
| 111 | ! |
lav_msg_warn(gettext( |
| 112 | ! |
"se = \"external\" but parameter table does not contain a `se' column")) |
| 113 |
} |
|
| 114 | 140x |
} else if (lavoptions$se %in% c("none", "twostep")) {
|
| 115 |
# do nothing |
|
| 116 |
} else {
|
|
| 117 | 105x |
lavpartable$se <- lav_model_vcov_se( |
| 118 | 105x |
lavmodel = lavmodel, |
| 119 | 105x |
lavpartable = lavpartable, |
| 120 | 105x |
VCOV = VCOV, |
| 121 | 105x |
BOOT = lavboot$coef |
| 122 |
) |
|
| 123 |
} |
|
| 124 | ||
| 125 | 140x |
list( |
| 126 | 140x |
lavpartable = lavpartable, |
| 127 | 140x |
lavvcov = lavvcov, |
| 128 | 140x |
VCOV = VCOV, |
| 129 | 140x |
lavmodel = lavmodel, |
| 130 | 140x |
lavboot = lavboot |
| 131 |
) |
|
| 132 |
} |
| 1 |
# lavSimulate: fit the *same* model, on simulated datasets |
|
| 2 |
# YR - 4 July 2016: initial version |
|
| 3 |
# YR - 15 Oct 2024: add iseed (similar to lavBootstrap) |
|
| 4 |
# YR - 26 Oct 2024: rm pop.model, add est.true argument |
|
| 5 | ||
| 6 |
lavSimulate <- function(model = NULL, # user model |
|
| 7 |
dataFunction = lav_data_simulate_old, |
|
| 8 |
dataFunction.args = list(), |
|
| 9 |
est.true = NULL, |
|
| 10 |
ndat = 1000L, |
|
| 11 |
cmd = "sem", |
|
| 12 |
..., |
|
| 13 |
store.slots = c("partable"),
|
|
| 14 |
FUN = NULL, |
|
| 15 |
show.progress = FALSE, |
|
| 16 |
store.failed = FALSE, |
|
| 17 |
parallel = c("no", "multicore", "snow"),
|
|
| 18 |
ncpus = max(1L, parallel::detectCores() - 1L), |
|
| 19 |
cl = NULL, |
|
| 20 |
iseed = NULL) {
|
|
| 21 |
# dotdotdot |
|
| 22 | ! |
dotdotdot <- list(...) |
| 23 | ||
| 24 |
# dotdotdot for fit.pop |
|
| 25 | ! |
dotdotdot.pop <- dotdotdot |
| 26 | ! |
dotdotdot.pop$verbose <- FALSE |
| 27 | ! |
dotdotdot.pop$debug <- FALSE |
| 28 | ! |
dotdotdot.pop$data <- NULL |
| 29 | ! |
dotdotdot.pop$sample.cov <- NULL |
| 30 | ||
| 31 |
# 'fit' model without data, check 'true' parameters |
|
| 32 | ! |
fit.pop <- do.call(cmd, |
| 33 | ! |
args = c(list(model = model), dotdotdot.pop) |
| 34 |
) |
|
| 35 | ||
| 36 |
# check est.true= argument |
|
| 37 | ! |
stopifnot(!missing(est.true), is.numeric(est.true), |
| 38 | ! |
length(fit.pop@ParTable$lhs) == length(est.true)) |
| 39 | ! |
fit.pop@ParTable$est <- est.true |
| 40 | ! |
fit.pop@ParTable$start <- est.true |
| 41 | ||
| 42 |
# per default, use 'true' values as starting values |
|
| 43 | ! |
if (is.null(dotdotdot$start)) {
|
| 44 | ! |
dotdotdot$start <- fit.pop |
| 45 |
} |
|
| 46 | ||
| 47 |
# no warnings during/after the simulations |
|
| 48 |
# add 'warn = FALSE' to args |
|
| 49 | ||
| 50 |
# generate simulations |
|
| 51 | ! |
fit <- do.call("lavaanList", args = c(list(
|
| 52 | ! |
model = model, |
| 53 | ! |
dataFunction = dataFunction, |
| 54 | ! |
dataFunction.args = dataFunction.args, |
| 55 | ! |
ndat = ndat, cmd = cmd, |
| 56 | ! |
store.slots = store.slots, FUN = FUN, |
| 57 | ! |
show.progress = show.progress, |
| 58 | ! |
store.failed = store.failed, |
| 59 | ! |
parallel = parallel, ncpus = ncpus, |
| 60 | ! |
cl = cl, iseed = iseed |
| 61 | ! |
), dotdotdot)) |
| 62 | ||
| 63 |
# flag this is a simulation |
|
| 64 | ! |
fit@meta$lavSimulate <- TRUE |
| 65 | ||
| 66 |
# store 'true' parameters in meta$est.true |
|
| 67 | ! |
fit@meta$est.true <- est.true |
| 68 | ||
| 69 | ! |
fit |
| 70 |
} |
| 1 |
lav_plot <- function( |
|
| 2 |
model = NULL, |
|
| 3 |
infile = NULL, |
|
| 4 |
varlv = FALSE, |
|
| 5 |
placenodes = NULL, |
|
| 6 |
edgelabelsbelow = NULL, |
|
| 7 |
group.covar.indicators = FALSE, |
|
| 8 |
common.opts = list(sloped.labels = TRUE, |
|
| 9 |
mlovcolors = c("lightgreen", "lightblue"),
|
|
| 10 |
italic = TRUE, |
|
| 11 |
lightness = 1, |
|
| 12 |
auto.subscript = TRUE), |
|
| 13 |
rplot = list(outfile = "", |
|
| 14 |
addgrid = TRUE), |
|
| 15 |
tikz = list(outfile = "", |
|
| 16 |
cex = 1.3, |
|
| 17 |
standalone = FALSE), |
|
| 18 |
svg = list(outfile = "", |
|
| 19 |
stroke.width = 2L, |
|
| 20 |
font.size = 20L, |
|
| 21 |
idx.font.size = 15L, |
|
| 22 |
dy = 5L, |
|
| 23 |
font.family = "Latin Modern Math, arial, Aerial, sans", |
|
| 24 |
standalone = FALSE) |
|
| 25 |
) {
|
|
| 26 | ! |
tmp <- lav_model_plotinfo(model, |
| 27 | ! |
infile = infile, |
| 28 | ! |
varlv = varlv) |
| 29 | ! |
tmp <- lav_plotinfo_positions(tmp, |
| 30 | ! |
placenodes = placenodes, |
| 31 | ! |
edgelabelsbelow = edgelabelsbelow, |
| 32 | ! |
group.covar.indicators = group.covar.indicators) |
| 33 | ! |
mc <- match.call() |
| 34 | ! |
create_rplot <- !is.null(mc$rplot) || (is.null(mc$tikz) && is.null(mc$svg)) |
| 35 | ! |
if (create_rplot) |
| 36 | ! |
do.call(lav_plotinfo_rgraph, c(list(plotinfo = tmp), |
| 37 | ! |
common.opts, |
| 38 | ! |
rplot)) |
| 39 | ! |
if (!is.null(mc$tikz)) |
| 40 | ! |
do.call(lav_plotinfo_tikzcode, c(list(plotinfo = tmp), |
| 41 | ! |
common.opts, |
| 42 | ! |
tikz)) |
| 43 | ! |
if (!is.null(mc$svg)) |
| 44 | ! |
do.call(lav_plotinfo_svgcode, c(list(plotinfo = tmp), |
| 45 | ! |
common.opts, |
| 46 | ! |
svg)) |
| 47 |
} |
| 1 |
# takes a model in lavaan syntax and the user's data and returns the covariance |
|
| 2 |
# matrix of observed variables. Useful so that the user can do things like |
|
| 3 |
# diagnose errors in the cov matrix, use cov2cor to look at the correlation |
|
| 4 |
# matrix, try and invert the sample covariance matrix, etc. |
|
| 5 | ||
| 6 |
# update 5/27/2011 JEB |
|
| 7 |
# changelog: using sem and inspect to get output. |
|
| 8 |
# This way, all arguments such as groups, etc, can be used |
|
| 9 |
# update 3 june 2011 YR: removed se="none" (since now implied by do.fit=FALSE) |
|
| 10 |
# update 13 dec 2011 YR: changed name (to avoid confusion with the |
|
| 11 |
# model-implied cov) |
|
| 12 |
lavInspectSampleCov <- function(model, data, ...) {
|
|
| 13 | ! |
fit <- sem(model, data = data, ..., do.fit = FALSE) |
| 14 | ! |
lavInspect(fit, "sampstat") |
| 15 |
} |
| 1 |
# lavMultipleGroups: fit the *same* model, on (typically a small number of) |
|
| 2 |
# groups/sets |
|
| 3 |
# YR - 11 July 2016 |
|
| 4 | ||
| 5 |
lavMultipleGroups <- |
|
| 6 |
function(model = NULL, |
|
| 7 |
dataList = NULL, |
|
| 8 |
ndat = length(dataList), |
|
| 9 |
cmd = "sem", |
|
| 10 |
..., |
|
| 11 |
store.slots = c("partable"),
|
|
| 12 |
FUN = NULL, |
|
| 13 |
show.progress = FALSE, |
|
| 14 |
parallel = c("no", "multicore", "snow"),
|
|
| 15 |
ncpus = max(1L, parallel::detectCores() - 1L), |
|
| 16 |
cl = NULL) {
|
|
| 17 |
# dotdotdot |
|
| 18 | ! |
dotdotdot <- list() |
| 19 | ||
| 20 |
# fit multiple times |
|
| 21 | ! |
fit <- do.call("lavaanList", args = c(list(
|
| 22 | ! |
model = model, |
| 23 | ! |
dataList = dataList, ndat = ndat, cmd = cmd, |
| 24 | ! |
store.slots = store.slots, FUN = FUN, |
| 25 | ! |
show.progress = show.progress, |
| 26 | ! |
parallel = parallel, ncpus = ncpus, cl = cl |
| 27 | ! |
), dotdotdot)) |
| 28 | ||
| 29 |
# store group labels (if any) |
|
| 30 | ! |
fit@meta$lavMultipleGroups <- TRUE |
| 31 | ! |
fit@meta$group.label <- names(dataList) |
| 32 | ||
| 33 | ! |
fit |
| 34 |
} |
| 1 |
lav_lavaan_step07_bounds <- function(lavoptions = NULL, |
|
| 2 |
lavh1 = NULL, |
|
| 3 |
lavdata = NULL, |
|
| 4 |
lavsamplestats = NULL, |
|
| 5 |
lavpartable = NULL) {
|
|
| 6 |
# # # # # # # # # # # # # # # |
|
| 7 |
# # 7. parameter bounds # # |
|
| 8 |
# # # # # # # # # # # # # # # |
|
| 9 | ||
| 10 |
# if lavoptions$optim.bounds not NULL and its members lower and upper |
|
| 11 |
# have length > 0L |
|
| 12 |
# modify lavpartable via lav_partable_add_bounds |
|
| 13 | ||
| 14 |
# automatic bounds (new in 0.6-6) |
|
| 15 | 140x |
if (!is.null(lavoptions$optim.bounds) || |
| 16 | 140x |
length(lavoptions$optim.bounds$lower) > 0L || |
| 17 | 140x |
length(lavoptions$optim.bounds$upper) > 0L) {
|
| 18 | 140x |
if (lav_verbose()) {
|
| 19 | ! |
cat("lavpartable bounds ...")
|
| 20 |
} |
|
| 21 | 140x |
lavpartable <- lav_partable_add_bounds( |
| 22 | 140x |
partable = lavpartable, |
| 23 | 140x |
lavh1 = lavh1, lavdata = lavdata, lavsamplestats = lavsamplestats, |
| 24 | 140x |
lavoptions = lavoptions |
| 25 |
) |
|
| 26 | 140x |
if (lav_verbose()) {
|
| 27 | ! |
cat(" done.\n")
|
| 28 |
} |
|
| 29 |
} |
|
| 30 | ||
| 31 | 140x |
lavpartable |
| 32 |
} |
| 1 |
.onAttach <- function(libname, pkgname) {
|
|
| 2 | 1x |
version <- read.dcf( |
| 3 | 1x |
file = system.file("DESCRIPTION", package = pkgname),
|
| 4 | 1x |
fields = "Version" |
| 5 | 1x |
)[1] |
| 6 | 1x |
packageStartupMessage( |
| 7 | 1x |
"This is ", paste(pkgname, version), "\n", |
| 8 | 1x |
pkgname, " is FREE software! Please report any bugs." |
| 9 |
) |
|
| 10 |
} |